1 files changed, 0 insertions, 333707 deletions

diff --git a/test/macro/vba_streams/excel-vba-streams-#1.bas b/test/macro/vba_streams/excel-vba-streams-#1.bas
deleted file mode 100644
index 33f1db36c..000000000
--- a/test/macro/vba_streams/excel-vba-streams-#1.bas
+++ /dev/null
@@ -1,333707 +0,0 @@
-Project Name : 'ProjectFoo'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Simple
->>>>>>
-Attribute VB_Name = "Simple"

-Function SGetThree()

-SGetThree = 3

-End Function

-

-Function SLoop()

-Dim i As Integer

-Dim j As Integer

-j = 0

-For i = 0 To 10

-    j = j + 1

-Next i

-SLoop = j

-End Function

-

-Function SNoRetVal()

-End Function

-<<<<<<
-======================
-MoreComplex
->>>>>>
-Attribute VB_Name = "MoreComplex"

-Function MGetThree()

-MGetThree = 3

-If MGetThree = 2 Then

- MsgBox ("Hello World")

-End If

-End Function

-

-Function MLoop()

-Dim i As Integer

-Dim j As Integer

-j = 0

-For i = 0 To 10

-    j = j + 1

-Next i

-If j = 17 Then

-    MLoop = Application.Sum(Range("A1:A10"))

-End If

-MLoop = j

-End Function

-

-Function MNoRetVal()

-Dim i As Integer

-End Function

-<<<<<<
-======================
-Real
->>>>>>
-Attribute VB_Name = "Real"

-Function CtoF(Centigrade)

-  CtoF = Centigrade * 9 / 5 + 32

-End Function

-

-Function WsF(Angle)

-  WsF = WorksheetFunction.Sinh(Angle)

-End Function

-<<<<<<
-======================
-FuncVal
->>>>>>
-Attribute VB_Name = "FuncVal"

-Function MyString()

-MyString = "teststring"

-End Function

-

-Function MyDouble()

-MyDouble = 1 / 8

-End Function

-

-Function MyBoolean()

-MyBoolean = False

-End Function

-

-Function MyInt()

-MyInt = 7

-End Function

-

-Function TakeOneArg(arg1)

-TakeOneArg = arg1

-End Function

-

-Function TakeTwoArgs(arg1, arg2)

-TakeTwoArgs = arg2

-End Function

-

-Function TakeThreeArgs(arg1, arg2, arg3)

-TakeThreeArgs = arg3

-End Function

-

-Function ContainsComment()

-Rem This is a comment

-ContainsComment = 3

-End Function

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-   

-    On Error Resume Next

-    Worksheets("Example4").ChartObjects.Delete

- 

-End Sub

-

-Private Sub Workbook_Open()

-    Worksheets("Change History").Activate

-    Range("VersionStart").Select

-    Selection.End(xlDown).Select

-    Selection.Copy (Worksheets("Overview").Range("VersionNumber"))

-    

-    On Error Resume Next

-    Worksheets("Example4").ChartObjects.Delete

-    

-    Worksheets("Overview").Activate

-    Range("A1").Activate

-

-End Sub

-<<<<<<
-======================
-UserForm1
->>>>>>
-Attribute VB_Name = "UserForm1"

-Attribute VB_Base = "0{DFA44B18-A9D7-11DA-9F20-0000E8226B19}{DFA44B00-A9D7-11DA-9F20-0000E8226B19}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-Dim ComboChoices()

-Private Sub CheckBox1_Click()

-

-End Sub

-

-Private Sub ComboBox1_Change()

-

-End Sub

-

-Private Sub CommandButton1_Click()

-    With UserForm1

-        .ValueOfTextBox.Value = .TextBox1.Value

-        .StateOfCheckBox.Value = .CheckBox1.Value

-        .StateOfOption1.Value = .OptionButton1.Value

-        .StateOfOption2.Value = .OptionButton2.Value

-        

-        If .ComboBox1.ListIndex > -1 Then

-            .SelectedItemComboBox.Value = ComboChoices(.ComboBox1.ListIndex)

-        Else

-            .SelectedItemComboBox.Value = "Unkown"

-        End If

-    End With

-End Sub

-

-Private Sub Label2_Click()

-

-End Sub

-

-Private Sub OptionButton1_Click()

-

-End Sub

-

-Private Sub Label3_Click()

-

-End Sub

-

-Private Sub UserForm_Click()

-

-End Sub

-

-Private Sub UserForm_Initialize()

-    ComboChoices = Array("Choice1", "Choice2", "Choice3")

-    With UserForm1.ComboBox1

-        .AddItem ComboChoices(0)

-        .AddItem ComboChoices(1)

-        .AddItem ComboChoices(2)

-    End With

-    

-    With UserForm1

-        .ValueOfTextBox.Value = ""

-        .StateOfCheckBox.Value = ""

-        .StateOfOption1.Value = ""

-        .StateOfOption2.Value = ""

-        .SelectedItemComboBox.Value = ""

-    End With

-    

-End Sub

-

-Private Sub ValueOfTextBox_Change()

-

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("WbkInformationArea").ClearContents

-    Application.Wait (Now() + TimeValue("00:00:01"))

-    Range("WbkPath").Value = ActiveWorkbook.Path

-    Range("WbkActiveWorkbook") = ActiveWorkbook.Name

-    Range("WbkActiveWorksheet") = ActiveSheet.Name

-    Range("WbkActiveCell") = ActiveCell.Address

-    Range("CurrentDateTime") = Now()

-    Range("WkShNameArea").ClearContents

-    Call ListAllWorksheets

-End Sub

-

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("WbkActiveCell") = Target.Address

-    Range("CurrentDateTime") = Now()

-End Sub

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CommandButton3Ex5, 3, 2, MSForms, CommandButton"

-

-Private Sub CommandButton3Ex5_Click()

-    Call ElementOperations

-End Sub

-

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Not (Intersect(Target, Range("MyCell")) Is Nothing) Then

-        Select Case LCase(Target.Value)

-            Case "a", "e", "i", "o", "u"

-                Range("MsgCell").Value = "vowel"

-                

-            Case "b" To "d", "f" To "h", "j" To "n", "p" To "t", "v" To "z"

-                Range("MsgCell").Value = "consonant"

-            

-            Case 0 To 9

-                Range("MsgCell").Value = "number"

-                

-            Case Else

-                Range("MsgCell").Value = "unknown"

-        End Select

-        Target.Select

-    End If

-    

-    If Not (Intersect(Target, Range("MyVector")) Is Nothing) Then

-        Range("ElementProduct").ClearContents

-        Range("ElementSum").ClearContents

-    End If

-End Sub

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CommandButton1Ex4, 2, 0, MSForms, CommandButton"

-Private Sub CommandButton1Ex4_Click()

-    Call GenerateChart

-End Sub

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CommandButtonEx6, 1, 0, MSForms, CommandButton"

-Private Sub CommandButtonEx6_Click()

-        MsgBox "Button Click recognized"

-End Sub

-

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CommandButton2Ex2, 2, 1, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton3Ex2, 3, 2, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton4Ex2, 5, 4, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton5Ex2, 6, 5, MSForms, CommandButton"

-Private Sub CommandButton1Ex2_Click()

-    Call getApplProperties

-End Sub

-

-Private Sub CommandButton2Ex2_Click()

-    Call generateDataToSort

-End Sub

-

-Private Sub CommandButton3Ex2_Click()

-    Call SortWithScreenUpdating

-End Sub

-

-Private Sub CommandButton4Ex2_Click()

-    Call SortWithNoScreenUpdating

-End Sub

-

-Private Sub CommandButton5Ex2_Click()

-    Call generateDataToSort

-End Sub

-

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-

-End Sub

-<<<<<<
-======================
-SampleCode
->>>>>>
-Attribute VB_Name = "SampleCode"

-'''

-''' Contains various VBA coding examples on accessing the Application Object

-'''

-Option Explicit

-

-Sub generateDataToSort()

-    Dim i As Integer

-    

-    With Range("SortArray")

-        For i = 1 To .Rows.Count

-            .Cells(i) = Int((100 * Rnd) + 1)    ' Generate random value between 1 and 100.

-        Next i

-    End With

-

-End Sub

-

-Sub SortWithScreenUpdating()

-    Application.ScreenUpdating = True

-    Call BubbleSort(Range("SortArray"))

-    Range("SortArray").Select

-    MsgBox "Sorting Completed"

-End Sub

-Sub SortWithNoScreenUpdating()

-    Application.ScreenUpdating = False

-    Call BubbleSort(Range("SortArray"))

-    Range("SortArray").Select

-    Application.ScreenUpdating = True

-    MsgBox "Sorting Completed"

-End Sub

-

-Sub BubbleSort(rngToSort As Range)

-    Dim i, j As Integer

-    Dim Temp As Variant

-

-    With rngToSort

-        For j = .Rows.Count To 1 Step -1

-            For i = 1 To j

-                .Cells(i).Interior.ColorIndex = 6

-                .Cells(j).Interior.ColorIndex = 8

-                Application.Wait (Now + TimeValue("0:00:01"))

-                If .Cells(i) > .Cells(j) Then

-                    Temp = .Cells(i)

-                    .Cells(i) = .Cells(j)

-                    .Cells(j) = Temp

-                End If

-                .Cells(i).Interior.ColorIndex = xlColorIndexNone

-                .Cells(j).Interior.ColorIndex = xlColorIndexNone

-            Next i

-        Next j

-    

-    End With

-

-End Sub

-

-Sub ElementOperations()

-    Range("ElementProduct").Value = WorksheetFunction.Sum(Range("MyVector"))

-    Range("ElementSum").Value = WorksheetFunction.Product(Range("MyVector"))

-End Sub

-

-Sub ListAllWorksheets()

-    Dim wksh As Worksheet

-    Dim i As Integer

-    

-    With Range("WkShNames")

-        i = 1

-        For Each wksh In ActiveWorkbook.Worksheets

-            .Cells(i).Value = wksh.Name

-            i = i + 1

-        Next

-    End With

-

-End Sub

-

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CommandButton1Ex7, 1, 0, MSForms, CommandButton"

-Private Sub CommandButton1Ex7_Click()

-    UserForm1.Show

-End Sub

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ChartDemoCode
->>>>>>
-Attribute VB_Name = "ChartDemoCode"

-Sub GenerateChart()

-Attribute GenerateChart.VB_Description = "Macro recorded 5/14/2004 by Jim Thompson"

-Attribute GenerateChart.VB_ProcData.VB_Invoke_Func = " \n14"

-'

-' Macro2 Macro

-' Macro recorded 5/14/2004 by Jim Thompson

-'

-

-'

-    Range("ChartData").Select

-    Charts.Add

-    ActiveChart.ChartType = xlColumnClustered

-    ActiveChart.Name = "Sample Chart"

-    ActiveChart.SetSourceData Source:=Sheets("Example4").Range("ChartData"), PlotBy:= _

-        xlColumns

-    ActiveChart.Location Where:=xlLocationAsObject, Name:="Example4"

-    With ActiveChart

-        .HasTitle = True

-        .HasLegend = False

-        .ChartTitle.Characters.Text = "Sample Chart"

-        .Axes(xlCategory, xlPrimary).HasTitle = True

-        .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Category"

-        .Axes(xlValue, xlPrimary).HasTitle = True

-        .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Amount"

-    End With

-    

-    Range("ChartData").Select

-End Sub

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CommandButton1Ex3, 1, 0, MSForms, CommandButton"

-Private Sub CommandButton1Ex3_Click()

-    Application.Wait (Now + TimeValue("00:00:01"))

-    Range("UpperLeftCell").Select

-    Range("RangeAddress") = Selection.Address

-    Application.Wait (Now + TimeValue("00:00:01"))

-    Selection.End(xlToRight).Select

-    Range("RangeAddress") = Selection. _

-          Address

-    Application.Wait (Now + TimeValue("00:00:01"))

-    Selection.End(xlDown).Select

-    Range("RangeAddress") = Selection.Address

-    Application.Wait (Now + TimeValue("00:00:01"))

-    Selection.End(xlToLeft).Select

-    Range("RangeAddress") = Selection.Address

-    Application.Wait (Now + TimeValue("00:00:01"))

-    Selection.End(xlUp).Select

-    Range("RangeAddress") = Selection.Address

-    Application.Wait (Now + TimeValue("00:00:01"))

-    Range(Selection, Selection.End(xlToRight)).Select

-    Range("RangeAddress") = Selection.Address

-    Application.Wait (Now + TimeValue("00:00:01"))

-    Range("UpperLeftCell").Select

-    Range("RangeAddress") = Selection.Address

-    Application.Wait (Now + TimeValue("00:00:01"))

-    Range(Selection, Selection.End(xlDown)).Select

-    Range("RangeAddress") = Selection.Address

-    Application.Wait (Now + TimeValue("00:00:01"))

-    Range("UpperLeftCell").Select

-    Range("RangeAddress") = Selection.Address

-    Application.Wait (Now + TimeValue("00:00:01"))

-    Selection.CurrentRegion.Select

-    Range("RangeAddress") = Selection.Address

-End Sub

-

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CommandButton1, 1, 0, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton2, 2, 1, MSForms, CommandButton"

-Private Sub CommandButton1_Click()

-test_main

-End Sub

-

-Private Sub CommandButton2_Click()

-init

-End Sub

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Option Base 1

-Dim numTests As Integer

-

-Sub init()

-numTests = 23

-reset_results

-End Sub

-Sub test_main()

-init

-On Error Resume Next ' comment out this line to help debug errors

-test1

-test2

-test3

-test4

-test5

-test6

-test7

-test8

-test9

-test10

-test11

-test12

-test13

-test14

-test15

-test16

-test17

-test18

-test19

-test20

-test21

-test22

-test23

-display_results

-End Sub

-

-

-' result for test 1 is in named range test1

-' Tests .Value property LHS assignment

-Sub test1()

-Range("B1").Value = 50

-If Range("B1").Value = 50 Then

-    Range("test1").Value = 1

-End If

-End Sub

-' result for test 2 is in named range test2

-' Tests ( default ) .Value property LHS assignment

-Sub test2()

-Range("B2") = 50

-If Range("B2").Value = 50 Then

-    Range("test2").Value = 1

-End If

-End Sub

-' result for test 3 is in named range test3

-' Tests RHS .Value property assignment

-

-Sub test3()

-Dim testVal As Integer

-testVal = 99

-Range("B3").Value = 50

-testVal = Range("B3").Value

-If testVal = 50 Then

-    Range("test3").Value = 1

-End If

-End Sub

-

-' result for test 4 is in named range test4

-' Tests RHS .Value default property assignment

-

-Sub test4()

-Dim testVal As Integer

-testVal = 99

-Range("B4").Value = 50

-testVal = Range("B4")

-If testVal = 50 Then

-    Range("test4").Value = 1

-End If

-End Sub

-' result for test 5 is in named range test5

-' Tests Range("XX") = Range("YY").Value ( lhs) default value property assignment

-' LHS is a cleared cell

-Sub test5()

-Range("B5").Value = 50

-Range("B6") = Range("B5").Value

-If Range("B6").Value = 50 Then

-    Range("test5").Value = 1

-End If

-

-End Sub

-

-' result for test 6 is in named range test6

-' Tests Range("XX").Value = Range("YY") ( rhs) default value property access

-' LHS is a cleared cell

-Sub test6()

-Range("B7").Value = 50

-Range("B8").Value = Range("B7")

-If Range("B8").Value = 50 Then

-    Range("test6").Value = 1

-End If

-End Sub

-' result for test 7 is in named range test7

-' Tests Range("XX") = Range("YY")

-' (rhs) default value property access

-' (lhs) default value property set

-' LHS is a cleared cell

-Sub test7()

-Range("B9").Value = 50

-Range("B10") = Range("B9")

-If Range("B10").Value = 50 Then

-    Range("test7").Value = 1

-End If

-End Sub

-

-' result for test 8 is in named range test8

-' Tests set objectVariable to a Range("YY") object

-Sub test8()

-Dim aRange As Object

-Range("B11") = 99

-Set aRange = Range("B11")

-If aRange.Value = 99 Then

-    Range("test8").Value = 1

-End If

-End Sub

-' result for test 9 is in named range test9

-' Tests Multiplication of a range, in Openoffice

-' val = Range("B12") * 0.1

-' this was failing due to Range("B12") getting overwritten

-' with the result of the calculation e.g. Range("B12") had 9 if

-' initial value of B12 was 90

-Sub test9()

-Range("B12").Value = 90

-Dim val As Integer

-val = 0

-val = (Range("B12") * 0.1)

-Range("B13") = val

-If Range("B13").Value = 9 And Range("B12").Value = 90 Then

-    Range("test9").Value = 1

-End If

-End Sub

-' result for test 10 is in named range test10

-' Tests multiplication of Range, there was a bug

-' in OO where "B15" in the test below would be overwritten

-' with 10

-Sub test10()

-Range("B15") = 100

-Range("B14") = (Range("B15") * 0.1)

-If Range("B14").Value = 10 And Range("B15") = 100 Then

-    Range("test10").Value = 1

-End If

-

-End Sub

-

-

-' result for test 11 is in named range test11

-' test the result of a 2-Dim range value prop

-' which should be a 2 Dim array containing the values

-' as set up in the tests below

-' e.g.

-' 1 4 7 10

-' 2 5 8 11

-' 3 6 9 12

-

-Sub test11()

-Dim testDatasc1

-Dim testDatasc2

-Dim testDatasc3

-Dim testDatasc4

-Dim cellNamesc1

-Dim cellNamesc2

-Dim cellNamesc3

-

-Dim cellName As String

-Dim cellval As Integer

-Dim colValues()

-

-testDatac1 = Array(1, 2, 3)

-testDatac2 = Array(4, 5, 6)

-testDatac3 = Array(7, 8, 9)

-testDatac4 = Array(10, 11, 12)

-

-colValues = Array(testDatac1, testDatac2, testDatac3, testDatac4)

-

-cellNamesc1 = Array("D1", "D2", "D3")

-cellNamesc2 = Array("E1", "E2", "E3")

-cellNamesc3 = Array("F1", "F2", "F3")

-cellNamesc4 = Array("G1", "G2", "G3")

-

-' set cellnames with values

-arrayset cellNamesc1, testDatac1

-arrayset cellNamesc2, testDatac2

-arrayset cellNamesc3, testDatac3

-arrayset cellNamesc4, testDatac4

-

-Dim contents As Variant

-Dim colcontents As Variant

-

-' get contents of range

-

-contents = Range("D1:G3").Value

-Dim lcol As Integer

-Dim ucol As Integer

-Dim col As Integer

-lcol = LBound(contents, 2)

-ucol = UBound(contents, 2)

-Dim res As Integer

-result = 1 ' success

-

-' check values

-For col = lcol To ucol

-

-    colcontents = getCol(contents, col)

-    For counter = LBound(colcontents) To UBound(colcontents)

-        'MsgBox " content of col " & col & " index " & counter & " has value " & colcontents(counter)

-        If checkarray(colcontents, colValues(col)) = False Then

-            result = -1

-            Exit For

-        End If

-        

-    Next counter

-Range("test11").Value = result

-Next col

-

-

-' note

-' Range("D4:G6") = Range("D1:G3") does not do a copy

-' nor does Range("D4:G6") = Range("D1:G3".Value

-' or Range("D4:G6").Value = Range("D1:G3")

-End Sub

-

-' tests a copy of a multicell range to

-' a multi cell range of the same dimensions

-

-Sub test12()

-

-Dim testDatasc1

-Dim testDatasc2

-Dim testDatasc3

-Dim testDatasc4

-Dim cellNamesc1

-Dim cellNamesc2

-Dim cellNamesc3

-

-Dim cellName As String

-Dim cellval As Integer

-Dim colValues()

-

-testDatac1 = Array(1, 2, 3)

-testDatac2 = Array(4, 5, 6)

-testDatac3 = Array(7, 8, 9)

-testDatac4 = Array(10, 11, 12)

-

-colValues = Array(testDatac1, testDatac2, testDatac3, testDatac4)

-

-cellNamesc1 = Array("D6", "D7", "D8")

-cellNamesc2 = Array("E6", "E7", "E8")

-cellNamesc3 = Array("F6", "F7", "F8")

-cellNamesc4 = Array("G6", "G7", "G8")

-' set cellnames with values

-arrayset cellNamesc1, testDatac1

-arrayset cellNamesc2, testDatac2

-arrayset cellNamesc3, testDatac3

-arrayset cellNamesc4, testDatac4

-

-Range("D9:G11").Value = Range("D6:G8").Value

-

-' Check the result of Range("D9:G11")

-Dim result As Integer

-result = 1 ' assume pass

-

-Dim origcontents

-Dim copycontents

-

-origcontents = Range("D6:G8").Value

-copycontents = Range("D9:G11").Value

-Dim lb1 As Integer

-Dim ub1 As Integer

-Dim lb2 As Integer

-Dim ub2 As Integer

-lb1 = LBound(origcontents, 1)

-ub1 = UBound(origcontents, 1)

-lb2 = LBound(origcontents, 2)

-ub2 = UBound(origcontents, 2)

-Dim i As Integer

-Dim j As Integer

-For i = lb1 To ub1

-    For j = lb2 To ub2

-        If copycontents(i, j) <> origcontents(i, j) Then

-            result = -1

-            Exit For

-        End If

-    Next j

-    If result = -1 Then

-        Exit For

-    End If

-    

-Next i

-Range("test12").Value = result

-End Sub

-

-' test setting Range.Value with 2 Dim array

-

-Sub test13()

-Dim dArray

-dArray = Range("D12:g14")

-Dim lb1 As Integer

-Dim ub1 As Integer

-Dim lb2 As Integer

-Dim ub2 As Integer

-lb1 = LBound(dArray, 1)

-ub1 = UBound(dArray, 1)

-lb2 = LBound(dArray, 2)

-ub2 = UBound(dArray, 2)

-Dim count As Integer

-For i = lb1 To ub1

-    For j = lb2 To ub2

-        dArray(i, j) = count

-        count = count + 1

-    Next j

-Next i

-Range("D12:g14").Value = dArray

-

-' get values for Range

-Dim contents

-Dim result As Integer

-result = 1

-contents = Range("D12:g14").Value

-

-' compare to values from array

-For i = lb1 To ub1

-    For j = lb2 To ub2

-        If contents(i, j) <> dArray(i, j) Then

-            result = -1

-            Exit For

-        End If

-        count = count + 1

-    Next j

-    If result = -1 Then

-        Exit For

-    End If

-Next i

-

-Range("test13").Value = result

-End Sub

-' test Range("XX").Value = number

-' the number should be applied over the range

-Sub test14()

-

-Dim contents

-Dim dValue As Integer

-dValue = 99

-Range("D16:F17").Value = dValue

-

-contents = Range("D16:F17").Value

-Dim lb1 As Integer

-Dim ub1 As Integer

-Dim lb2 As Integer

-Dim ub2 As Integer

-Dim result As Integer

-result = 1 '

-lb1 = LBound(contents, 1)

-ub1 = UBound(contents, 1)

-lb2 = LBound(contents, 2)

-ub2 = UBound(contents, 2)

-For i = lb1 To ub1

-    For j = lb2 To ub2

-        If contents(i, j) <> dValue Then

-            result = -1

-            Exit For

-        End If

-    If result = -1 Then

-        Exit For

-    End If

-    

-        

-    Next j

-Next i

-Range("test14").Value = result

-End Sub

-' test assigment of row Range to a single Array

-Sub test15()

-Dim testData()

-testData = Array(1, 2, 3, 4, 5)

-Range("A20:E20").Value = testData()

-Dim resultData()

-resultData = Range("A20:E20").Value

-Dim result As Integer

-result = 1 '

-RowIndex = LBound(resultData, 1)

-For count = LBound(resultData, 2) To UBound(resultData, 2)

-    If resultData(RowIndex, count) <> testData(count) Then

-        result = -1

-        Exit For

-    End If

-        

-    

-Next count

-Range("test15") = result

-End Sub

-

-' test assigment of col Range to a single Array

-

-Sub test16()

-Dim testData()

-testData = Array(1, 2, 3, 4, 5)

-Range("A21:A25").Value = testData()

-Dim resultData()

-resultData = Range("A21:A25").Value

-Dim result As Integer

-result = 1 '

-ColIndex = LBound(resultData, 2)

-For count = LBound(resultData, 1) To UBound(resultData, 1)

-    If resultData(count, ColIndex) <> testData(LBound(testData)) Then

-        result = -1

-        Exit For

-    End If

-        

-    

-Next count

-Range("test16") = result

-End Sub

-

-' test assigment of range to a single Array

-' to a Range of the same row size

-Sub test17()

-Dim testData()

-testData = Array(1, 2, 3, 4, 5)

-Range("A28:E29").Value = testData()

-

-Dim resultData()

-resultData = Range("A28:E29").Value

-Dim result As Integer

-result = 1 '

-

-For row = LBound(resultData, 1) To UBound(resultData, 1)

-    For col = LBound(resultData, 2) To UBound(resultData, 2)

-    'MsgBox row & "," & col & " = " & resultData(row, col)

-        If resultData(row, col) <> testData(col) Then

-            result = -1

-            Exit For

-        End If

-    Next col

-Next row

-Range("test17") = result

-End Sub

-' Test18 tests ActiveSheet.Range( Cell1, Cell2 ) method

-' results involve no offset, unlike Range.Range( Cell1, Cell2 )

-' simple range

-Sub test18()

-Dim result As Integer

-Range("c5").Select

-result = 1

-If ActiveSheet.Range(Range("a2"), Range("d5")).Address <> "$A$2:$D$5" Then

-    result = -1

-End If

-Range("test18") = result

-

-End Sub

-' Test19 tests ActiveSheet.Range( Cell1, Cell2 ) method

-' results involve no offset, unlike Range.Range( Cell1, Cell2 )

-' more complex range, the range selected is the greatest range defined

-' by overlap of Cell1 & Cell2

-Sub test19()

-Dim result As Integer

-Range("c5").Select

-result = 1

-If ActiveSheet.Range(Range("a2:d6"), Range("d5:d8")).Address <> "$A$2:$D$8" Then

-    result = -1

-End If

-Range("test19") = result

-

-End Sub

-

-Sub test20()

-Dim result As Integer

-result = 1

-If Range("c5").Range("a2").Address <> "$C$6" Then

-    result = -1

-End If

-Range("test20") = result

-End Sub

-

-

-Sub test21()

-Dim result As Integer

-result = 1

-If Range("c5:f10").Range("g4").Address <> "$I$8" Then

-    result = -1

-End If

-Range("test21") = result

-End Sub

-

-Sub test22()

-Dim result As Integer

-result = 1

-If Range("c5:c8").Range(Range("g4"), Range("l10")).Address <> "$I$8:$N$14" Then

-    result = -1

-End If

-Range("test22") = result

-End Sub

-Sub test23()

-Dim result As Integer

-result = 1

-If Range("c5:f10").Range("g4:i8").Address <> "$I$8:$K$12" Then

-    result = -1

-End If

-Range("test23") = result

-End Sub

-

-Function getCol(matrix As Variant, col As Integer) As Variant

-Dim lrow As Integer

-Dim urow As Integer

-Dim row As Integer

-lrow = LBound(matrix, 1)

-urow = UBound(matrix, 1)

-

-Dim column()

-ReDim column(urow)

-

-For row = lrow To urow

-    'column(row) = matrix(col, row)

-    Dim val As Integer

-    column(row) = matrix(row, col)

-Next row

-getCol = column()

-End Function

-Function checkarray(values As Variant, newvalues As Variant) As Boolean

-Dim count As Integer

-Dim result As Boolean

-result = True

-For count = LBound(values) To UBound(values)

-    If values(count) <> newvalues(count) Then

-        result = False

-        Exit For

-    End If

-Next count

-checkarray = result

-End Function

-Sub arrayset(names As Variant, values As Variant)

-Dim count As Integer

-Dim cellName As String

-Dim cellval As Integer

-

-For count = LBound(names) To UBound(values)

-    cellName = names(count)

-    cellval = values(count)

-    Range(cellName).Value = cellval

-Next count

-End Sub

-

-Sub reset_results()

-For count = 1 To numTests

-    Range("test" & count).Value = -1

-Next count

-' test 1

-Range("B1").Clear

-' test 2

-Range("B2").Clear

-' test 3

-Range("B3").Clear

-' test 4

-Range("B4").Clear

-' test 5

-Range("B5").Clear

-Range("B6").Clear

-' test 6

-Range("B7").Clear

-Range("B8").Clear

-' test 7

-Range("B9").Clear

-Range("B10").Clear

-' test 8

-Range("B11").Clear

-' test 9

-Range("B12").Clear

-Range("B13").Clear

-' test 10

-Range("B14").Clear

-Range("B15").Clear

-' test 11

-Range("D1:G3").Clear

-' test 12

-Range("D6:G8").Clear

-Range("D9:g11").Clear

-' test 13

-Range("D12:g14").Clear

-' test 14

-Range("D16:F17").Clear

-' test 15

-Range("A20:E20").Clear

-' test 16

-Range("A20:A25").Clear

-' test 17

-Range("A28:E29").Clear

-End Sub

-

-Sub display_results()

-Dim results As String

-Dim failed As String

-

-Dim count As Integer

-Dim testsRun As Integer

-

-For count = 1 To numTests

-    If testResult("test" & count) = False Then

-        failed = failed & "      test" & count & " failed" & Chr$(10)

-    Else

-        succeeded = succeeded + 1

-    End If

-Next count

-testsRun = count - 1

-results = results & "No. tests: " & numTests & Chr$(10)

-

-results = results & "Summary" & Chr$(10)

-results = results & "=======" & Chr$(10)

-results = results & "Run:       " & testsRun & Chr$(10)

-results = results & "Passed:    " & succeeded & Chr$(10)

-results = results & "Failed:    " & (testsRun - succeeded) & Chr$(10)

-results = results & failed

-results = results & Chr$(10) + "Expected Failure On OpenOffice: test13"

-MsgBox results

-End Sub

-

-Function testResult(arg As String) As Boolean

-If (Range(arg).Value = 1) Then

-    testResult = True

-Else

-    testResult = False

-End If

-End Function

-

-

-Sub tempStuff()

-

-' in openoffice a1 = 5, in xl its 50

-' the line below seems not do the expected in xl (?)

-Range("B1") = 50

-Range("A1").Value = (Range("B1").Value * 0.1)

-MsgBox ("A1 = " + Range("A1"))

-Range("A1") = Range("B1").Value

-Range("B2") = 100

-Range("B3") = Range("B2")

-MsgBox "B3 = " & Range("B3")

-

-val = Range("A1")

-MsgBox (Range("A1"))

-    

-'Range("A5:A8").Value =Range("A1:A4").Value

-MsgBox (val)

-End Sub

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Sub main()

-test (xlCellTypeAllFormatConditions)

-test2 (Excel.XlCellType.xlCellTypeAllValidation)

-test3 (XlCellType.xlCellTypeAllValidation)

-test4 xlCellTypeSameValidation

-End Sub

-

-Function test(ByRef num As Integer)

-MsgBox "test got " & num

-End Function

-

-Function test2(num)

-MsgBox "test2 got " & num

-End Function

-

-

-Function test3(num)

-MsgBox "test3 got " & num

-End Function

-

-Function test4(num)

-MsgBox "test4 got " & num

-End Function

-<<<<<<
-Project Name : 'VBProject'
-Quirk - duff tag length======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Option Explicit

-Dim NextTick

-

-Sub StartClock()

-    UpdateClock

-End Sub

-

-Sub StopClock()

-'   Cancels the OnTime event (stops the clock)

-    On Error Resume Next

-    Application.OnTime NextTick, "UpdateClock", , False

-End Sub

-

-Sub cbClockType_Click()

-'   Hides or unhids the clock

-    With ThisWorkbook.Sheets("Clock")

-        If .DrawingObjects("cbClockType").Value = xlOn Then

-            .ChartObjects("ClockChart").Visible = True

-        Else

-            .ChartObjects("ClockChart").Visible = False

-        End If

-    End With

-End Sub

-

-Sub UpdateClock()

-'   Updates the clock that's visible

-    Dim Clock As Chart

-    Set Clock = ThisWorkbook.Sheets("Clock").ChartObjects("ClockChart").Chart

-    

-    If Clock.Parent.Visible Then

-'       ANALOG CLOCK

-        Const PI As Double = 3.14159265358979

-        Dim CurrentSeries As Series

-        Dim s As Series

-        Dim x(1 To 2) As Variant

-        Dim v(1 To 2) As Variant

-    

-'       Hour hand

-        Set CurrentSeries = Clock.SeriesCollection("HourHand")

-        x(1) = 0

-        x(2) = 0.5 * Sin((Hour(Time) + (Minute(Time) / 60)) * (2 * PI / 12))

-        v(1) = 0

-        v(2) = 0.5 * Cos((Hour(Time) + (Minute(Time) / 60)) * (2 * PI / 12))

-        CurrentSeries.XValues = x

-        CurrentSeries.Values = v

-        

-'       Minute hand

-        Set CurrentSeries = Clock.SeriesCollection("MinuteHand")

-        x(1) = 0

-        x(2) = 0.8 * Sin((Minute(Time) + (Second(Time) / 60)) * (2 * PI / 60))

-        v(1) = 0

-        v(2) = 0.8 * Cos((Minute(Time) + (Second(Time) / 60)) * (2 * PI / 60))

-        CurrentSeries.XValues = x

-        CurrentSeries.Values = v

-    

-'       Second hand

-        Set CurrentSeries = Clock.SeriesCollection("SecondHand")

-        x(1) = 0

-        x(2) = 0.85 * Sin(Second(Time) * (2 * PI / 60))

-        v(1) = 0

-        v(2) = 0.85 * Cos(Second(Time) * (2 * PI / 60))

-        CurrentSeries.XValues = x

-        CurrentSeries.Values = v

-    Else

-'       DIGITAL CLOCK

-        ThisWorkbook.Sheets("Clock").Range("DigitalClock").Value = CDbl(Time)

-    End If

-    

-'   Set up the next event one second from now

-    NextTick = Now + TimeValue("00:00:01")

-    Application.OnTime NextTick, "UpdateClock"

-End Sub

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Private Sub Workbook_Open()

-    Call StartClock

-End Sub

-

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    Call StopClock

-End Sub

-

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Option Explicit

-

-' Developed by John Walkenbach

-' of JWalk and Associates

-' http://www.j-walk.com/ss/

-' Thanks to GeeDee for suggesting the animation and colors.

-

-Dim r As Long

-

-

-

-

-Sub Scroller_Click()

-    Range("FavoriteNum").Value = " "

-End Sub

-Sub RandomButton_Click()

-    Application.ScreenUpdating = False

-    Range("a_inc").Value = Rnd() * 1000

-    Range("b_inc").Value = Rnd() * 1000

-    Range("t_inc").Value = Rnd() * 1000

-    Range("FavoriteNum").Value = ""

-    Application.ScreenUpdating = True

-End Sub

-

-Sub NextFavoriteButton_Click()

-    Application.ScreenUpdating = False

-    r = Range("FavoriteNum").Value + 1

-    If r > Application.CountA(Range("Favorites").EntireColumn) Then r = 1

-    Range("a_inc").Value = Range("Favorites").Offset(r - 1, 0).Value

-    Range("b_inc").Value = Range("Favorites").Offset(r - 1, 1).Value

-    Range("t_inc").Value = Range("Favorites").Offset(r - 1, 2).Value

-    Range("FavoriteNum").Value = r

-    Application.ScreenUpdating = True

-End Sub

-

-Sub PreviousFavoriteButton_Click()

-    Application.ScreenUpdating = False

-    r = Range("FavoriteNum").Value - 1

-    If r <= 0 Then r = Application.CountA(Range("Favorites").EntireColumn)

-    Range("a_inc").Value = Range("Favorites").Offset(r - 1, 0).Value

-    Range("b_inc").Value = Range("Favorites").Offset(r - 1, 1).Value

-    Range("t_inc").Value = Range("Favorites").Offset(r - 1, 2).Value

-    Range("FavoriteNum").Value = r

-    Application.ScreenUpdating = True

-End Sub

-

-Sub AddToFavoritesButton_Cklick()

-Attribute AddToFavoritesButton_Cklick.VB_ProcData.VB_Invoke_Func = " \n14"

-    Dim EmptyStr As String

-    EmptyStr = ""

-    

-    If Range("FavoriteNum").Value = EmptyStr Then

-        Application.ScreenUpdating = False

-        Application.Calculation = xlCalculationManual

-        r = Application.CountA(Range("Favorites").EntireColumn) + 1

-        Range("FavoriteNum").Value = r

-        Cells(r, Range("Favorites").Column) = Range("a_inc").Value

-        Cells(r, Range("Favorites").Column + 1) = Range("b_inc").Value

-        Cells(r, Range("Favorites").Column + 2) = Range("t_inc").Value

-        Application.Calculation = xlCalculationAutomatic

-        Application.ScreenUpdating = True

-    End If

-End Sub

-

-

-

-

-

-Sub InfoButton_Click()

-    ChartIsAnimated = False

-    Sheets("Info").Activate

-    Range("A2").Select

-End Sub

-

-Sub ReturnButton_Click()

-    Sheets("Chart").Activate

-    Range("E4").Select

-End Sub

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Private Sub Workbook_Open()

-    ThisWorkbook.Windows(1).WindowState = xlNormal

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    If Range("CloseFlag") <> "Y" Then

-        Worksheets("Workbook Examples").Activate

-        Range("CloseFlag").Activate

-        MsgBox "CloseFlag Cell must be 'Y' to close workbook"

-        Cancel = True

-    End If

-End Sub

-

-Private Sub Workbook_Open()

-    Worksheets("Change History").Activate

-    Range("VersionStart").Select

-    Selection.End(xlDown).Select

-    Selection.Copy (Worksheets("Overview").Range("VersionNumber"))

-    Worksheets("Workbook Examples").Activate

-    Range("CloseFlag") = "N"

-    Worksheets("Overview").Activate

-    Range("A1").Activate

-

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CommandButton1, 1, 0, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton2, 2, 1, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton3, 4, 2, MSForms, CommandButton"

-Private Sub CommandButton1_Click()

-    Call ListAllWorksheets

-End Sub

-

-Private Sub CommandButton2_Click()

-    Call ClearWorksheetNames

-End Sub

-

-Private Sub CommandButton3_Click()

-    Call AddNewWorksheet

-End Sub

-

-Private Sub Worksheet_Activate()

-    MsgBox "This pop-up message is displayed whenever this worksheet is activated."

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-

-End Sub

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CommandButton1, 1, 0, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton2, 2, 1, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton3, 3, 2, MSForms, CommandButton"

-Private Sub CommandButton1_Click()

-    Call SelectToFromCells

-End Sub

-

-Private Sub CommandButton2_Click()

-    Call RotateMatrix

-End Sub

-

-Private Sub CommandButton3_Click()

-    Call ElementOperations

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Not (Intersect(Target, Range("MyCell")) Is Nothing) Then

-        Select Case LCase(Target.Value)

-            Case "a", "e", "i", "o", "u"

-                Range("MsgCell").Value = "vowel"

-                

-            Case "b" To "d", "f" To "h", "j" To "n", "p" To "t", "v" To "z"

-                Range("MsgCell").Value = "consonant"

-            

-            Case 0 To 9

-                Range("MsgCell").Value = "number"

-                

-            Case Else

-                Range("MsgCell").Value = "unknown"

-        End Select

-    End If

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-

-End Sub

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-WorksheetsVBACode
->>>>>>
-Attribute VB_Name = "WorksheetsVBACode"

-Sub AddNewWorksheet()

-    Dim wksh As Worksheet

-    

-    Set wksh = Worksheets.Add

-    wksh.Name = "MyNewSheet"

-End Sub

-Sub ListAllWorksheets()

-    Dim wksh As Worksheet

-    Dim i As Integer

-    

-    With Range("WkShNames")

-        i = 1

-        For Each wksh In ActiveWorkbook.Worksheets

-            .Cells(i).Value = wksh.Name

-            i = i + 1

-        Next

-    End With

-

-End Sub

-

-Sub ClearWorksheetNames()

-    Dim YesNoResponse As Integer

-    

-    Range("WkShNameArea").Select

-    

-    YesNoResponse = MsgBox("Clear Worksheet Name Area?", vbYesNo)

-    

-    If YesNoResponse = vbYes Then

-        Range("WkShNameArea").ClearContents

-

-    End If

-    

-    Range("a1").Select

-End Sub

-<<<<<<
-======================
-CellVBACode
->>>>>>
-Attribute VB_Name = "CellVBACode"

-Sub SelectToFromCells()

-    Range("FromCell", "ToCell").Select

-End Sub

-

-Sub RotateMatrix()

-    Dim i As Integer, j As Integer

-    Dim Temp As Variant

-    

-    With Range("MyMatrix")

-        Temp = .Cells(2, 1)

-        .Cells(2, 1) = .Cells(2, 2)

-        .Cells(2, 2) = .Cells(1, 2)

-        .Cells(1, 2) = .Cells(1, 1)

-        .Cells(1, 1) = Temp

-    End With

-End Sub

-

-

-Sub ElementOperations()

-    Dim i As Integer

-    Dim NumberOfElements As Integer

-    Dim ElementProduct As Double

-    Dim ElementSum As Double

-    

-    With Range("MyVector")

-        NumberOfElements = .Rows.Count

-        ElementProduct = 1

-        ElementSum = 0

-        For i = 1 To NumberOfElements

-            ElementProduct = ElementProduct * .Cells(i)

-            ElementSum = ElementSum + .Cells(i)

-        Next i

-    End With

-

-    Range("ElementProduct").Value = ElementProduct

-    Range("ElementSum").Value = ElementSum

-End Sub

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CommandButton1, 1, 0, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton2, 2, 1, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton3, 3, 2, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton4, 5, 4, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton5, 6, 5, MSForms, CommandButton"

-Private Sub CommandButton1_Click()

-    Call getApplProperties

-End Sub

-

-Private Sub CommandButton2_Click()

-    Call generateDataToSort

-End Sub

-

-Private Sub CommandButton3_Click()

-    Call SortWithScreenUpdating

-End Sub

-

-Private Sub CommandButton4_Click()

-    Call SortWithNoScreenUpdating

-End Sub

-

-Private Sub CommandButton5_Click()

-    Call generateDataToSort

-End Sub

-

-Private Sub Worksheet_Activate()

-    Range("ApplProperties").ClearContents

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-

-End Sub

-<<<<<<
-======================
-ApplicationCode
->>>>>>
-Attribute VB_Name = "ApplicationCode"

-'''

-''' Contains various VBA coding examples on accessing the Application Object

-'''

-Option Explicit

-

-

-Sub getApplProperties()

-    Range("ApplParent") = Application.Parent

-    Range("ApplPath") = Application.Path

-    Range("ApplActiveWorkbook") = Application.ActiveWorkbook.Name

-    Range("ApplActiveSheet") = Application.ActiveSheet.Name

-    Range("ApplActiveCell") = Application.ActiveCell.Address

-    

-End Sub

-

-

-Sub generateDataToSort()

-    Dim i As Integer

-    

-    With Range("SortArray")

-        For i = 1 To .Rows.Count

-            .Cells(i) = Int((100 * Rnd) + 1)    ' Generate random value between 1 and 100.

-        Next i

-    End With

-

-End Sub

-

-Sub SortWithScreenUpdating()

-    Application.ScreenUpdating = True

-    Call BubbleSort(Range("SortArray"))

-    Range("SortArray").Select

-    MsgBox "Sorting Completed"

-End Sub

-Sub SortWithNoScreenUpdating()

-    Application.ScreenUpdating = False

-    Call BubbleSort(Range("SortArray"))

-    Range("SortArray").Select

-    Application.ScreenUpdating = True

-    MsgBox "Sorting Completed"

-End Sub

-

-Sub BubbleSort(rngToSort As Range)

-    Dim i, j As Integer

-    Dim Temp As Variant

-

-    With rngToSort

-        For j = .Rows.Count To 1 Step -1

-            For i = 1 To j

-                .Cells(i).Interior.ColorIndex = 6

-                .Cells(j).Interior.ColorIndex = 8

-                Application.Wait (Now + TimeValue("0:00:01"))

-                If .Cells(i) > .Cells(j) Then

-                    Temp = .Cells(i)

-                    .Cells(i) = .Cells(j)

-                    .Cells(j) = Temp

-                End If

-                .Cells(i).Interior.ColorIndex = xlColorIndexNone

-                .Cells(j).Interior.ColorIndex = xlColorIndexNone

-            Next i

-        Next j

-    

-    End With

-

-End Sub

-

-

-

-

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Sub Macro1()

-Attribute Macro1.VB_Description = "Macro recorded 5/5/2004 by Jim Thompson"

-Attribute Macro1.VB_ProcData.VB_Invoke_Func = " \n14"

-'

-' Macro1 Macro

-' Macro recorded 5/5/2004 by Jim Thompson

-'

-

-'

-    Selection.End(xlDown).Select

-End Sub

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'Controls'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CommandButton1, 1, 0, MSForms, CommandButton"

-

-Private Sub CommandButton1_Click()

-ActiveSheet.Next.Select

-Rem Range("A1").Select - broken for some stupid reason

-Rem Selection.Copy

-Rem If Selection.EntireRow.Hidden = False Then

-Rem     MsgBox ("Selection Error")

-Rem End If

-ActiveSheet.Previous.Select

-End Sub

-<<<<<<
-======================
-Invocations
->>>>>>
-Attribute VB_Name = "Invocations"

-Rem       No defined return value

-

-Function INoReturnNoRet()

-End Function

-Function IGetThreeNoRet()

-IGetThreeNoRet = 3

-End Function

-Function IGetFooNoRet()

-IGetFooNoRet = "foo"

-End Function

-Function IGetPINoRet()

-IGetPINoRet = 3.1415926535898

-End Function

-

-Rem       Various return types

-

-Function IGetInteger() As Integer

-IGetInteger = 42

-End Function

-Function IGetString() As String

-IGetString = "baa"

-End Function

-Function IGetDouble() As Double

-IGetDouble = 3.1415926535898

-End Function

-Function IGetSingle() As Single

-IGetSingle = 23

-End Function

-Function IGetBoolean() As Boolean

-IGetBoolean = True

-End Function

-

-Rem       Misc parameter types

-

-Function TakesNothing()

-TakesNothing = 1

-End Function

-Function TakesInteger(arg As Integer) As Integer

-TakesInteger = 21

-End Function

-Function TakesString(arg As String) As Integer

-TakesString = 17

-End Function

-Function TakesDouble(arg As Double) As Integer

-TakesDouble = 38

-End Function

-Function TakesDate(arg As Date) As Integer

-TakesDate = 23

-End Function

-Function TakesRange(arg As Range) As Integer

-TakesRange = 11

-End Function

-

-

-Rem Optional arguments

-Function OptionalArgument(Length As Integer, Optional Width As Variant) As Integer

-If IsMissing(Width) Then

-    OptionalArgument = Length * Length

-Else

-    OptionalArgument = Length * Width

-End If

-End Function

-

-Function OptionalNonVariant(Optional IsZero As Integer) As Integer

-If IsMissing(IsZero) Then

-Rem This never occurs

-    OptionalNonVariant = 23

-Else

-    OptionalNonVariant = 17

-End If

-End Function

-

-<<<<<<
-======================
-ObjectModel
->>>>>>
-Attribute VB_Name = "ObjectModel"

-Function ObjectWorksheetFn() As Double

-ObjectWorksheetFn = WorksheetFunction.Sinh(2.3)

-End Function

-Function ObjectIsVolatile() As Double

-Application.Volatile

-ObjectIsVolatile = 3

-End Function

-Function ObjectRange(a As Range) As Integer

-ObjectRange = a.Column + a.Row + a.Height + a.Width

-End Function

-<<<<<<
-======================
-Syntax
->>>>>>
-Attribute VB_Name = "Syntax"

-Rem       Basic Statements

-Function StmtIf() As Boolean

-Dim bIf As Boolean

-bIf = True

-If bIf Then StmtIf = True

-If Not bIf Then

-    StmtIf = False

-Else

-    StmtIf = True

-End If

-End Function

-Function StmtSel() As Boolean

-Dim Digit As Integer

-Select Case Digit

-    Case 0

-        StmtSel = True

-    Case 1

-        StmtSel = False

-End Select

-End Function

-Function StmtFor() As Integer

-Dim i As Integer

-Dim j As Integer

-For i = 0 To 10

-    j = j + i

-Next i

-StmtFor = j

-End Function

-Function StmtForEach() As Integer

-Dim i(3)

-Dim j As Variant

-Dim c As Integer

-i(1) = "1"

-i(2) = Now

-i(3) = "1"

-For Each j In i()

-    c = c + 1

-Next j

-StmtForEach = c

-End Function

-Function StmtWhile() As Integer

-Dim i As Integer

-While i < 11

-    i = i + 1

-Wend

-StmtWhile = i

-End Function

-Function StmtWith() As Integer

-With Selection

-    .Orientation = 0

-End With

-StmtWith = 15

-End Function

-

-Rem       Unary Operators

-Function UnaryNot() As Boolean

-UnaryNot = Not False

-End Function

-

-Rem       Comparison Operators

-Function BinaryIsGreater() As Boolean

-BinaryIsGreater = 3 > 2

-End Function

-Function BinaryIsGreaterEqual() As Boolean

-BinaryIsGreaterEqual = 2 >= 2

-End Function

-Function BinaryIsLess() As Boolean

-BinaryIsLess = 2 < 2

-End Function

-Function BinaryIsLessEqual() As Boolean

-BinaryIsLessEqual = 4 <= 4

-End Function

-Function BinaryIsEqual() As Boolean

-BinaryIsEqual = 4 = 4

-End Function

-

-Rem       Arithmetic Operators

-Function BinaryExp() As Integer

-BinaryExp = 10 ^ 2

-End Function

-Function BinaryAdd() As Integer

-BinaryAdd = 2 + 3

-End Function

-Function BinarySub() As Integer

-BinarySub = 5 - 7

-End Function

-Function BinaryMult() As Integer

-BinaryMult = 2 * 7

-End Function

-Function BinaryDivide() As Integer

-BinaryDivide = 17 / 6

-End Function

-Function RShift() As Integer

-' RShift = 10 << 1

-End Function

-Function LShift() As Integer

-' LShift = 10 >> 1

-End Function

-

-<<<<<<
-======================
-RecordedMacros
->>>>>>
-Attribute VB_Name = "RecordedMacros"

-Sub Boldify()

-Attribute Boldify.VB_Description = "Macro recorded 20/04/2004 by Michael"

-Attribute Boldify.VB_ProcData.VB_Invoke_Func = "t\n14"

-'

-' Boldify Macro

-' Macro recorded 20/04/2004 by Michael

-'

-' Keyboard Shortcut: Ctrl+t

-'

-    Selection.Font.Bold = True

-End Sub

-Sub Italicize()

-Attribute Italicize.VB_Description = "Second Macro description"

-Attribute Italicize.VB_ProcData.VB_Invoke_Func = "J\n14"

-'

-' Italicize Macro

-' Second Macro description

-'

-' Keyboard Shortcut: Ctrl+Shift+J

-'

-    Selection.Font.Italic = True

-End Sub

-Sub Complex()

-Attribute Complex.VB_Description = "Daft thing ..."

-Attribute Complex.VB_ProcData.VB_Invoke_Func = "C\n14"

-'

-' Complex Macro

-' Daft thing ...

-'

-' Keyboard Shortcut: Ctrl+Shift+C

-'

-    ActiveCell.FormulaR1C1 = "2"

-    Range("F8").Select

-    ActiveCell.FormulaR1C1 = "3"

-    Range("F9").Select

-    Selection.Font.Bold = True

-    ActiveCell.FormulaR1C1 = "5"

-    Range("F10").Select

-    ActiveCell.FormulaR1C1 = "=R[-3]C+R[-1]C"

-    Range("F11").Select

-    With Selection.Font

-        .Name = "Arial Black"

-        .Size = 10

-        .Strikethrough = False

-        .Superscript = False

-        .Subscript = False

-        .OutlineFont = False

-        .Shadow = False

-        .Underline = xlUnderlineStyleNone

-        .ColorIndex = xlAutomatic

-    End With

-    ActiveCell.FormulaR1C1 = "Arial Black"

-    Range("F12").Select

-    ActiveCell.FormulaR1C1 = "Centered"

-    Range("F13").Select

-    ActiveCell.FormulaR1C1 = "Left"

-    Range("F14").Select

-    ActiveCell.FormulaR1C1 = "Right"

-    Range("F12").Select

-    With Selection

-        .HorizontalAlignment = xlCenter

-        .VerticalAlignment = xlBottom

-        .WrapText = False

-        .Orientation = 0

-        .AddIndent = False

-        .IndentLevel = 0

-        .ShrinkToFit = False

-        .ReadingOrder = xlContext

-        .MergeCells = False

-    End With

-    Range("F13").Select

-    With Selection

-        .HorizontalAlignment = xlLeft

-        .VerticalAlignment = xlBottom

-        .WrapText = False

-        .Orientation = 0

-        .AddIndent = False

-        .IndentLevel = 0

-        .ShrinkToFit = False

-        .ReadingOrder = xlContext

-        .MergeCells = False

-    End With

-    Range("F14").Select

-    With Selection

-        .HorizontalAlignment = xlRight

-        .VerticalAlignment = xlBottom

-        .WrapText = False

-        .Orientation = 0

-        .AddIndent = False

-        .IndentLevel = 0

-        .ShrinkToFit = False

-        .ReadingOrder = xlContext

-        .MergeCells = False

-    End With

-    Range("F15:G15").Select

-    ActiveCell.FormulaR1C1 = "Joiined"

-    Range("F15:G15").Select

-    Range("G15").Activate

-    With Selection

-        .HorizontalAlignment = xlCenter

-        .VerticalAlignment = xlBottom

-        .WrapText = False

-        .Orientation = 0

-        .AddIndent = False

-        .IndentLevel = 0

-        .ShrinkToFit = False

-        .ReadingOrder = xlContext

-        .MergeCells = False

-    End With

-    Selection.Merge

-End Sub

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Constants
->>>>>>
-Attribute VB_Name = "Constants"

-Rem  *****  BASIC  *****

-    

-Function vbUseCompareOptionConst() As Double

-    vbUseCompareOptionConst = vbUseCompareOption

-End Function

-Function vbBinaryCompareConst() As Double

-    vbBinaryCompareConst = vbBinaryCompare

-End Function

-Function vbTextCompareConst() As Double

-    vbTextCompareConst = vbTextCompare

-End Function

-Function vbDatabaseCompareConst() As Double

-    vbDatabaseCompareConst = vbDatabaseCompare

-End Function

-Function vbSundayConst() As Double

-    vbSundayConst = vbSunday

-End Function

-Function vbMondayConst() As Double

-    vbMondayConst = vbMonday

-End Function

-Function vbTuesdayConst() As Double

-    vbTuesdayConst = vbTuesday

-End Function

-Function vbWednesdayConst() As Double

-    vbWednesdayConst = vbWednesday

-End Function

-Function vbThursdayConst() As Double

-    vbThursdayConst = vbThursday

-End Function

-Function vbFridayConst() As Double

-    vbFridayConst = vbFriday

-End Function

-Function vbSaturdayConst() As Double

-    vbSaturdayConst = vbSaturday

-End Function

-Function vbUseSystemConst() As Double

-    vbUseSystemConst = vbUseSystem

-End Function

-Function vbGeneralDateConst() As Double

-    vbGeneralDateConst = vbGeneralDate

-End Function

-Function vbLongDateConst() As Double

-    vbLongDateConst = vbLongDate

-End Function

-Function vbShortDateConst() As Double

-    vbShortDateConst = vbShortDate

-End Function

-Function vbLongTimeConst() As Double

-    vbLongTimeConst = vbLongTime

-End Function

-Function vbShortTimeConst() As Double

-    vbShortTimeConst = vbShortTime

-End Function

-Function vbObjectErrorConst() As Double

-    vbObjectErrorConst = vbObjectError

-End Function

-Function vbOKOnlyConst() As Double

-    vbOKOnlyConst = vbOKOnly

-End Function

-Function vbOKCancelConst() As Double

-    vbOKCancelConst = vbOKCancel

-End Function

-Function vbAbortRetryIgnoreConst() As Double

-    vbAbortRetryIgnoreConst = vbAbortRetryIgnore

-End Function

-Function vbYesNoCancelConst() As Double

-    vbYesNoCancelConst = vbYesNoCancel

-End Function

-Function vbYesNoConst() As Double

-    vbYesNoConst = vbYesNo

-End Function

-Function vbRetryCancelConst() As Double

-    vbRetryCancelConst = vbRetryCancel

-End Function

-Function vbCriticalConst() As Double

-    vbCriticalConst = vbCritical

-End Function

-Function vbQuestionConst() As Double

-    vbQuestionConst = vbQuestion

-End Function

-Function vbExclamationConst() As Double

-    vbExclamationConst = vbExclamation

-End Function

-Function vbInformationConst() As Double

-    vbInformationConst = vbInformation

-End Function

-Function vbDefaultButton1Const() As Double

-    vbDefaultButton1Const = vbDefaultButton1

-End Function

-Function vbDefaultButton2Const() As Double

-    vbDefaultButton2Const = vbDefaultButton2

-End Function

-Function vbDefaultButton3Const() As Double

-    vbDefaultButton3Const = vbDefaultButton3

-End Function

-Function vbDefaultButton4Const() As Double

-    vbDefaultButton4Const = vbDefaultButton4

-End Function

-Function vbApplicationModalConst() As Double

-    vbApplicationModalConst = vbApplicationModal

-End Function

-Function vbSystemModalConst() As Double

-    vbSystemModalConst = vbSystemModal

-End Function

-Function vbMsgBoxHelpButtonConst() As Double

-    vbMsgBoxHelpButtonConst = vbMsgBoxHelpButton

-End Function

-Function vbMsgBoxSetForegroundConst() As Double

-    vbMsgBoxSetForegroundConst = vbMsgBoxSetForeground

-End Function

-Function vbMsgBoxRightConst() As Double

-    vbMsgBoxRightConst = vbMsgBoxRight

-End Function

-Function vbMsgBoxRtlReadingConst() As Double

-    vbMsgBoxRtlReadingConst = vbMsgBoxRtlReading

-End Function

-

-<<<<<<
-======================
-Constants1
->>>>>>
-Attribute VB_Name = "Constants1"

-Rem  *****  BASIC  *****

-    

-Function vbCrConst() As String

-    vbCrConst = vbCr

-End Function

-Function VbCrLfConst() As String

-    VbCrLfConst = vbCrLf

-End Function

-Function vbFormFeedConst() As String

-    vbFormFeedConst = vbFormFeed

-End Function

-Function vbLfConst() As String

-    vbLfConst = vbLf

-End Function

-Function vbNewLineConst() As String

-    vbNewLineConst = vbNewLine

-End Function

-Function vbNullCharConst() As String

-    vbNullCharConst = vbNullChar

-End Function

-Function vbNullStringConst() As String

-    vbNullStringConst = vbNullString

-End Function

-Function vbTabConst() As String

-    vbTabConst = vbTab

-End Function

-Function vbVerticalTabConst() As String

-    vbVerticalTabConst = vbVerticalTab

-End Function

-Function vbUpperCaseConst() As Integer

-    vbUpperCaseConst = vbUpperCase

-End Function

-Function vbLowerCaseConst() As Integer

-    vbLowerCaseConst = vbLowerCase

-End Function

-Function vbProperCaseConst() As Integer

-    vbProperCaseConst = vbProperCase

-End Function

-Function vbWideConst() As Integer

-    vbWideConst = vbWide

-End Function

-Function vbNarrowConst() As Integer

-    vbNarrowConst = vbNarrow

-End Function

-Function vbKatakanaConst() As Integer

-    vbKatakanaConst = vbKatakana

-End Function

-Function vbHiraganaConst() As Integer

-    vbHiraganaConst = vbHiragana

-End Function

-Function vbUnicodeConst() As Integer

-    vbUnicodeConst = vbUnicode

-End Function

-Function vbFromUnicodeConst() As Integer

-    vbFromUnicodeConst = vbFromUnicode

-End Function

-Function vbUseDefaultConst() As String

-    vbUseDefaultConst = vbUseDefault

-End Function

-Function vbTrueConst() As String

-    vbTrueConst = vbTrue

-End Function

-Function vbFalseConst() As String

-    vbFalseConst = vbFalse

-End Function

-Function vbEmptyConst() As Double

-    vbEmptyConst = vbEmpty

-End Function

-Function vbNullConst() As Double

-    vbNullConst = vbNull

-End Function

-Function vbIntegerConst() As Double

-    vbIntegerConst = vbInteger

-End Function

-Function vbLongConst() As Double

-    vbLongConst = vbLong

-End Function

-Function vbSingleConst() As Double

-    vbSingleConst = vbSingle

-End Function

-Function vbDoubleConst() As Double

-    vbDoubleConst = vbDouble

-End Function

-Function vbCurrencyConst() As Double

-    vbCurrencyConst = vbCurrency

-End Function

-Function vbDateConst() As Double

-    vbDateConst = vbDate

-End Function

-Function vbStringConst() As Double

-    vbStringConst = vbString

-End Function

-Function vbObjectConst() As Double

-    vbObjectConst = vbObject

-End Function

-Function vbErrorConst() As Double

-    vbErrorConst = vbError

-End Function

-Function vbBooleanConst() As Double

-    vbBooleanConst = vbBoolean

-End Function

-Function vbVariantConst() As Double

-    vbVariantConst = vbVariant

-End Function

-Function vbDataObjectConst() As Double

-    vbDataObjectConst = vbDataObject

-End Function

-Function vbDecimalConst() As Double

-    vbDecimalConst = vbDecimal

-End Function

-Function vbByteConst() As Double

-    vbByteConst = vbByte

-End Function

-Function vbUserDefinedTypeConst() As Double

-    vbUserDefinedTypeConst = vbUserDefinedType

-End Function

-Function vbArrayConst() As Double

-    vbArrayConst = vbArray

-End Function

-

-<<<<<<
-======================
-FunctionA_E
->>>>>>
-Attribute VB_Name = "FunctionA_E"

-Rem  *****  BASIC  *****

-    

-Function rtl_abs() As Double

-    rtl_abs = Abs(-53)

-End Function

-Function rtl_array() As Variant

-    rtl_array = Array(10, 20, 30)

-End Function

-Function rtl_asc() As Integer

-    rtl_asc = Asc("A")

-End Function

-Function rtl_atn() As Double

-    rtl_atn = Atn(3.14 / 4)

-End Function

-Function rtl_callbyname()

-End Function

-Function rtl_choose()

-   rtl_choose = Choose(1, "Choose", "Error", "Error")

-End Function

-Function rtl_chr() As String

-    rtl_chr = Chr(65)

-End Function

-Function rtl_command()

-End Function

-Function rtl_cos() As Double

-    rtl_cos = Cos(0)

-End Function

-Function rtl_createobject()

-End Function

-Function rtl_curdir() As String

-    rtl_curdir = CurDir()

-End Function

-Function rtl_cverr()

-End Function

-Function rtl_date() As Date

-    rtl_date = Date

-End Function

-Function rtl_dateadd() As Double

-    Dim myDate As Date

-    myDate = "08/10/2004"

-    rtl_dateadd = DateAdd("yyyy", 1, myDate)

-End Function

-Function rtl_datediff() As Long

-    Dim myDate As Date

-    myDate = "08/10/2004"

-    rtl_datediff = DateDiff("d", "08/01/2004", myDate)

-End Function

-Function rtl_datepart() As Integer

-    Dim myDate As Date

-    myDate = "08/10/2004"

-    rtl_datepart = DatePart("q", myDate)

-End Function

-Function rtl_dateserial() As Date

-    Dim myDate As Date

-    myDate = "08/10/2004"

-    rtl_dateserial = DateSerial(2004, 8, 10)

-End Function

-Function rtl_datevalue() As Date

-    Dim myDate As Date

-    rtl_datevalue = DateValue("12/02/1969")

-End Function

-Function rtl_day() As Integer

-    Dim myDate As Date

-    myDate = "08/10/2004"

-    rtl_day = Day(myDate)

-End Function

-Function rtl_ddb() As Integer

-End Function

-Function rtl_dir() As String

-    rtl_dir = Dir(CurDir())

-End Function

-Function rtl_doevents()

-End Function

-Function rtl_environ() As String

-    rtl_environ = Environ(1)

-End Function

-Function rtl_eof()

-End Function

-Function rtl_error() As String

-    rtl_error = Error(1)

-End Function

-Function rtl_exp() As Double

-    rtl_exp = Exp(1)

-End Function

-

-<<<<<<
-======================
-FunctionF_I
->>>>>>
-Attribute VB_Name = "FunctionF_I"

-Rem  *****  BASIC  *****

-        

-Function rtl_fileattr()

-End Function

-Function rtl_filedatetime()

-End Function

-Function rtl_filelen()

-End Function

-Function rtl_filter() As String

-    Dim MyIndex() As String

-    Dim MyArray(3)

-    MyArray(0) = "Format"

-    MyArray(1) = "Filter"

-    MyArray(2) = 10

-    MyIndex() = Filter(MyArray(), "Fil")   ' MyIndex(0) contains "Monday".

-    rtl_filter = MyIndex(0)

-End Function

-Function rtl_format() As String

-    rtl_format = Format(334.9, "###0.00")   ' Returns "334.90".

-End Function

-Function rtl_formatcurrency() As String

-    rtl_formatcurrency = FormatCurrency(1000)   ' MyCurrency contains $1000.00.

-End Function

-Function rtl_FormatDateTime() As String

-    rtl_FormatDateTime = FormatDateTime("08/10/2004", vbLongDate) 'Tuesday, August 10, 2004

-End Function

-Function rtl_formatnumber() As String

-    Dim MyAngle, MySecant

-    MyAngle = 1.3   ' Define angle in radians.

-    MySecant = 1 / Cos(MyAngle)   ' Calculate secant.

-    rtl_formatnumber = FormatNumber(MySecant, 4) ' Format MySecant to four decimal places.

-End Function

-Function rtl_formatpercent() As String

-    rtl_formatpercent = FormatPercent(2 / 32) ' MyPercent contains 6.25%.

-End Function

-Function rtl_freefile()

-End Function

-Function rtl_fv()

-End Function

-Function rtl_getallsettings()

-End Function

-Function rtl_getattr()

-End Function

-Function rtl_getautoserversetting()

-End Function

-Function rtl_getobject()

-End Function

-Function rtl_getsetting()

-End Function

-Function rtl_hex() As String

-    rtl_hex = Hex(65535)

-End Function

-Function rtl_hour() As String

-    rtl_hour = Hour("12:00:00")

-End Function

-Function rtl_iif() As String

-    rtl_iif = IIf(10 > 100, "Large", "Small")

-End Function

-Function rtl_imestatus()

-End Function

-Function rtl_input()

-End Function

-Function rtl_inputbox()

-End Function

-Function rtl_instr() As Integer

-    Dim SearchString, SearchChar

-    SearchString = "XXpXXpXXPXXP"  ' String to search in.

-    SearchChar = "P"   ' Search for "P".

-        

-    ' A textual comparison starting at position 4. Returns 6.

-    rtl_instr = InStr(4, SearchString, SearchChar, 1)

-End Function

-Function rtl_instrrev() As Integer

-    Dim SearchString, SearchChar

-    SearchString = "XXpXXpXXPXXP"  ' String to search in.

-    SearchChar = "P"   ' Search for "P".

-        

-    ' returns 12

-    rtl_instrrev = InStrRev(SearchString, SearchChar)

-End Function

-Function rtl_int() As Integer

-    rtl_int = Int(7.45)

-End Function

-Function rtl_ipmt()

-End Function

-Function rtl_irr()

-End Function

-Function rtl_isarray() As Boolean

-    Dim var(3)

-    rtl_isarray = IsArray(var())

-End Function

-Function rtl_isdate() As Boolean

-    Dim var As Date

-    rtl_isdate = IsDate(var)

-End Function

-Function rtl_isempty() As Boolean

-    Dim var

-    rtl_isempty = IsEmpty(var)

-End Function

-Function rtl_iserror() As Boolean

-    Dim var As Error

-    rtl_iserror = IsError(var)

-End Function

-Function rtl_ismissing() As Boolean

-    Dim var

-    rtl_ismissing = IsMissing(var)

-End Function

-Function rtl_isnull() As Boolean

-    Dim var

-    rtl_isnull = IsNull(var)

-End Function

-Function rtl_isnumeric() As Boolean

-    Dim var As Integer

-    rtl_isnumeric = IsNumeric(var)

-End Function

-Function rtl_isobject() As Boolean

-    Dim var As Object

-    rtl_isobject = IsObject(var)

-End Function

-

-<<<<<<
-======================
-FunctionJ_R
->>>>>>
-Attribute VB_Name = "FunctionJ_R"

-Rem  *****  BASIC  *****

-        

-Function rtl_join() As String

-    Dim MyArray(3)

-    MyArray(1) = "1"

-    MyArray(2) = "1"

-    MyArray(3) = "1"

-    rtl_join = Join(MyArray())

-End Function

-Function rtl_lbound() As Integer

-    Dim MyArray(1 To 10, 5 To 15, 10 To 20)    ' Declare array variables.

-    rtl_lbound = LBound(MyArray(), 1)    ' Returns 1.

-End Function

-Function rtl_lcase() As String

-    rtl_lcase = LCase("LowerCase")

-End Function

-Function rtl_left() As String

-    rtl_left = Left("Left", 2)

-End Function

-Function rtl_len() As Long

-    rtl_len = Len("Len")

-End Function

-Function rtl_loadpicture()

-End Function

-Function rtl_loc()

-End Function

-Function rtl_lof()

-End Function

-Function rtl_log() As Double

-    rtl_log = Log(10)

-End Function

-Function rtl_ltrim() As String

-    rtl_ltrim = LTrim(" LTrim")

-End Function

-Function rtl_mid() As String

-    rtl_mid = Mid("Mid Function", 1, 3)

-End Function

-Function rtl_minute() As Integer

-    rtl_minute = Minute("12:31:45")

-End Function

-Function rtl_mirr()

-End Function

-Function rtl_month() As Integer

-    rtl_month = Month("10/08/2004")

-End Function

-Function rtl_monthname() As String

-    rtl_monthname = MonthName(10)

-End Function

-Function rtl_msgbox()

-End Function

-Function rtl_now() As Date

-    rtl_now = Now()

-End Function

-Function rtl_nper()

-End Function

-Function rtl_npv()

-End Function

-Function rtl_oct() As String

-    rtl_oct = Oct(32)

-End Function

-Function rtl_partition()

-End Function

-Function rtl_pmt()

-End Function

-Function rtl_ppmt()

-End Function

-Function rtl_pv()

-End Function

-Function rtl_qbcolor() As Long

-    rtl_qbcolor = QBColor(5)

-End Function

-Function rtl_rate()

-End Function

-Function rtl_replace() As String

-    ' A binary comparison starting at the beginning of the string.

-    rtl_replace = Replace("XXpXXPXXp", "p", "Y")

-End Function

-Function rtl_rgb() As Long

-    rtl_rgb = RGB(255, 0, 0)

-End Function

-Function rtl_right() As String

-    rtl_right = Right("right", 2)

-End Function

-Function rtl_rnd() As Single

-    rtl_rnd = Rnd(10)

-End Function

-Function rtl_round() As Single

-    rtl_round = Round(3.1415, 2)

-End Function

-

-<<<<<<
-======================
-FunctionS_Y
->>>>>>
-Attribute VB_Name = "FunctionS_Y"

-Rem  *****  BASIC  *****

-        

-Function rtl_second() As Integer

-    rtl_second = Second("12:31:45")

-End Function

-Function rtl_seek()

-End Function

-Function rtl_sgn() As Integer

-    rtl_sgn = Sgn(10)

-End Function

-Function rtl_shell() As Integer

-End Function

-Function rtl_sin() As Integer

-    rtl_sin = Sin(0)

-End Function

-Function rtl_sln()

-End Function

-Function rtl_space() As String

-    rtl_space = "4" + Space(4) + "spaces"

-End Function

-Function rtl_split()

-    rtl_split = Split("Part1 Part2 Part3")

-End Function

-Function rtl_sqr() As Double

-    rtl_sqr = Sqr(256)

-End Function

-Function rtl_str() As String

-    rtl_str = str(256)

-End Function

-Function rtl_strcomp() As Integer

-    rtl_strcomp = StrComp("strcomp", "strcomp")

-End Function

-Function rtl_strconv() As String

-    rtl_strconv = StrConv("strconv", 3)

-End Function

-Function rtl_string() As String

-    rtl_string = String(10, "s")

-End Function

-Function rtl_strreverse() As String

-    rtl_strreverse = StrReverse("reverse")

-End Function

-Function rtl_switch() As String

-    Dim str As String

-    str = "switch"

-    rtl_switch = Switch(str = "skip", "noswitch", str = "switch", "switch")

-End Function

-Function rtl_syd()

-End Function

-Function rtl_tab()

-End Function

-Function rtl_tan() As Double

-    rtl_tan = Tan(0)

-End Function

-Function rtl_time() As Date

-    rtl_time = Time()

-End Function

-Function rtl_timer() As Single

-    rtl_timer = Timer()

-End Function

-Function rtl_timeserial() As Date

-    rtl_timeserial = TimeSerial(12, 31, 45)

-End Function

-Function rtl_timevalue() As Date

-    rtl_timevalue = TimeValue("12:31:45 AM")

-End Function

-Function rtl_typename() As String

-    rtl_typename = TypeName("string")

-End Function

-Function rtl_ubound() As Integer

-    Dim MyArray(1 To 10, 5 To 15, 10 To 20)   ' Declare array variables.

-    rtl_ubound = UBound(MyArray(), 1)   ' Returns 10.

-End Function

-Function rtl_ucase() As String

-    rtl_ucase = UCase("Uppercase")

-End Function

-Function rtl_val() As Integer

-    rtl_val = Val("3.1415")

-End Function

-Function rtl_vartype() As Integer

-    rtl_vartype = VarType(10)

-End Function

-Function rtl_weekday() As Integer

-    rtl_weekday = Weekday("10/08/2004")

-End Function

-Function rtl_weekdayname() As String

-    rtl_weekdayname = WeekdayName(6)

-End Function

-Function rtl_year() As String

-    rtl_year = Year("10/08/2004")

-End Function

-

-<<<<<<
-Project Name : 'Animated Chart Example.xls'
-Quirk - duff tag length======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "ScrollBar1, 4, 1, MSForms, ScrollBar"

-Attribute VB_Control = "CommandButton1, 5, 2, MSForms, CommandButton"

-

-

-Private Sub CommandButton1_Click()

-Range("A1").Value = 0

-End Sub

-

-Private Sub ScrollBar1_Change()

-    Range("A1").Value = Range("B1").Value * 0.035

-End Sub

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBProject'
-Quirk - duff tag length======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CommandButton1, 1, 0, MSForms, CommandButton"

-Private Sub CommandButton1_Click()

-    MsgBox "Hello your workbook name is " & Application.ActiveWorkbook.Name

-End Sub

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CheckBox1, 1, 0, MSForms, CheckBox"

-Attribute VB_Control = "CheckBox2, 2, 1, MSForms, CheckBox"

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "OptionButton1, 2, 1, MSForms, OptionButton"

-Attribute VB_Control = "OptionButton2, 3, 2, MSForms, OptionButton"

-Attribute VB_Control = "OptionButton3, 4, 3, MSForms, OptionButton"

-Private Sub OptionButton1_Click()

-    'blue

-    Cells.Interior.Color = RGB(0, 0, 255)

-End Sub

-

-Private Sub OptionButton2_Click()

-    'green

-    Cells.Interior.Color = RGB(0, 255, 0)

-End Sub

-

-Private Sub OptionButton3_Click()

-    'red

-    Cells.Interior.Color = RGB(255, 0, 0)

-End Sub

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "TextBox1, 1, 0, MSForms, TextBox"

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "ListBox1, 1, 0, MSForms, ListBox"

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "ComboBox1, 1, 0, MSForms, ComboBox"

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "ScrollBar1, 1, 0, MSForms, ScrollBar"

-Attribute VB_Control = "ScrollBar2, 2, 1, MSForms, ScrollBar"

-Attribute VB_Control = "ScrollBar3, 3, 2, MSForms, ScrollBar"

-Private Sub ScrollBar1_Change()

-    Call UpdateColor

-End Sub

-

-Private Sub ScrollBar2_Change()

-    Call UpdateColor

-End Sub

-

-Private Sub ScrollBar3_Change()

-    Call UpdateColor

-End Sub

-

-Private Sub UpdateColor()

-    Cells.Interior.Color = RGB(Range("A1"), Range("A2"), Range("A3"))

-End Sub

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "SpinButton1, 1, 0, MSForms, SpinButton"

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Private Sub Workbook_Open()

-

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "SpinButton1, 2, 0, MSForms, SpinButton"

-Attribute VB_Control = "Reset, 3, 1, MSForms, CommandButton"

-Private Sub Reset_Click()

-

-Application.ScreenUpdating = False

-

-ActiveSheet.Range("direction").Cells(1, 1).Value = 1

-ActiveSheet.Range("direction").Cells(1, 2).Value = 0

-Dim center_x As Long

-Dim center_y As Long

-With ActiveSheet.Range("board")

-    .Clear

-    .Interior.Color = RGB(0, 0, 0)

-    center_x = .Column + .Columns.Count / 2

-    center_y = .Row + .Rows.Count / 2

-End With

-With ActiveSheet.Range("position")

-    Dim pos As Long

-    For pos = 1 To .Rows.Count

-        .Cells(pos, 1).Value = center_x

-        .Cells(pos, 2).Value = center_y

-    Next pos

-    pos = .Rows.Count

-    .Cells(pos, 1).Value = center_x - 1

-    .Cells(pos, 2).Value = center_y - 1

-End With

-

-Application.ScreenUpdating = True

-

-End Sub

-

-'Sub DrawSnake(sheet As Worksheet, pos As Range)

-Sub DrawSnake(sheet As Object, pos As Object)

-Dim col As Long

-For idx = 1 To pos.Rows.Count

-    x = pos.Cells(idx, 1).Value

-    y = pos.Cells(idx, 2).Value

-    If idx = pos.Rows.Count Then

-        col = RGB(0, 0, 0)

-    Else

-        col = RGB(150, 0, 0)

-    End If

-'    MsgBox ("Set " + Str(x) + " " + Str(y) + " to " + Str(col))

-    sheet.Cells(y, x).Interior.Color = col

-'    sheet.Range("A1:IV65536").Cells(y, x).Value = col

-Next idx

-End Sub

-

-Sub MoveSnake(board As Object, ByRef x As Long, ByRef y As Long, ByRef dir_x As Long, ByRef dir_y As Long)

-

-x = x + dir_x

-y = y + dir_y

-

-' New wrapping code

-x = ((x - board.Column + board.Columns.Count) Mod board.Columns.Count) + board.Column

-y = ((y - board.Row + board.Rows.Count) Mod board.Rows.Count) + board.Row

-

-' should we change direction ? - bias for X due to non-square foos

-If (dir_x = 0 And Rnd() > 0.75) Or _

-   (dir_x <> 0 And Rnd() > 0.85) Then

-    ' Swap dirx & diry & randomly negate

-    Dim tmp As Long

-    tmp = dir_x

-    dir_x = dir_y

-    dir_y = tmp

-    If Rnd() > 0.5 Then

-        dir_x = -dir_x

-        dir_y = -dir_y

-    End If

-End If

-

-End Sub

-Private Sub SpinButton1_Change()

-

-Application.ScreenUpdating = False

-

-Dim sheet As Object

-Set sheet = ActiveSheet

-

-Dim x As Long

-Dim y As Long

-Dim dir_x As Long

-Dim dir_y As Long

-

-x = sheet.Range("position").Cells(1, 1).Value

-y = sheet.Range("position").Cells(1, 2).Value

-dir_x = sheet.Range("direction").Cells(1, 1).Value

-dir_y = sheet.Range("direction").Cells(1, 2).Value

-

-'Dim board As Range

-Dim board As Object

-Set board = sheet.Range("board")

-

-Call MoveSnake(board, x, y, dir_x, dir_y)

-

-'MsgBox ("Moved to " + Str(x) + " " + Str(y) + " to red")

-

-sheet.Range("position").Cells(1, 1).Value = x

-sheet.Range("position").Cells(1, 2).Value = y

-ActiveSheet.Range("direction").Cells(1, 1).Value = dir_x

-ActiveSheet.Range("direction").Cells(1, 2).Value = dir_y

-

-Call DrawSnake(sheet, sheet.Range("position"))

-

-sheet.Range("src").Copy (sheet.Range("dest"))

-

-Application.ScreenUpdating = True

-

-End Sub

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Sub doSnake()

-

-Dim pos As Integer

-Dim sheet As Object

-

-Set sheet = Application.Workbooks(1).Sheets(1)

-For pos = 1 To 20

-Rem  With sheet.Cells(1, b).Interior

-    sheet.Cells(1, pos).Interior.Color = RGB(123, 0, 0)

-Rem    End With

-Rem Application.Wait (Now + TimeValue("00:00:01"))

-Next pos

-

-End Sub

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Sub test()

-Sheets("sheet1").Activate

-main_1

-Sheets("sheet2").Activate

-main_2

-Sheets("sheet3").Activate

-main_3

-Sheets("sheet4").Activate

-main_4

-Sheets("sheet5").Activate

-main_5

-End Sub

-Sub main_1()

-test_xl24HourClock (xl24HourClock)

-test_xl4DigitYears (xl4DigitYears)

-test_xlAlternateArraySeparator (xlAlternateArraySeparator)

-test_xlColumnSeparator (xlColumnSeparator)

-test_xlCountryCode (xlCountryCode)

-test_xlCountrySetting (xlCountrySetting)

-test_xlCurrencyBefore (xlCurrencyBefore)

-test_xlCurrencyCode (xlCurrencyCode)

-test_xlCurrencyDigits (xlCurrencyDigits)

-test_xlCurrencyLeadingZeros (xlCurrencyLeadingZeros)

-test_xlCurrencyMinusSign (xlCurrencyMinusSign)

-test_xlCurrencyNegative (xlCurrencyNegative)

-test_xlCurrencySpaceBefore (xlCurrencySpaceBefore)

-test_xlCurrencyTrailingZeros (xlCurrencyTrailingZeros)

-test_xlDateOrder (xlDateOrder)

-test_xlDateSeparator (xlDateSeparator)

-test_xlDayCode (xlDayCode)

-test_xlDayLeadingZero (xlDayLeadingZero)

-test_xlDecimalSeparator (xlDecimalSeparator)

-test_xlGeneralFormatName (xlGeneralFormatName)

-test_xlHourCode (xlHourCode)

-test_xlLeftBrace (xlLeftBrace)

-test_xlLeftBracket (xlLeftBracket)

-test_xlListSeparator (xlListSeparator)

-test_xlLowerCaseColumnLetter (xlLowerCaseColumnLetter)

-test_xlLowerCaseRowLetter (xlLowerCaseRowLetter)

-test_xlMDY (xlMDY)

-test_xlMetric (xlMetric)

-test_xlMinuteCode (xlMinuteCode)

-test_xlMonthCode (xlMonthCode)

-test_xlMonthLeadingZero (xlMonthLeadingZero)

-test_xlMonthNameChars (xlMonthNameChars)

-test_xlNocurrencyDigits (xlNocurrencyDigits)

-test_xlNonEnglishFunctions (xlNonEnglishFunctions)

-test_xlRightBrace (xlRightBrace)

-test_xlRightBracket (xlRightBracket)

-test_xlRowSeparator (xlRowSeparator)

-test_xlSecondCode (xlSecondCode)

-test_xlThousandsSeparator (xlThousandsSeparator)

-test_xlTimeLeadingZero (xlTimeLeadingZero)

-test_xlTimeSeparator (xlTimeSeparator)

-test_xlUpperCaseColumnLetter (xlUpperCaseColumnLetter)

-test_xlUpperCaseRowLetter (xlUpperCaseRowLetter)

-test_xlWeekdayNameChars (xlWeekdayNameChars)

-test_xlYearCode (xlYearCode)

-test_xlColumnThenRow (xlColumnThenRow)

-test_xlRowThenColumn (xlRowThenColumn)

-test_xlArabicBothStrict (xlArabicBothStrict)

-test_xlArabicNone (xlArabicNone)

-test_xlArabicStrictAlefHamza (xlArabicStrictAlefHamza)

-test_xlArabicStrictFinalYaa (xlArabicStrictFinalYaa)

-test_xlArrangeStyleCascade (xlArrangeStyleCascade)

-test_xlArrangeStyleHorizontal (xlArrangeStyleHorizontal)

-test_xlArrangeStyleTiled (xlArrangeStyleTiled)

-test_xlArrangeStyleVertical (xlArrangeStyleVertical)

-test_xlArrowHeadLengthLong (xlArrowHeadLengthLong)

-test_xlArrowHeadLengthMedium (xlArrowHeadLengthMedium)

-test_xlArrowHeadLengthShort (xlArrowHeadLengthShort)

-test_xlArrowHeadStyleClosed (xlArrowHeadStyleClosed)

-test_xlArrowHeadStyleDoubleClosed (xlArrowHeadStyleDoubleClosed)

-test_xlArrowHeadStyleDoubleOpen (xlArrowHeadStyleDoubleOpen)

-test_xlArrowHeadStyleNone (xlArrowHeadStyleNone)

-test_xlArrowHeadStyleOpen (xlArrowHeadStyleOpen)

-test_xlArrowHeadWidthMedium (xlArrowHeadWidthMedium)

-test_xlArrowHeadWidthNarrow (xlArrowHeadWidthNarrow)

-test_xlArrowHeadWidthWide (xlArrowHeadWidthWide)

-test_xlFillCopy (xlFillCopy)

-test_xlFillDays (xlFillDays)

-test_xlFillDefault (xlFillDefault)

-test_xlFillFormats (xlFillFormats)

-test_xlFillMonths (xlFillMonths)

-test_xlFillSeries (xlFillSeries)

-test_xlFillValues (xlFillValues)

-test_xlFillWeekdays (xlFillWeekdays)

-test_xlFillYears (xlFillYears)

-test_xlGrowthTrend (xlGrowthTrend)

-test_xlLinearTrend (xlLinearTrend)

-test_xlAnd (xlAnd)

-test_xlBottom10Items (xlBottom10Items)

-test_xlBottom10Percent (xlBottom10Percent)

-test_xlOr (xlOr)

-test_xlTop10Items (xlTop10Items)

-test_xlTop10Percent (xlTop10Percent)

-test_xlAxisCrossesAutomatic (xlAxisCrossesAutomatic)

-test_xlAxisCrossesCustom (xlAxisCrossesCustom)

-test_xlAxisCrossesMaximum (xlAxisCrossesMaximum)

-test_xlAxisCrossesMinimum (xlAxisCrossesMinimum)

-test_xlPrimary (xlPrimary)

-test_xlSecondary (xlSecondary)

-test_xlCategory (xlCategory)

-test_xlSeriesAxis (xlSeriesAxis)

-test_xlValue (xlValue)

-Range("A1").Value = "constant name"

-Range("B1").Value = "OOo result"

-Range("C1").Value = "Excel result"

-Range("D1").Value = "Correct?"

-End Sub

-

-Function test_xl24HourClock(ByRef num)

-Range("A2").Clear

-Range("B2").Clear

-Range("C2").Clear

-Range("D2").Clear

-Range("A2").Value = "xl24HourClock"

-Range("B2").Value = 33

-Range("C2").Value = num

-B2 = Range("B2").Value

-C2 = Range("C2").Value

-If B2 = C2 Then

-Range("D2").Value = "OK"

-Else

-Range("D2").Value = "NG"

-End If

-End Function

-

-Function test_xl4DigitYears(ByRef num)

-Range("A3").Clear

-Range("B3").Clear

-Range("C3").Clear

-Range("D3").Clear

-Range("A3").Value = "xl4DigitYears"

-Range("B3").Value = 43

-Range("C3").Value = num

-B3 = Range("B3").Value

-C3 = Range("C3").Value

-If B3 = C3 Then

-Range("D3").Value = "OK"

-Else

-Range("D3").Value = "NG"

-End If

-End Function

-

-Function test_xlAlternateArraySeparator(ByRef num)

-Range("A4").Clear

-Range("B4").Clear

-Range("C4").Clear

-Range("D4").Clear

-Range("A4").Value = "xlAlternateArraySeparator"

-Range("B4").Value = 16

-Range("C4").Value = num

-B4 = Range("B4").Value

-C4 = Range("C4").Value

-If B4 = C4 Then

-Range("D4").Value = "OK"

-Else

-Range("D4").Value = "NG"

-End If

-End Function

-

-Function test_xlColumnSeparator(ByRef num)

-Range("A5").Clear

-Range("B5").Clear

-Range("C5").Clear

-Range("D5").Clear

-Range("A5").Value = "xlColumnSeparator"

-Range("B5").Value = 14

-Range("C5").Value = num

-B5 = Range("B5").Value

-C5 = Range("C5").Value

-If B5 = C5 Then

-Range("D5").Value = "OK"

-Else

-Range("D5").Value = "NG"

-End If

-End Function

-

-Function test_xlCountryCode(ByRef num)

-Range("A6").Clear

-Range("B6").Clear

-Range("C6").Clear

-Range("D6").Clear

-Range("A6").Value = "xlCountryCode"

-Range("B6").Value = 1

-Range("C6").Value = num

-B6 = Range("B6").Value

-C6 = Range("C6").Value

-If B6 = C6 Then

-Range("D6").Value = "OK"

-Else

-Range("D6").Value = "NG"

-End If

-End Function

-

-Function test_xlCountrySetting(ByRef num)

-Range("A7").Clear

-Range("B7").Clear

-Range("C7").Clear

-Range("D7").Clear

-Range("A7").Value = "xlCountrySetting"

-Range("B7").Value = 2

-Range("C7").Value = num

-B7 = Range("B7").Value

-C7 = Range("C7").Value

-If B7 = C7 Then

-Range("D7").Value = "OK"

-Else

-Range("D7").Value = "NG"

-End If

-End Function

-

-Function test_xlCurrencyBefore(ByRef num)

-Range("A8").Clear

-Range("B8").Clear

-Range("C8").Clear

-Range("D8").Clear

-Range("A8").Value = "xlCurrencyBefore"

-Range("B8").Value = 37

-Range("C8").Value = num

-B8 = Range("B8").Value

-C8 = Range("C8").Value

-If B8 = C8 Then

-Range("D8").Value = "OK"

-Else

-Range("D8").Value = "NG"

-End If

-End Function

-

-Function test_xlCurrencyCode(ByRef num)

-Range("A9").Clear

-Range("B9").Clear

-Range("C9").Clear

-Range("D9").Clear

-Range("A9").Value = "xlCurrencyCode"

-Range("B9").Value = 25

-Range("C9").Value = num

-B9 = Range("B9").Value

-C9 = Range("C9").Value

-If B9 = C9 Then

-Range("D9").Value = "OK"

-Else

-Range("D9").Value = "NG"

-End If

-End Function

-

-Function test_xlCurrencyDigits(ByRef num)

-Range("A10").Clear

-Range("B10").Clear

-Range("C10").Clear

-Range("D10").Clear

-Range("A10").Value = "xlCurrencyDigits"

-Range("B10").Value = 27

-Range("C10").Value = num

-B10 = Range("B10").Value

-C10 = Range("C10").Value

-If B10 = C10 Then

-Range("D10").Value = "OK"

-Else

-Range("D10").Value = "NG"

-End If

-End Function

-

-Function test_xlCurrencyLeadingZeros(ByRef num)

-Range("A11").Clear

-Range("B11").Clear

-Range("C11").Clear

-Range("D11").Clear

-Range("A11").Value = "xlCurrencyLeadingZeros"

-Range("B11").Value = 40

-Range("C11").Value = num

-B11 = Range("B11").Value

-C11 = Range("C11").Value

-If B11 = C11 Then

-Range("D11").Value = "OK"

-Else

-Range("D11").Value = "NG"

-End If

-End Function

-

-Function test_xlCurrencyMinusSign(ByRef num)

-Range("A12").Clear

-Range("B12").Clear

-Range("C12").Clear

-Range("D12").Clear

-Range("A12").Value = "xlCurrencyMinusSign"

-Range("B12").Value = 38

-Range("C12").Value = num

-B12 = Range("B12").Value

-C12 = Range("C12").Value

-If B12 = C12 Then

-Range("D12").Value = "OK"

-Else

-Range("D12").Value = "NG"

-End If

-End Function

-

-Function test_xlCurrencyNegative(ByRef num)

-Range("A13").Clear

-Range("B13").Clear

-Range("C13").Clear

-Range("D13").Clear

-Range("A13").Value = "xlCurrencyNegative"

-Range("B13").Value = 28

-Range("C13").Value = num

-B13 = Range("B13").Value

-C13 = Range("C13").Value

-If B13 = C13 Then

-Range("D13").Value = "OK"

-Else

-Range("D13").Value = "NG"

-End If

-End Function

-

-Function test_xlCurrencySpaceBefore(ByRef num)

-Range("A14").Clear

-Range("B14").Clear

-Range("C14").Clear

-Range("D14").Clear

-Range("A14").Value = "xlCurrencySpaceBefore"

-Range("B14").Value = 36

-Range("C14").Value = num

-B14 = Range("B14").Value

-C14 = Range("C14").Value

-If B14 = C14 Then

-Range("D14").Value = "OK"

-Else

-Range("D14").Value = "NG"

-End If

-End Function

-

-Function test_xlCurrencyTrailingZeros(ByRef num)

-Range("A15").Clear

-Range("B15").Clear

-Range("C15").Clear

-Range("D15").Clear

-Range("A15").Value = "xlCurrencyTrailingZeros"

-Range("B15").Value = 39

-Range("C15").Value = num

-B15 = Range("B15").Value

-C15 = Range("C15").Value

-If B15 = C15 Then

-Range("D15").Value = "OK"

-Else

-Range("D15").Value = "NG"

-End If

-End Function

-

-Function test_xlDateOrder(ByRef num)

-Range("A16").Clear

-Range("B16").Clear

-Range("C16").Clear

-Range("D16").Clear

-Range("A16").Value = "xlDateOrder"

-Range("B16").Value = 32

-Range("C16").Value = num

-B16 = Range("B16").Value

-C16 = Range("C16").Value

-If B16 = C16 Then

-Range("D16").Value = "OK"

-Else

-Range("D16").Value = "NG"

-End If

-End Function

-

-Function test_xlDateSeparator(ByRef num)

-Range("A17").Clear

-Range("B17").Clear

-Range("C17").Clear

-Range("D17").Clear

-Range("A17").Value = "xlDateSeparator"

-Range("B17").Value = 17

-Range("C17").Value = num

-B17 = Range("B17").Value

-C17 = Range("C17").Value

-If B17 = C17 Then

-Range("D17").Value = "OK"

-Else

-Range("D17").Value = "NG"

-End If

-End Function

-

-Function test_xlDayCode(ByRef num)

-Range("A18").Clear

-Range("B18").Clear

-Range("C18").Clear

-Range("D18").Clear

-Range("A18").Value = "xlDayCode"

-Range("B18").Value = 21

-Range("C18").Value = num

-B18 = Range("B18").Value

-C18 = Range("C18").Value

-If B18 = C18 Then

-Range("D18").Value = "OK"

-Else

-Range("D18").Value = "NG"

-End If

-End Function

-

-Function test_xlDayLeadingZero(ByRef num)

-Range("A19").Clear

-Range("B19").Clear

-Range("C19").Clear

-Range("D19").Clear

-Range("A19").Value = "xlDayLeadingZero"

-Range("B19").Value = 42

-Range("C19").Value = num

-B19 = Range("B19").Value

-C19 = Range("C19").Value

-If B19 = C19 Then

-Range("D19").Value = "OK"

-Else

-Range("D19").Value = "NG"

-End If

-End Function

-

-Function test_xlDecimalSeparator(ByRef num)

-Range("A20").Clear

-Range("B20").Clear

-Range("C20").Clear

-Range("D20").Clear

-Range("A20").Value = "xlDecimalSeparator"

-Range("B20").Value = 3

-Range("C20").Value = num

-B20 = Range("B20").Value

-C20 = Range("C20").Value

-If B20 = C20 Then

-Range("D20").Value = "OK"

-Else

-Range("D20").Value = "NG"

-End If

-End Function

-

-Function test_xlGeneralFormatName(ByRef num)

-Range("A21").Clear

-Range("B21").Clear

-Range("C21").Clear

-Range("D21").Clear

-Range("A21").Value = "xlGeneralFormatName"

-Range("B21").Value = 26

-Range("C21").Value = num

-B21 = Range("B21").Value

-C21 = Range("C21").Value

-If B21 = C21 Then

-Range("D21").Value = "OK"

-Else

-Range("D21").Value = "NG"

-End If

-End Function

-

-Function test_xlHourCode(ByRef num)

-Range("A22").Clear

-Range("B22").Clear

-Range("C22").Clear

-Range("D22").Clear

-Range("A22").Value = "xlHourCode"

-Range("B22").Value = 22

-Range("C22").Value = num

-B22 = Range("B22").Value

-C22 = Range("C22").Value

-If B22 = C22 Then

-Range("D22").Value = "OK"

-Else

-Range("D22").Value = "NG"

-End If

-End Function

-

-Function test_xlLeftBrace(ByRef num)

-Range("A23").Clear

-Range("B23").Clear

-Range("C23").Clear

-Range("D23").Clear

-Range("A23").Value = "xlLeftBrace"

-Range("B23").Value = 12

-Range("C23").Value = num

-B23 = Range("B23").Value

-C23 = Range("C23").Value

-If B23 = C23 Then

-Range("D23").Value = "OK"

-Else

-Range("D23").Value = "NG"

-End If

-End Function

-

-Function test_xlLeftBracket(ByRef num)

-Range("A24").Clear

-Range("B24").Clear

-Range("C24").Clear

-Range("D24").Clear

-Range("A24").Value = "xlLeftBracket"

-Range("B24").Value = 10

-Range("C24").Value = num

-B24 = Range("B24").Value

-C24 = Range("C24").Value

-If B24 = C24 Then

-Range("D24").Value = "OK"

-Else

-Range("D24").Value = "NG"

-End If

-End Function

-

-Function test_xlListSeparator(ByRef num)

-Range("A25").Clear

-Range("B25").Clear

-Range("C25").Clear

-Range("D25").Clear

-Range("A25").Value = "xlListSeparator"

-Range("B25").Value = 5

-Range("C25").Value = num

-B25 = Range("B25").Value

-C25 = Range("C25").Value

-If B25 = C25 Then

-Range("D25").Value = "OK"

-Else

-Range("D25").Value = "NG"

-End If

-End Function

-

-Function test_xlLowerCaseColumnLetter(ByRef num)

-Range("A26").Clear

-Range("B26").Clear

-Range("C26").Clear

-Range("D26").Clear

-Range("A26").Value = "xlLowerCaseColumnLetter"

-Range("B26").Value = 9

-Range("C26").Value = num

-B26 = Range("B26").Value

-C26 = Range("C26").Value

-If B26 = C26 Then

-Range("D26").Value = "OK"

-Else

-Range("D26").Value = "NG"

-End If

-End Function

-

-Function test_xlLowerCaseRowLetter(ByRef num)

-Range("A27").Clear

-Range("B27").Clear

-Range("C27").Clear

-Range("D27").Clear

-Range("A27").Value = "xlLowerCaseRowLetter"

-Range("B27").Value = 8

-Range("C27").Value = num

-B27 = Range("B27").Value

-C27 = Range("C27").Value

-If B27 = C27 Then

-Range("D27").Value = "OK"

-Else

-Range("D27").Value = "NG"

-End If

-End Function

-

-Function test_xlMDY(ByRef num)

-Range("A28").Clear

-Range("B28").Clear

-Range("C28").Clear

-Range("D28").Clear

-Range("A28").Value = "xlMDY"

-Range("B28").Value = 44

-Range("C28").Value = num

-B28 = Range("B28").Value

-C28 = Range("C28").Value

-If B28 = C28 Then

-Range("D28").Value = "OK"

-Else

-Range("D28").Value = "NG"

-End If

-End Function

-

-Function test_xlMetric(ByRef num)

-Range("A29").Clear

-Range("B29").Clear

-Range("C29").Clear

-Range("D29").Clear

-Range("A29").Value = "xlMetric"

-Range("B29").Value = 35

-Range("C29").Value = num

-B29 = Range("B29").Value

-C29 = Range("C29").Value

-If B29 = C29 Then

-Range("D29").Value = "OK"

-Else

-Range("D29").Value = "NG"

-End If

-End Function

-

-Function test_xlMinuteCode(ByRef num)

-Range("A30").Clear

-Range("B30").Clear

-Range("C30").Clear

-Range("D30").Clear

-Range("A30").Value = "xlMinuteCode"

-Range("B30").Value = 23

-Range("C30").Value = num

-B30 = Range("B30").Value

-C30 = Range("C30").Value

-If B30 = C30 Then

-Range("D30").Value = "OK"

-Else

-Range("D30").Value = "NG"

-End If

-End Function

-

-Function test_xlMonthCode(ByRef num)

-Range("A31").Clear

-Range("B31").Clear

-Range("C31").Clear

-Range("D31").Clear

-Range("A31").Value = "xlMonthCode"

-Range("B31").Value = 20

-Range("C31").Value = num

-B31 = Range("B31").Value

-C31 = Range("C31").Value

-If B31 = C31 Then

-Range("D31").Value = "OK"

-Else

-Range("D31").Value = "NG"

-End If

-End Function

-

-Function test_xlMonthLeadingZero(ByRef num)

-Range("A32").Clear

-Range("B32").Clear

-Range("C32").Clear

-Range("D32").Clear

-Range("A32").Value = "xlMonthLeadingZero"

-Range("B32").Value = 41

-Range("C32").Value = num

-B32 = Range("B32").Value

-C32 = Range("C32").Value

-If B32 = C32 Then

-Range("D32").Value = "OK"

-Else

-Range("D32").Value = "NG"

-End If

-End Function

-

-Function test_xlMonthNameChars(ByRef num)

-Range("A33").Clear

-Range("B33").Clear

-Range("C33").Clear

-Range("D33").Clear

-Range("A33").Value = "xlMonthNameChars"

-Range("B33").Value = 30

-Range("C33").Value = num

-B33 = Range("B33").Value

-C33 = Range("C33").Value

-If B33 = C33 Then

-Range("D33").Value = "OK"

-Else

-Range("D33").Value = "NG"

-End If

-End Function

-

-Function test_xlNocurrencyDigits(ByRef num)

-Range("A34").Clear

-Range("B34").Clear

-Range("C34").Clear

-Range("D34").Clear

-Range("A34").Value = "xlNocurrencyDigits"

-Range("B34").Value = 29

-Range("C34").Value = num

-B34 = Range("B34").Value

-C34 = Range("C34").Value

-If B34 = C34 Then

-Range("D34").Value = "OK"

-Else

-Range("D34").Value = "NG"

-End If

-End Function

-

-Function test_xlNonEnglishFunctions(ByRef num)

-Range("A35").Clear

-Range("B35").Clear

-Range("C35").Clear

-Range("D35").Clear

-Range("A35").Value = "xlNonEnglishFunctions"

-Range("B35").Value = 34

-Range("C35").Value = num

-B35 = Range("B35").Value

-C35 = Range("C35").Value

-If B35 = C35 Then

-Range("D35").Value = "OK"

-Else

-Range("D35").Value = "NG"

-End If

-End Function

-

-Function test_xlRightBrace(ByRef num)

-Range("A36").Clear

-Range("B36").Clear

-Range("C36").Clear

-Range("D36").Clear

-Range("A36").Value = "xlRightBrace"

-Range("B36").Value = 13

-Range("C36").Value = num

-B36 = Range("B36").Value

-C36 = Range("C36").Value

-If B36 = C36 Then

-Range("D36").Value = "OK"

-Else

-Range("D36").Value = "NG"

-End If

-End Function

-

-Function test_xlRightBracket(ByRef num)

-Range("A37").Clear

-Range("B37").Clear

-Range("C37").Clear

-Range("D37").Clear

-Range("A37").Value = "xlRightBracket"

-Range("B37").Value = 11

-Range("C37").Value = num

-B37 = Range("B37").Value

-C37 = Range("C37").Value

-If B37 = C37 Then

-Range("D37").Value = "OK"

-Else

-Range("D37").Value = "NG"

-End If

-End Function

-

-Function test_xlRowSeparator(ByRef num)

-Range("A38").Clear

-Range("B38").Clear

-Range("C38").Clear

-Range("D38").Clear

-Range("A38").Value = "xlRowSeparator"

-Range("B38").Value = 15

-Range("C38").Value = num

-B38 = Range("B38").Value

-C38 = Range("C38").Value

-If B38 = C38 Then

-Range("D38").Value = "OK"

-Else

-Range("D38").Value = "NG"

-End If

-End Function

-

-Function test_xlSecondCode(ByRef num)

-Range("A39").Clear

-Range("B39").Clear

-Range("C39").Clear

-Range("D39").Clear

-Range("A39").Value = "xlSecondCode"

-Range("B39").Value = 24

-Range("C39").Value = num

-B39 = Range("B39").Value

-C39 = Range("C39").Value

-If B39 = C39 Then

-Range("D39").Value = "OK"

-Else

-Range("D39").Value = "NG"

-End If

-End Function

-

-Function test_xlThousandsSeparator(ByRef num)

-Range("A40").Clear

-Range("B40").Clear

-Range("C40").Clear

-Range("D40").Clear

-Range("A40").Value = "xlThousandsSeparator"

-Range("B40").Value = 4

-Range("C40").Value = num

-B40 = Range("B40").Value

-C40 = Range("C40").Value

-If B40 = C40 Then

-Range("D40").Value = "OK"

-Else

-Range("D40").Value = "NG"

-End If

-End Function

-

-Function test_xlTimeLeadingZero(ByRef num)

-Range("A41").Clear

-Range("B41").Clear

-Range("C41").Clear

-Range("D41").Clear

-Range("A41").Value = "xlTimeLeadingZero"

-Range("B41").Value = 45

-Range("C41").Value = num

-B41 = Range("B41").Value

-C41 = Range("C41").Value

-If B41 = C41 Then

-Range("D41").Value = "OK"

-Else

-Range("D41").Value = "NG"

-End If

-End Function

-

-Function test_xlTimeSeparator(ByRef num)

-Range("A42").Clear

-Range("B42").Clear

-Range("C42").Clear

-Range("D42").Clear

-Range("A42").Value = "xlTimeSeparator"

-Range("B42").Value = 18

-Range("C42").Value = num

-B42 = Range("B42").Value

-C42 = Range("C42").Value

-If B42 = C42 Then

-Range("D42").Value = "OK"

-Else

-Range("D42").Value = "NG"

-End If

-End Function

-

-Function test_xlUpperCaseColumnLetter(ByRef num)

-Range("A43").Clear

-Range("B43").Clear

-Range("C43").Clear

-Range("D43").Clear

-Range("A43").Value = "xlUpperCaseColumnLetter"

-Range("B43").Value = 7

-Range("C43").Value = num

-B43 = Range("B43").Value

-C43 = Range("C43").Value

-If B43 = C43 Then

-Range("D43").Value = "OK"

-Else

-Range("D43").Value = "NG"

-End If

-End Function

-

-Function test_xlUpperCaseRowLetter(ByRef num)

-Range("A44").Clear

-Range("B44").Clear

-Range("C44").Clear

-Range("D44").Clear

-Range("A44").Value = "xlUpperCaseRowLetter"

-Range("B44").Value = 6

-Range("C44").Value = num

-B44 = Range("B44").Value

-C44 = Range("C44").Value

-If B44 = C44 Then

-Range("D44").Value = "OK"

-Else

-Range("D44").Value = "NG"

-End If

-End Function

-

-Function test_xlWeekdayNameChars(ByRef num)

-Range("A45").Clear

-Range("B45").Clear

-Range("C45").Clear

-Range("D45").Clear

-Range("A45").Value = "xlWeekdayNameChars"

-Range("B45").Value = 31

-Range("C45").Value = num

-B45 = Range("B45").Value

-C45 = Range("C45").Value

-If B45 = C45 Then

-Range("D45").Value = "OK"

-Else

-Range("D45").Value = "NG"

-End If

-End Function

-

-Function test_xlYearCode(ByRef num)

-Range("A46").Clear

-Range("B46").Clear

-Range("C46").Clear

-Range("D46").Clear

-Range("A46").Value = "xlYearCode"

-Range("B46").Value = 19

-Range("C46").Value = num

-B46 = Range("B46").Value

-C46 = Range("C46").Value

-If B46 = C46 Then

-Range("D46").Value = "OK"

-Else

-Range("D46").Value = "NG"

-End If

-End Function

-

-Function test_xlColumnThenRow(ByRef num)

-Range("A47").Clear

-Range("B47").Clear

-Range("C47").Clear

-Range("D47").Clear

-Range("A47").Value = "xlColumnThenRow"

-Range("B47").Value = 2

-Range("C47").Value = num

-B47 = Range("B47").Value

-C47 = Range("C47").Value

-If B47 = C47 Then

-Range("D47").Value = "OK"

-Else

-Range("D47").Value = "NG"

-End If

-End Function

-

-Function test_xlRowThenColumn(ByRef num)

-Range("A48").Clear

-Range("B48").Clear

-Range("C48").Clear

-Range("D48").Clear

-Range("A48").Value = "xlRowThenColumn"

-Range("B48").Value = 1

-Range("C48").Value = num

-B48 = Range("B48").Value

-C48 = Range("C48").Value

-If B48 = C48 Then

-Range("D48").Value = "OK"

-Else

-Range("D48").Value = "NG"

-End If

-End Function

-

-Function test_xlArabicBothStrict(ByRef num)

-Range("A49").Clear

-Range("B49").Clear

-Range("C49").Clear

-Range("D49").Clear

-Range("A49").Value = "xlArabicBothStrict"

-Range("B49").Value = 3

-Range("C49").Value = num

-B49 = Range("B49").Value

-C49 = Range("C49").Value

-If B49 = C49 Then

-Range("D49").Value = "OK"

-Else

-Range("D49").Value = "NG"

-End If

-End Function

-

-Function test_xlArabicNone(ByRef num)

-Range("A50").Clear

-Range("B50").Clear

-Range("C50").Clear

-Range("D50").Clear

-Range("A50").Value = "xlArabicNone"

-Range("B50").Value = 0

-Range("C50").Value = num

-B50 = Range("B50").Value

-C50 = Range("C50").Value

-If B50 = C50 Then

-Range("D50").Value = "OK"

-Else

-Range("D50").Value = "NG"

-End If

-End Function

-

-Function test_xlArabicStrictAlefHamza(ByRef num)

-Range("A51").Clear

-Range("B51").Clear

-Range("C51").Clear

-Range("D51").Clear

-Range("A51").Value = "xlArabicStrictAlefHamza"

-Range("B51").Value = 1

-Range("C51").Value = num

-B51 = Range("B51").Value

-C51 = Range("C51").Value

-If B51 = C51 Then

-Range("D51").Value = "OK"

-Else

-Range("D51").Value = "NG"

-End If

-End Function

-

-Function test_xlArabicStrictFinalYaa(ByRef num)

-Range("A52").Clear

-Range("B52").Clear

-Range("C52").Clear

-Range("D52").Clear

-Range("A52").Value = "xlArabicStrictFinalYaa"

-Range("B52").Value = 2

-Range("C52").Value = num

-B52 = Range("B52").Value

-C52 = Range("C52").Value

-If B52 = C52 Then

-Range("D52").Value = "OK"

-Else

-Range("D52").Value = "NG"

-End If

-End Function

-

-Function test_xlArrangeStyleCascade(ByRef num)

-Range("A53").Clear

-Range("B53").Clear

-Range("C53").Clear

-Range("D53").Clear

-Range("A53").Value = "xlArrangeStyleCascade"

-Range("B53").Value = 7

-Range("C53").Value = num

-B53 = Range("B53").Value

-C53 = Range("C53").Value

-If B53 = C53 Then

-Range("D53").Value = "OK"

-Else

-Range("D53").Value = "NG"

-End If

-End Function

-

-Function test_xlArrangeStyleHorizontal(ByRef num)

-Range("A54").Clear

-Range("B54").Clear

-Range("C54").Clear

-Range("D54").Clear

-Range("A54").Value = "xlArrangeStyleHorizontal"

-Range("B54").Value = -4128

-Range("C54").Value = num

-B54 = Range("B54").Value

-C54 = Range("C54").Value

-If B54 = C54 Then

-Range("D54").Value = "OK"

-Else

-Range("D54").Value = "NG"

-End If

-End Function

-

-Function test_xlArrangeStyleTiled(ByRef num)

-Range("A55").Clear

-Range("B55").Clear

-Range("C55").Clear

-Range("D55").Clear

-Range("A55").Value = "xlArrangeStyleTiled"

-Range("B55").Value = 1

-Range("C55").Value = num

-B55 = Range("B55").Value

-C55 = Range("C55").Value

-If B55 = C55 Then

-Range("D55").Value = "OK"

-Else

-Range("D55").Value = "NG"

-End If

-End Function

-

-Function test_xlArrangeStyleVertical(ByRef num)

-Range("A56").Clear

-Range("B56").Clear

-Range("C56").Clear

-Range("D56").Clear

-Range("A56").Value = "xlArrangeStyleVertical"

-Range("B56").Value = -4166

-Range("C56").Value = num

-B56 = Range("B56").Value

-C56 = Range("C56").Value

-If B56 = C56 Then

-Range("D56").Value = "OK"

-Else

-Range("D56").Value = "NG"

-End If

-End Function

-

-Function test_xlArrowHeadLengthLong(ByRef num)

-Range("A57").Clear

-Range("B57").Clear

-Range("C57").Clear

-Range("D57").Clear

-Range("A57").Value = "xlArrowHeadLengthLong"

-Range("B57").Value = 3

-Range("C57").Value = num

-B57 = Range("B57").Value

-C57 = Range("C57").Value

-If B57 = C57 Then

-Range("D57").Value = "OK"

-Else

-Range("D57").Value = "NG"

-End If

-End Function

-

-Function test_xlArrowHeadLengthMedium(ByRef num)

-Range("A58").Clear

-Range("B58").Clear

-Range("C58").Clear

-Range("D58").Clear

-Range("A58").Value = "xlArrowHeadLengthMedium"

-Range("B58").Value = -4138

-Range("C58").Value = num

-B58 = Range("B58").Value

-C58 = Range("C58").Value

-If B58 = C58 Then

-Range("D58").Value = "OK"

-Else

-Range("D58").Value = "NG"

-End If

-End Function

-

-Function test_xlArrowHeadLengthShort(ByRef num)

-Range("A59").Clear

-Range("B59").Clear

-Range("C59").Clear

-Range("D59").Clear

-Range("A59").Value = "xlArrowHeadLengthShort"

-Range("B59").Value = 1

-Range("C59").Value = num

-B59 = Range("B59").Value

-C59 = Range("C59").Value

-If B59 = C59 Then

-Range("D59").Value = "OK"

-Else

-Range("D59").Value = "NG"

-End If

-End Function

-

-Function test_xlArrowHeadStyleClosed(ByRef num)

-Range("A60").Clear

-Range("B60").Clear

-Range("C60").Clear

-Range("D60").Clear

-Range("A60").Value = "xlArrowHeadStyleClosed"

-Range("B60").Value = 3

-Range("C60").Value = num

-B60 = Range("B60").Value

-C60 = Range("C60").Value

-If B60 = C60 Then

-Range("D60").Value = "OK"

-Else

-Range("D60").Value = "NG"

-End If

-End Function

-

-Function test_xlArrowHeadStyleDoubleClosed(ByRef num)

-Range("A61").Clear

-Range("B61").Clear

-Range("C61").Clear

-Range("D61").Clear

-Range("A61").Value = "xlArrowHeadStyleDoubleClosed"

-Range("B61").Value = 4

-Range("C61").Value = num

-B61 = Range("B61").Value

-C61 = Range("C61").Value

-If B61 = C61 Then

-Range("D61").Value = "OK"

-Else

-Range("D61").Value = "NG"

-End If

-End Function

-

-Function test_xlArrowHeadStyleDoubleOpen(ByRef num)

-Range("A62").Clear

-Range("B62").Clear

-Range("C62").Clear

-Range("D62").Clear

-Range("A62").Value = "xlArrowHeadStyleDoubleOpen"

-Range("B62").Value = 5

-Range("C62").Value = num

-B62 = Range("B62").Value

-C62 = Range("C62").Value

-If B62 = C62 Then

-Range("D62").Value = "OK"

-Else

-Range("D62").Value = "NG"

-End If

-End Function

-

-Function test_xlArrowHeadStyleNone(ByRef num)

-Range("A63").Clear

-Range("B63").Clear

-Range("C63").Clear

-Range("D63").Clear

-Range("A63").Value = "xlArrowHeadStyleNone"

-Range("B63").Value = -4142

-Range("C63").Value = num

-B63 = Range("B63").Value

-C63 = Range("C63").Value

-If B63 = C63 Then

-Range("D63").Value = "OK"

-Else

-Range("D63").Value = "NG"

-End If

-End Function

-

-Function test_xlArrowHeadStyleOpen(ByRef num)

-Range("A64").Clear

-Range("B64").Clear

-Range("C64").Clear

-Range("D64").Clear

-Range("A64").Value = "xlArrowHeadStyleOpen"

-Range("B64").Value = 2

-Range("C64").Value = num

-B64 = Range("B64").Value

-C64 = Range("C64").Value

-If B64 = C64 Then

-Range("D64").Value = "OK"

-Else

-Range("D64").Value = "NG"

-End If

-End Function

-

-Function test_xlArrowHeadWidthMedium(ByRef num)

-Range("A65").Clear

-Range("B65").Clear

-Range("C65").Clear

-Range("D65").Clear

-Range("A65").Value = "xlArrowHeadWidthMedium"

-Range("B65").Value = -4138

-Range("C65").Value = num

-B65 = Range("B65").Value

-C65 = Range("C65").Value

-If B65 = C65 Then

-Range("D65").Value = "OK"

-Else

-Range("D65").Value = "NG"

-End If

-End Function

-

-Function test_xlArrowHeadWidthNarrow(ByRef num)

-Range("A66").Clear

-Range("B66").Clear

-Range("C66").Clear

-Range("D66").Clear

-Range("A66").Value = "xlArrowHeadWidthNarrow"

-Range("B66").Value = 1

-Range("C66").Value = num

-B66 = Range("B66").Value

-C66 = Range("C66").Value

-If B66 = C66 Then

-Range("D66").Value = "OK"

-Else

-Range("D66").Value = "NG"

-End If

-End Function

-

-Function test_xlArrowHeadWidthWide(ByRef num)

-Range("A67").Clear

-Range("B67").Clear

-Range("C67").Clear

-Range("D67").Clear

-Range("A67").Value = "xlArrowHeadWidthWide"

-Range("B67").Value = 3

-Range("C67").Value = num

-B67 = Range("B67").Value

-C67 = Range("C67").Value

-If B67 = C67 Then

-Range("D67").Value = "OK"

-Else

-Range("D67").Value = "NG"

-End If

-End Function

-

-Function test_xlFillCopy(ByRef num)

-Range("A68").Clear

-Range("B68").Clear

-Range("C68").Clear

-Range("D68").Clear

-Range("A68").Value = "xlFillCopy"

-Range("B68").Value = 1

-Range("C68").Value = num

-B68 = Range("B68").Value

-C68 = Range("C68").Value

-If B68 = C68 Then

-Range("D68").Value = "OK"

-Else

-Range("D68").Value = "NG"

-End If

-End Function

-

-Function test_xlFillDays(ByRef num)

-Range("A69").Clear

-Range("B69").Clear

-Range("C69").Clear

-Range("D69").Clear

-Range("A69").Value = "xlFillDays"

-Range("B69").Value = 5

-Range("C69").Value = num

-B69 = Range("B69").Value

-C69 = Range("C69").Value

-If B69 = C69 Then

-Range("D69").Value = "OK"

-Else

-Range("D69").Value = "NG"

-End If

-End Function

-

-Function test_xlFillDefault(ByRef num)

-Range("A70").Clear

-Range("B70").Clear

-Range("C70").Clear

-Range("D70").Clear

-Range("A70").Value = "xlFillDefault"

-Range("B70").Value = 0

-Range("C70").Value = num

-B70 = Range("B70").Value

-C70 = Range("C70").Value

-If B70 = C70 Then

-Range("D70").Value = "OK"

-Else

-Range("D70").Value = "NG"

-End If

-End Function

-

-Function test_xlFillFormats(ByRef num)

-Range("A71").Clear

-Range("B71").Clear

-Range("C71").Clear

-Range("D71").Clear

-Range("A71").Value = "xlFillFormats"

-Range("B71").Value = 3

-Range("C71").Value = num

-B71 = Range("B71").Value

-C71 = Range("C71").Value

-If B71 = C71 Then

-Range("D71").Value = "OK"

-Else

-Range("D71").Value = "NG"

-End If

-End Function

-

-Function test_xlFillMonths(ByRef num)

-Range("A72").Clear

-Range("B72").Clear

-Range("C72").Clear

-Range("D72").Clear

-Range("A72").Value = "xlFillMonths"

-Range("B72").Value = 7

-Range("C72").Value = num

-B72 = Range("B72").Value

-C72 = Range("C72").Value

-If B72 = C72 Then

-Range("D72").Value = "OK"

-Else

-Range("D72").Value = "NG"

-End If

-End Function

-

-Function test_xlFillSeries(ByRef num)

-Range("A73").Clear

-Range("B73").Clear

-Range("C73").Clear

-Range("D73").Clear

-Range("A73").Value = "xlFillSeries"

-Range("B73").Value = 2

-Range("C73").Value = num

-B73 = Range("B73").Value

-C73 = Range("C73").Value

-If B73 = C73 Then

-Range("D73").Value = "OK"

-Else

-Range("D73").Value = "NG"

-End If

-End Function

-

-Function test_xlFillValues(ByRef num)

-Range("A74").Clear

-Range("B74").Clear

-Range("C74").Clear

-Range("D74").Clear

-Range("A74").Value = "xlFillValues"

-Range("B74").Value = 4

-Range("C74").Value = num

-B74 = Range("B74").Value

-C74 = Range("C74").Value

-If B74 = C74 Then

-Range("D74").Value = "OK"

-Else

-Range("D74").Value = "NG"

-End If

-End Function

-

-Function test_xlFillWeekdays(ByRef num)

-Range("A75").Clear

-Range("B75").Clear

-Range("C75").Clear

-Range("D75").Clear

-Range("A75").Value = "xlFillWeekdays"

-Range("B75").Value = 6

-Range("C75").Value = num

-B75 = Range("B75").Value

-C75 = Range("C75").Value

-If B75 = C75 Then

-Range("D75").Value = "OK"

-Else

-Range("D75").Value = "NG"

-End If

-End Function

-

-Function test_xlFillYears(ByRef num)

-Range("A76").Clear

-Range("B76").Clear

-Range("C76").Clear

-Range("D76").Clear

-Range("A76").Value = "xlFillYears"

-Range("B76").Value = 8

-Range("C76").Value = num

-B76 = Range("B76").Value

-C76 = Range("C76").Value

-If B76 = C76 Then

-Range("D76").Value = "OK"

-Else

-Range("D76").Value = "NG"

-End If

-End Function

-

-Function test_xlGrowthTrend(ByRef num)

-Range("A77").Clear

-Range("B77").Clear

-Range("C77").Clear

-Range("D77").Clear

-Range("A77").Value = "xlGrowthTrend"

-Range("B77").Value = 10

-Range("C77").Value = num

-B77 = Range("B77").Value

-C77 = Range("C77").Value

-If B77 = C77 Then

-Range("D77").Value = "OK"

-Else

-Range("D77").Value = "NG"

-End If

-End Function

-

-Function test_xlLinearTrend(ByRef num)

-Range("A78").Clear

-Range("B78").Clear

-Range("C78").Clear

-Range("D78").Clear

-Range("A78").Value = "xlLinearTrend"

-Range("B78").Value = 9

-Range("C78").Value = num

-B78 = Range("B78").Value

-C78 = Range("C78").Value

-If B78 = C78 Then

-Range("D78").Value = "OK"

-Else

-Range("D78").Value = "NG"

-End If

-End Function

-

-Function test_xlAnd(ByRef num)

-Range("A79").Clear

-Range("B79").Clear

-Range("C79").Clear

-Range("D79").Clear

-Range("A79").Value = "xlAnd"

-Range("B79").Value = 1

-Range("C79").Value = num

-B79 = Range("B79").Value

-C79 = Range("C79").Value

-If B79 = C79 Then

-Range("D79").Value = "OK"

-Else

-Range("D79").Value = "NG"

-End If

-End Function

-

-Function test_xlBottom10Items(ByRef num)

-Range("A80").Clear

-Range("B80").Clear

-Range("C80").Clear

-Range("D80").Clear

-Range("A80").Value = "xlBottom10Items"

-Range("B80").Value = 4

-Range("C80").Value = num

-B80 = Range("B80").Value

-C80 = Range("C80").Value

-If B80 = C80 Then

-Range("D80").Value = "OK"

-Else

-Range("D80").Value = "NG"

-End If

-End Function

-

-Function test_xlBottom10Percent(ByRef num)

-Range("A81").Clear

-Range("B81").Clear

-Range("C81").Clear

-Range("D81").Clear

-Range("A81").Value = "xlBottom10Percent"

-Range("B81").Value = 6

-Range("C81").Value = num

-B81 = Range("B81").Value

-C81 = Range("C81").Value

-If B81 = C81 Then

-Range("D81").Value = "OK"

-Else

-Range("D81").Value = "NG"

-End If

-End Function

-

-Function test_xlOr(ByRef num)

-Range("A82").Clear

-Range("B82").Clear

-Range("C82").Clear

-Range("D82").Clear

-Range("A82").Value = "xlOr"

-Range("B82").Value = 2

-Range("C82").Value = num

-B82 = Range("B82").Value

-C82 = Range("C82").Value

-If B82 = C82 Then

-Range("D82").Value = "OK"

-Else

-Range("D82").Value = "NG"

-End If

-End Function

-

-Function test_xlTop10Items(ByRef num)

-Range("A83").Clear

-Range("B83").Clear

-Range("C83").Clear

-Range("D83").Clear

-Range("A83").Value = "xlTop10Items"

-Range("B83").Value = 3

-Range("C83").Value = num

-B83 = Range("B83").Value

-C83 = Range("C83").Value

-If B83 = C83 Then

-Range("D83").Value = "OK"

-Else

-Range("D83").Value = "NG"

-End If

-End Function

-

-Function test_xlTop10Percent(ByRef num)

-Range("A84").Clear

-Range("B84").Clear

-Range("C84").Clear

-Range("D84").Clear

-Range("A84").Value = "xlTop10Percent"

-Range("B84").Value = 5

-Range("C84").Value = num

-B84 = Range("B84").Value

-C84 = Range("C84").Value

-If B84 = C84 Then

-Range("D84").Value = "OK"

-Else

-Range("D84").Value = "NG"

-End If

-End Function

-

-Function test_xlAxisCrossesAutomatic(ByRef num)

-Range("A85").Clear

-Range("B85").Clear

-Range("C85").Clear

-Range("D85").Clear

-Range("A85").Value = "xlAxisCrossesAutomatic"

-Range("B85").Value = -4105

-Range("C85").Value = num

-B85 = Range("B85").Value

-C85 = Range("C85").Value

-If B85 = C85 Then

-Range("D85").Value = "OK"

-Else

-Range("D85").Value = "NG"

-End If

-End Function

-

-Function test_xlAxisCrossesCustom(ByRef num)

-Range("A86").Clear

-Range("B86").Clear

-Range("C86").Clear

-Range("D86").Clear

-Range("A86").Value = "xlAxisCrossesCustom"

-Range("B86").Value = -4114

-Range("C86").Value = num

-B86 = Range("B86").Value

-C86 = Range("C86").Value

-If B86 = C86 Then

-Range("D86").Value = "OK"

-Else

-Range("D86").Value = "NG"

-End If

-End Function

-

-Function test_xlAxisCrossesMaximum(ByRef num)

-Range("A87").Clear

-Range("B87").Clear

-Range("C87").Clear

-Range("D87").Clear

-Range("A87").Value = "xlAxisCrossesMaximum"

-Range("B87").Value = 2

-Range("C87").Value = num

-B87 = Range("B87").Value

-C87 = Range("C87").Value

-If B87 = C87 Then

-Range("D87").Value = "OK"

-Else

-Range("D87").Value = "NG"

-End If

-End Function

-

-Function test_xlAxisCrossesMinimum(ByRef num)

-Range("A88").Clear

-Range("B88").Clear

-Range("C88").Clear

-Range("D88").Clear

-Range("A88").Value = "xlAxisCrossesMinimum"

-Range("B88").Value = 4

-Range("C88").Value = num

-B88 = Range("B88").Value

-C88 = Range("C88").Value

-If B88 = C88 Then

-Range("D88").Value = "OK"

-Else

-Range("D88").Value = "NG"

-End If

-End Function

-

-Function test_xlPrimary(ByRef num)

-Range("A89").Clear

-Range("B89").Clear

-Range("C89").Clear

-Range("D89").Clear

-Range("A89").Value = "xlPrimary"

-Range("B89").Value = 1

-Range("C89").Value = num

-B89 = Range("B89").Value

-C89 = Range("C89").Value

-If B89 = C89 Then

-Range("D89").Value = "OK"

-Else

-Range("D89").Value = "NG"

-End If

-End Function

-

-Function test_xlSecondary(ByRef num)

-Range("A90").Clear

-Range("B90").Clear

-Range("C90").Clear

-Range("D90").Clear

-Range("A90").Value = "xlSecondary"

-Range("B90").Value = 2

-Range("C90").Value = num

-B90 = Range("B90").Value

-C90 = Range("C90").Value

-If B90 = C90 Then

-Range("D90").Value = "OK"

-Else

-Range("D90").Value = "NG"

-End If

-End Function

-

-Function test_xlCategory(ByRef num)

-Range("A91").Clear

-Range("B91").Clear

-Range("C91").Clear

-Range("D91").Clear

-Range("A91").Value = "xlCategory"

-Range("B91").Value = 1

-Range("C91").Value = num

-B91 = Range("B91").Value

-C91 = Range("C91").Value

-If B91 = C91 Then

-Range("D91").Value = "OK"

-Else

-Range("D91").Value = "NG"

-End If

-End Function

-

-Function test_xlSeriesAxis(ByRef num)

-Range("A92").Clear

-Range("B92").Clear

-Range("C92").Clear

-Range("D92").Clear

-Range("A92").Value = "xlSeriesAxis"

-Range("B92").Value = 3

-Range("C92").Value = num

-B92 = Range("B92").Value

-C92 = Range("C92").Value

-If B92 = C92 Then

-Range("D92").Value = "OK"

-Else

-Range("D92").Value = "NG"

-End If

-End Function

-

-Function test_xlValue(ByRef num)

-Range("A93").Clear

-Range("B93").Clear

-Range("C93").Clear

-Range("D93").Clear

-Range("A93").Value = "xlValue"

-Range("B93").Value = 2

-Range("C93").Value = num

-B93 = Range("B93").Value

-C93 = Range("C93").Value

-If B93 = C93 Then

-Range("D93").Value = "OK"

-Else

-Range("D93").Value = "NG"

-End If

-End Function

-

-<<<<<<
-======================
-Module2
->>>>>>
-Attribute VB_Name = "Module2"

-

-Sub main_2()

-test_xlBackgroundAutomatic (xlBackgroundAutomatic)

-test_xlBackgroundOpaque (xlBackgroundOpaque)

-test_xlBackgroundTransparent (xlBackgroundTransparent)

-test_xlHairline (xlHairline)

-test_xlMedium (xlMedium)

-test_xlThick (xlThick)

-test_xlThin (xlThin)

-test_xlBox (xlBox)

-test_xlConeToMax (xlConeToMax)

-test_xlConeToPoint (xlConeToPoint)

-test_xlCylinder (xlCylinder)

-test_xlPyramidToMax (xlPyramidToMax)

-test_xlPyramidToPoint (xlPyramidToPoint)

-Range("A1").Value = "constant name"

-Range("B1").Value = "OOo result"

-Range("C1").Value = "Excel result"

-Range("D1").Value = "Correct?"

-End Sub

-

-Function test_xlBackgroundAutomatic(ByRef num)

-Range("A2").Clear

-Range("B2").Clear

-Range("C2").Clear

-Range("D2").Clear

-Range("A2").Value = "xlBackgroundAutomatic"

-Range("B2").Value = -4105

-Range("C2").Value = num

-B2 = Range("B2").Value

-C2 = Range("C2").Value

-If B2 = C2 Then

-Range("D2").Value = "OK"

-Else

-Range("D2").Value = "NG"

-End If

-End Function

-

-Function test_xlBackgroundOpaque(ByRef num)

-Range("A3").Clear

-Range("B3").Clear

-Range("C3").Clear

-Range("D3").Clear

-Range("A3").Value = "xlBackgroundOpaque"

-Range("B3").Value = 3

-Range("C3").Value = num

-B3 = Range("B3").Value

-C3 = Range("C3").Value

-If B3 = C3 Then

-Range("D3").Value = "OK"

-Else

-Range("D3").Value = "NG"

-End If

-End Function

-

-Function test_xlBackgroundTransparent(ByRef num)

-Range("A4").Clear

-Range("B4").Clear

-Range("C4").Clear

-Range("D4").Clear

-Range("A4").Value = "xlBackgroundTransparent"

-Range("B4").Value = 2

-Range("C4").Value = num

-B4 = Range("B4").Value

-C4 = Range("C4").Value

-If B4 = C4 Then

-Range("D4").Value = "OK"

-Else

-Range("D4").Value = "NG"

-End If

-End Function

-

-Function test_xlHairline(ByRef num)

-Range("A5").Clear

-Range("B5").Clear

-Range("C5").Clear

-Range("D5").Clear

-Range("A5").Value = "xlHairline"

-Range("B5").Value = 1

-Range("C5").Value = num

-B5 = Range("B5").Value

-C5 = Range("C5").Value

-If B5 = C5 Then

-Range("D5").Value = "OK"

-Else

-Range("D5").Value = "NG"

-End If

-End Function

-

-Function test_xlMedium(ByRef num)

-Range("A6").Clear

-Range("B6").Clear

-Range("C6").Clear

-Range("D6").Clear

-Range("A6").Value = "xlMedium"

-Range("B6").Value = -4138

-Range("C6").Value = num

-B6 = Range("B6").Value

-C6 = Range("C6").Value

-If B6 = C6 Then

-Range("D6").Value = "OK"

-Else

-Range("D6").Value = "NG"

-End If

-End Function

-

-Function test_xlThick(ByRef num)

-Range("A7").Clear

-Range("B7").Clear

-Range("C7").Clear

-Range("D7").Clear

-Range("A7").Value = "xlThick"

-Range("B7").Value = 4

-Range("C7").Value = num

-B7 = Range("B7").Value

-C7 = Range("C7").Value

-If B7 = C7 Then

-Range("D7").Value = "OK"

-Else

-Range("D7").Value = "NG"

-End If

-End Function

-

-Function test_xlThin(ByRef num)

-Range("A8").Clear

-Range("B8").Clear

-Range("C8").Clear

-Range("D8").Clear

-Range("A8").Value = "xlThin"

-Range("B8").Value = 2

-Range("C8").Value = num

-B8 = Range("B8").Value

-C8 = Range("C8").Value

-If B8 = C8 Then

-Range("D8").Value = "OK"

-Else

-Range("D8").Value = "NG"

-End If

-End Function

-

-Function test_xlBox(ByRef num)

-Range("A9").Clear

-Range("B9").Clear

-Range("C9").Clear

-Range("D9").Clear

-Range("A9").Value = "xlBox"

-Range("B9").Value = 0

-Range("C9").Value = num

-B9 = Range("B9").Value

-C9 = Range("C9").Value

-If B9 = C9 Then

-Range("D9").Value = "OK"

-Else

-Range("D9").Value = "NG"

-End If

-End Function

-

-Function test_xlConeToMax(ByRef num)

-Range("A10").Clear

-Range("B10").Clear

-Range("C10").Clear

-Range("D10").Clear

-Range("A10").Value = "xlConeToMax"

-Range("B10").Value = 5

-Range("C10").Value = num

-B10 = Range("B10").Value

-C10 = Range("C10").Value

-If B10 = C10 Then

-Range("D10").Value = "OK"

-Else

-Range("D10").Value = "NG"

-End If

-End Function

-

-Function test_xlConeToPoint(ByRef num)

-Range("A11").Clear

-Range("B11").Clear

-Range("C11").Clear

-Range("D11").Clear

-Range("A11").Value = "xlConeToPoint"

-Range("B11").Value = 4

-Range("C11").Value = num

-B11 = Range("B11").Value

-C11 = Range("C11").Value

-If B11 = C11 Then

-Range("D11").Value = "OK"

-Else

-Range("D11").Value = "NG"

-End If

-End Function

-

-Function test_xlCylinder(ByRef num)

-Range("A12").Clear

-Range("B12").Clear

-Range("C12").Clear

-Range("D12").Clear

-Range("A12").Value = "xlCylinder"

-Range("B12").Value = 3

-Range("C12").Value = num

-B12 = Range("B12").Value

-C12 = Range("C12").Value

-If B12 = C12 Then

-Range("D12").Value = "OK"

-Else

-Range("D12").Value = "NG"

-End If

-End Function

-

-Function test_xlPyramidToMax(ByRef num)

-Range("A13").Clear

-Range("B13").Clear

-Range("C13").Clear

-Range("D13").Clear

-Range("A13").Value = "xlPyramidToMax"

-Range("B13").Value = 2

-Range("C13").Value = num

-B13 = Range("B13").Value

-C13 = Range("C13").Value

-If B13 = C13 Then

-Range("D13").Value = "OK"

-Else

-Range("D13").Value = "NG"

-End If

-End Function

-

-Function test_xlPyramidToPoint(ByRef num)

-Range("A14").Clear

-Range("B14").Clear

-Range("C14").Clear

-Range("D14").Clear

-Range("A14").Value = "xlPyramidToPoint"

-Range("B14").Value = 1

-Range("C14").Value = num

-B14 = Range("B14").Value

-C14 = Range("C14").Value

-If B14 = C14 Then

-Range("D14").Value = "OK"

-Else

-Range("D14").Value = "NG"

-End If

-End Function

-

-<<<<<<
-======================
-Module3
->>>>>>
-Attribute VB_Name = "Module3"

-Sub main_3()

-test_xlDialogActivate (xlDialogActivate)

-test_xlDialogActiveCellFont (xlDialogActiveCellFont)

-test_xlDialogAddChartAutoformat (xlDialogAddChartAutoformat)

-test_xlDialogAddinManager (xlDialogAddinManager)

-test_xlDialogAlignment (xlDialogAlignment)

-test_xlDialogApplyNames (xlDialogApplyNames)

-test_xlDialogApplyStyle (xlDialogApplyStyle)

-test_xlDialogAppMove (xlDialogAppMove)

-test_xlDialogAppSize (xlDialogAppSize)

-test_xlDialogArrangeAll (xlDialogArrangeAll)

-test_xlDialogAssignToObject (xlDialogAssignToObject)

-test_xlDialogAssignToTool (xlDialogAssignToTool)

-test_xlDialogAttachText (xlDialogAttachText)

-test_xlDialogAttachToolbars (xlDialogAttachToolbars)

-test_xlDialogAutoCorrect (xlDialogAutoCorrect)

-test_xlDialogAxes (xlDialogAxes)

-test_xlDialogBorder (xlDialogBorder)

-test_xlDialogCalculation (xlDialogCalculation)

-test_xlDialogCellProtection (xlDialogCellProtection)

-test_xlDialogChangeLink (xlDialogChangeLink)

-test_xlDialogChartAddData (xlDialogChartAddData)

-test_xlDialogChartLocation (xlDialogChartLocation)

-test_xlDialogChartOptionDataLabelMultiple (xlDialogChartOptionDataLabelMultiple)

-test_xlDialogChartOptionDataLabels (xlDialogChartOptionDataLabels)

-test_xlDialogChartOptionDataTable (xlDialogChartOptionDataTable)

-test_xlDialogChartSourceData (xlDialogChartSourceData)

-test_xlDialogChartTrend (xlDialogChartTrend)

-test_xlDialogChartType (xlDialogChartType)

-test_xlDialogChartWizard (xlDialogChartWizard)

-test_xlDialogChechboxProperties (xlDialogChechboxProperties)

-test_xlDialogClear (xlDialogClear)

-test_xlDialogColorPalette (xlDialogColorPalette)

-test_xlDialogColumnWidth (xlDialogColumnWidth)

-test_xlDialogCombination (xlDialogCombination)

-test_xlDialogConditionalFormatting (xlDialogConditionalFormatting)

-test_xlDialogConsolidate (xlDialogConsolidate)

-test_xlDialogCopyChart (xlDialogCopyChart)

-test_xlDialogCopyPicture (xlDialogCopyPicture)

-test_xlDialogCreateList (xlDialogCreateList)

-test_xlDialogCreateNames (xlDialogCreateNames)

-test_xlDialogCreatePublisher (xlDialogCreatePublisher)

-test_xlDialogCustomizeToolbar (xlDialogCustomizeToolbar)

-test_xlDialogCustomViews (xlDialogCustomViews)

-test_xlDialogDataDelete (xlDialogDataDelete)

-test_xlDialogDataLabel (xlDialogDataLabel)

-test_xlDialogDataLabelMultiple (xlDialogDataLabelMultiple)

-test_xlDialogDataSeries (xlDialogDataSeries)

-test_xlDialogDataValidation (xlDialogDataValidation)

-test_xlDialogDefineName (xlDialogDefineName)

-test_xlDialogDefineStyle (xlDialogDefineStyle)

-test_xlDialogDeleteFormat (xlDialogDeleteFormat)

-test_xlDialogDeleteName (xlDialogDeleteName)

-test_xlDialogDemote (xlDialogDemote)

-test_xlDialogDisplay (xlDialogDisplay)

-test_xlDialogEditboxProperties (xlDialogEditboxProperties)

-test_xlDialogEditColor (xlDialogEditColor)

-test_xlDialogEditDelete (xlDialogEditDelete)

-test_xlDialogEditionOptions (xlDialogEditionOptions)

-test_xlDialogEditSeries (xlDialogEditSeries)

-test_xlDialogErrorbarX (xlDialogErrorbarX)

-test_xlDialogErrorbarY (xlDialogErrorbarY)

-test_xlDialogErrorChecking (xlDialogErrorChecking)

-test_xlDialogEvaluateFormula (xlDialogEvaluateFormula)

-test_xlDialogExternalDataProperties (xlDialogExternalDataProperties)

-test_xlDialogExtract (xlDialogExtract)

-test_xlDialogFileDelete (xlDialogFileDelete)

-test_xlDialogFileSharing (xlDialogFileSharing)

-test_xlDialogFillGroup (xlDialogFillGroup)

-test_xlDialogFillWorkGroup (xlDialogFillWorkGroup)

-test_xlDialogFilter (xlDialogFilter)

-test_xlDialogFilterAdvanced (xlDialogFilterAdvanced)

-test_xlDialogFindFile (xlDialogFindFile)

-test_xlDialogFont (xlDialogFont)

-test_xlDialogFontProperties (xlDialogFontProperties)

-test_xlDialogFormatAuto (xlDialogFormatAuto)

-test_xlDialogFormatChart (xlDialogFormatChart)

-test_xlDialogFormatCharttype (xlDialogFormatCharttype)

-test_xlDialogFormatFont (xlDialogFormatFont)

-test_xlDialogFormatLegend (xlDialogFormatLegend)

-test_xlDialogFormatMain (xlDialogFormatMain)

-test_xlDialogFormatMove (xlDialogFormatMove)

-test_xlDialogFormatNumber (xlDialogFormatNumber)

-test_xlDialogFormatOverlay (xlDialogFormatOverlay)

-test_xlDialogFormatSize (xlDialogFormatSize)

-test_xlDialogFormatText (xlDialogFormatText)

-test_xlDialogFormulaFind (xlDialogFormulaFind)

-test_xlDialogFormulaGoto (xlDialogFormulaGoto)

-test_xlDialogFormulaReplace (xlDialogFormulaReplace)

-test_xlDialogFunctionWizard (xlDialogFunctionWizard)

-test_xlDialogGallery3dArea (xlDialogGallery3dArea)

-test_xlDialogGallery3dBar (xlDialogGallery3dBar)

-test_xlDialogGallery3dColumn (xlDialogGallery3dColumn)

-test_xlDialogGallery3dLine (xlDialogGallery3dLine)

-test_xlDialogGallery3dPie (xlDialogGallery3dPie)

-test_xlDialogGallery3dSurface (xlDialogGallery3dSurface)

-test_xlDialogGalleryArea (xlDialogGalleryArea)

-test_xlDialogGalleryBar (xlDialogGalleryBar)

-test_xlDialogGalleryColumn (xlDialogGalleryColumn)

-test_xlDialogGalleryCustom (xlDialogGalleryCustom)

-test_xlDialogGalleryDoughnut (xlDialogGalleryDoughnut)

-test_xlDialogGalleryLine (xlDialogGalleryLine)

-test_xlDialogGalleryPie (xlDialogGalleryPie)

-test_xlDialogGalleryRader (xlDialogGalleryRader)

-test_xlDialogGalleryScatter (xlDialogGalleryScatter)

-test_xlDialogGoalSeek (xlDialogGoalSeek)

-test_xlDialogGridlines (xlDialogGridlines)

-test_xlDialogImportTextFile (xlDialogImportTextFile)

-test_xlDialogInsert (xlDialogInsert)

-test_xlDialogInsertHyperlink (xlDialogInsertHyperlink)

-test_xlDialogInsertNameLabel (xlDialogInsertNameLabel)

-test_xlDialogInsertObject (xlDialogInsertObject)

-test_xlDialogInsertPicture (xlDialogInsertPicture)

-test_xlDialogInsertTitle (xlDialogInsertTitle)

-test_xlDialogLabelProperties (xlDialogLabelProperties)

-test_xlDialogListboxProperties (xlDialogListboxProperties)

-test_xlDialogMacroOptions (xlDialogMacroOptions)

-test_xlDialogMailEditMailer (xlDialogMailEditMailer)

-test_xlDialogMailLogon (xlDialogMailLogon)

-test_xlDialogMailNextLetter (xlDialogMailNextLetter)

-test_xlDialogMainChart (xlDialogMainChart)

-test_xlDialogMainChartType (xlDialogMainChartType)

-test_xlDialogMenuEditor (xlDialogMenuEditor)

-test_xlDialogMove (xlDialogMove)

-test_xlDialogMyPermission (xlDialogMyPermission)

-test_xlDialogNew (xlDialogNew)

-test_xlDialogNewWebQuery (xlDialogNewWebQuery)

-test_xlDialogNote (xlDialogNote)

-test_xlDialogObjectProperties (xlDialogObjectProperties)

-test_xlDialogObjectProtection (xlDialogObjectProtection)

-test_xlDialogOpen (xlDialogOpen)

-test_xlDialogOpenLinks (xlDialogOpenLinks)

-test_xlDialogOpenMail (xlDialogOpenMail)

-test_xlDialogOpenText (xlDialogOpenText)

-test_xlDialogOptionsCalculation (xlDialogOptionsCalculation)

-test_xlDialogOptionsChart (xlDialogOptionsChart)

-test_xlDialogOptionsEdit (xlDialogOptionsEdit)

-test_xlDialogOptionsGeneral (xlDialogOptionsGeneral)

-test_xlDialogOptionsListAdd (xlDialogOptionsListAdd)

-test_xlDialogOptionsME (xlDialogOptionsME)

-test_xlDialogOptionsTransition (xlDialogOptionsTransition)

-test_xlDialogOptionsView (xlDialogOptionsView)

-test_xlDialogOutline (xlDialogOutline)

-test_xlDialogOverlay (xlDialogOverlay)

-test_xlDialogOverlayChartType (xlDialogOverlayChartType)

-test_xlDialogPageSetup (xlDialogPageSetup)

-test_xlDialogParse (xlDialogParse)

-test_xlDialogPasteNames (xlDialogPasteNames)

-test_xlDialogPasteSpecial (xlDialogPasteSpecial)

-test_xlDialogPatterns (xlDialogPatterns)

-test_xlDialogPermission (xlDialogPermission)

-test_xlDialogPhonetic (xlDialogPhonetic)

-test_xlDialogPivotCalculatedField (xlDialogPivotCalculatedField)

-test_xlDialogPivotCalculatedItem (xlDialogPivotCalculatedItem)

-test_xlDialogPivotClientServerSet (xlDialogPivotClientServerSet)

-test_xlDialogPivotFieldGroup (xlDialogPivotFieldGroup)

-test_xlDialogPivotFieldProperties (xlDialogPivotFieldProperties)

-test_xlDialogPivotFieldUngroup (xlDialogPivotFieldUngroup)

-test_xlDialogPivotShowPages (xlDialogPivotShowPages)

-test_xlDialogPivotSolveOrder (xlDialogPivotSolveOrder)

-test_xlDialogPivotTableOptions (xlDialogPivotTableOptions)

-test_xlDialogPivotTableWizard (xlDialogPivotTableWizard)

-test_xlDialogPlacement (xlDialogPlacement)

-test_xlDialogPrint (xlDialogPrint)

-test_xlDialogPrintSetup (xlDialogPrintSetup)

-test_xlDialogPrintPreview (xlDialogPrintPreview)

-test_xlDialogPromote (xlDialogPromote)

-test_xlDialogProperties (xlDialogProperties)

-test_xlDialogPropertyFields (xlDialogPropertyFields)

-test_xlDialogProtectDocument (xlDialogProtectDocument)

-test_xlDialogProtectSharing (xlDialogProtectSharing)

-test_xlDialogPublishAsWebPage (xlDialogPublishAsWebPage)

-test_xlDialogPushbuttonProperties (xlDialogPushbuttonProperties)

-test_xlDialogReplaceFont (xlDialogReplaceFont)

-test_xlDialogRoutingSlip (xlDialogRoutingSlip)

-test_xlDialogRowHeight (xlDialogRowHeight)

-test_xlDialogRun (xlDialogRun)

-test_xlDialogSaveAs (xlDialogSaveAs)

-test_xlDialogSaveCopyAs (xlDialogSaveCopyAs)

-test_xlDialogSaveNewObject (xlDialogSaveNewObject)

-test_xlDialogSaveWorkbook (xlDialogSaveWorkbook)

-test_xlDialogSaveWorkspace (xlDialogSaveWorkspace)

-test_xlDialogScale (xlDialogScale)

-test_xlDialogScenarioAdd (xlDialogScenarioAdd)

-test_xlDialogScenarioCells (xlDialogScenarioCells)

-test_xlDialogScenarioEdit (xlDialogScenarioEdit)

-test_xlDialogScenarioMerge (xlDialogScenarioMerge)

-test_xlDialogScenarioSummary (xlDialogScenarioSummary)

-test_xlDialogScrollbarProperties (xlDialogScrollbarProperties)

-test_xlDialogSearch (xlDialogSearch)

-test_xlDialogSelectSpecial (xlDialogSelectSpecial)

-test_xlDialogSendMail (xlDialogSendMail)

-test_xlDialogSeriesAxes (xlDialogSeriesAxes)

-test_xlDialogSeriesOptions (xlDialogSeriesOptions)

-test_xlDialogSeriesOrder (xlDialogSeriesOrder)

-test_xlDialogSeriesShape (xlDialogSeriesShape)

-test_xlDialogSeriesX (xlDialogSeriesX)

-test_xlDialogSeriesY (xlDialogSeriesY)

-test_xlDialogSetBackgroundPicture (xlDialogSetBackgroundPicture)

-test_xlDialogSetPrintTitles (xlDialogSetPrintTitles)

-test_xlDialogSetUpdateStatus (xlDialogSetUpdateStatus)

-test_xlDialogShowDetail (xlDialogShowDetail)

-test_xlDialogShowToolbar (xlDialogShowToolbar)

-test_xlDialogSize (xlDialogSize)

-test_xlDialogSort (xlDialogSort)

-test_xlDialogSortSpecial (xlDialogSortSpecial)

-test_xlDialogSplit (xlDialogSplit)

-test_xlDialogStandardFont (xlDialogStandardFont)

-test_xlDialogStandardWidth (xlDialogStandardWidth)

-test_xlDialogStyle (xlDialogStyle)

-test_xlDialogSubscribeTo (xlDialogSubscribeTo)

-test_xlDialogSubtotalCreate (xlDialogSubtotalCreate)

-test_xlDialogSummaryInfo (xlDialogSummaryInfo)

-test_xlDialogTable (xlDialogTable)

-test_xlDialogTabOrder (xlDialogTabOrder)

-test_xlDialogTextToColumns (xlDialogTextToColumns)

-test_xlDialogUnhide (xlDialogUnhide)

-test_xlDialogUpdateLink (xlDialogUpdateLink)

-test_xlDialogVbaInsertFile (xlDialogVbaInsertFile)

-test_xlDialogVbaMakeAddin (xlDialogVbaMakeAddin)

-test_xlDialogVbaProcedureDefinition (xlDialogVbaProcedureDefinition)

-test_xlDialogView3d (xlDialogView3d)

-test_xlDialogWebOptionsBrowsers (xlDialogWebOptionsBrowsers)

-test_xlDialogWebOptionsEncoding (xlDialogWebOptionsEncoding)

-test_xlDialogWebOptionsFiles (xlDialogWebOptionsFiles)

-test_xlDialogWebOptionsFonts (xlDialogWebOptionsFonts)

-test_xlDialogWebOptionsGeneral (xlDialogWebOptionsGeneral)

-test_xlDialogWebOptionsPictures (xlDialogWebOptionsPictures)

-test_xlDialogWindowMove (xlDialogWindowMove)

-test_xlDialogWindowSize (xlDialogWindowSize)

-test_xlDialogWorkbookAdd (xlDialogWorkbookAdd)

-test_xlDialogWorkbookCopy (xlDialogWorkbookCopy)

-test_xlDialogWorkbookInsert (xlDialogWorkbookInsert)

-test_xlDialogWorkbookMove (xlDialogWorkbookMove)

-test_xlDialogWorkbookName (xlDialogWorkbookName)

-test_xlDialogWorkbookNew (xlDialogWorkbookNew)

-test_xlDialogWorkbookOptions (xlDialogWorkbookOptions)

-test_xlDialogWorkbookProtect (xlDialogWorkbookProtect)

-test_xlDialogWorkbookTabSplit (xlDialogWorkbookTabSplit)

-test_xlDialogWorkbookUnhide (xlDialogWorkbookUnhide)

-test_xlDialogWorkgroup (xlDialogWorkgroup)

-test_xlDialogWorkspace (xlDialogWorkspace)

-test_xlDialogZoom (xlDialogZoom)

-Range("A1").Value = "constant name"

-Range("B1").Value = "OOo result"

-Range("C1").Value = "Excel result"

-Range("D1").Value = "Correct?"

-End Sub

-

-Function test_xlDialogActivate(ByRef num)

-Range("A2").Clear

-Range("B2").Clear

-Range("C2").Clear

-Range("D2").Clear

-Range("A2").Value = "xlDialogActivate"

-Range("B2").Value = 103

-Range("C2").Value = num

-B2 = Range("B2").Value

-C2 = Range("C2").Value

-If B2 = C2 Then

-Range("D2").Value = "OK"

-Else

-Range("D2").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogActiveCellFont(ByRef num)

-Range("A3").Clear

-Range("B3").Clear

-Range("C3").Clear

-Range("D3").Clear

-Range("A3").Value = "xlDialogActiveCellFont"

-Range("B3").Value = 476

-Range("C3").Value = num

-B3 = Range("B3").Value

-C3 = Range("C3").Value

-If B3 = C3 Then

-Range("D3").Value = "OK"

-Else

-Range("D3").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogAddChartAutoformat(ByRef num)

-Range("A4").Clear

-Range("B4").Clear

-Range("C4").Clear

-Range("D4").Clear

-Range("A4").Value = "xlDialogAddChartAutoformat"

-Range("B4").Value = 390

-Range("C4").Value = num

-B4 = Range("B4").Value

-C4 = Range("C4").Value

-If B4 = C4 Then

-Range("D4").Value = "OK"

-Else

-Range("D4").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogAddinManager(ByRef num)

-Range("A5").Clear

-Range("B5").Clear

-Range("C5").Clear

-Range("D5").Clear

-Range("A5").Value = "xlDialogAddinManager"

-Range("B5").Value = 321

-Range("C5").Value = num

-B5 = Range("B5").Value

-C5 = Range("C5").Value

-If B5 = C5 Then

-Range("D5").Value = "OK"

-Else

-Range("D5").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogAlignment(ByRef num)

-Range("A6").Clear

-Range("B6").Clear

-Range("C6").Clear

-Range("D6").Clear

-Range("A6").Value = "xlDialogAlignment"

-Range("B6").Value = 43

-Range("C6").Value = num

-B6 = Range("B6").Value

-C6 = Range("C6").Value

-If B6 = C6 Then

-Range("D6").Value = "OK"

-Else

-Range("D6").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogApplyNames(ByRef num)

-Range("A7").Clear

-Range("B7").Clear

-Range("C7").Clear

-Range("D7").Clear

-Range("A7").Value = "xlDialogApplyNames"

-Range("B7").Value = 133

-Range("C7").Value = num

-B7 = Range("B7").Value

-C7 = Range("C7").Value

-If B7 = C7 Then

-Range("D7").Value = "OK"

-Else

-Range("D7").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogApplyStyle(ByRef num)

-Range("A8").Clear

-Range("B8").Clear

-Range("C8").Clear

-Range("D8").Clear

-Range("A8").Value = "xlDialogApplyStyle"

-Range("B8").Value = 212

-Range("C8").Value = num

-B8 = Range("B8").Value

-C8 = Range("C8").Value

-If B8 = C8 Then

-Range("D8").Value = "OK"

-Else

-Range("D8").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogAppMove(ByRef num)

-Range("A9").Clear

-Range("B9").Clear

-Range("C9").Clear

-Range("D9").Clear

-Range("A9").Value = "xlDialogAppMove"

-Range("B9").Value = 170

-Range("C9").Value = num

-B9 = Range("B9").Value

-C9 = Range("C9").Value

-If B9 = C9 Then

-Range("D9").Value = "OK"

-Else

-Range("D9").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogAppSize(ByRef num)

-Range("A10").Clear

-Range("B10").Clear

-Range("C10").Clear

-Range("D10").Clear

-Range("A10").Value = "xlDialogAppSize"

-Range("B10").Value = 171

-Range("C10").Value = num

-B10 = Range("B10").Value

-C10 = Range("C10").Value

-If B10 = C10 Then

-Range("D10").Value = "OK"

-Else

-Range("D10").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogArrangeAll(ByRef num)

-Range("A11").Clear

-Range("B11").Clear

-Range("C11").Clear

-Range("D11").Clear

-Range("A11").Value = "xlDialogArrangeAll"

-Range("B11").Value = 12

-Range("C11").Value = num

-B11 = Range("B11").Value

-C11 = Range("C11").Value

-If B11 = C11 Then

-Range("D11").Value = "OK"

-Else

-Range("D11").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogAssignToObject(ByRef num)

-Range("A12").Clear

-Range("B12").Clear

-Range("C12").Clear

-Range("D12").Clear

-Range("A12").Value = "xlDialogAssignToObject"

-Range("B12").Value = 213

-Range("C12").Value = num

-B12 = Range("B12").Value

-C12 = Range("C12").Value

-If B12 = C12 Then

-Range("D12").Value = "OK"

-Else

-Range("D12").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogAssignToTool(ByRef num)

-Range("A13").Clear

-Range("B13").Clear

-Range("C13").Clear

-Range("D13").Clear

-Range("A13").Value = "xlDialogAssignToTool"

-Range("B13").Value = 293

-Range("C13").Value = num

-B13 = Range("B13").Value

-C13 = Range("C13").Value

-If B13 = C13 Then

-Range("D13").Value = "OK"

-Else

-Range("D13").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogAttachText(ByRef num)

-Range("A14").Clear

-Range("B14").Clear

-Range("C14").Clear

-Range("D14").Clear

-Range("A14").Value = "xlDialogAttachText"

-Range("B14").Value = 80

-Range("C14").Value = num

-B14 = Range("B14").Value

-C14 = Range("C14").Value

-If B14 = C14 Then

-Range("D14").Value = "OK"

-Else

-Range("D14").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogAttachToolbars(ByRef num)

-Range("A15").Clear

-Range("B15").Clear

-Range("C15").Clear

-Range("D15").Clear

-Range("A15").Value = "xlDialogAttachToolbars"

-Range("B15").Value = 323

-Range("C15").Value = num

-B15 = Range("B15").Value

-C15 = Range("C15").Value

-If B15 = C15 Then

-Range("D15").Value = "OK"

-Else

-Range("D15").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogAutoCorrect(ByRef num)

-Range("A16").Clear

-Range("B16").Clear

-Range("C16").Clear

-Range("D16").Clear

-Range("A16").Value = "xlDialogAutoCorrect"

-Range("B16").Value = 485

-Range("C16").Value = num

-B16 = Range("B16").Value

-C16 = Range("C16").Value

-If B16 = C16 Then

-Range("D16").Value = "OK"

-Else

-Range("D16").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogAxes(ByRef num)

-Range("A17").Clear

-Range("B17").Clear

-Range("C17").Clear

-Range("D17").Clear

-Range("A17").Value = "xlDialogAxes"

-Range("B17").Value = 78

-Range("C17").Value = num

-B17 = Range("B17").Value

-C17 = Range("C17").Value

-If B17 = C17 Then

-Range("D17").Value = "OK"

-Else

-Range("D17").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogBorder(ByRef num)

-Range("A18").Clear

-Range("B18").Clear

-Range("C18").Clear

-Range("D18").Clear

-Range("A18").Value = "xlDialogBorder"

-Range("B18").Value = 45

-Range("C18").Value = num

-B18 = Range("B18").Value

-C18 = Range("C18").Value

-If B18 = C18 Then

-Range("D18").Value = "OK"

-Else

-Range("D18").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogCalculation(ByRef num)

-Range("A19").Clear

-Range("B19").Clear

-Range("C19").Clear

-Range("D19").Clear

-Range("A19").Value = "xlDialogCalculation"

-Range("B19").Value = 32

-Range("C19").Value = num

-B19 = Range("B19").Value

-C19 = Range("C19").Value

-If B19 = C19 Then

-Range("D19").Value = "OK"

-Else

-Range("D19").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogCellProtection(ByRef num)

-Range("A20").Clear

-Range("B20").Clear

-Range("C20").Clear

-Range("D20").Clear

-Range("A20").Value = "xlDialogCellProtection"

-Range("B20").Value = 46

-Range("C20").Value = num

-B20 = Range("B20").Value

-C20 = Range("C20").Value

-If B20 = C20 Then

-Range("D20").Value = "OK"

-Else

-Range("D20").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogChangeLink(ByRef num)

-Range("A21").Clear

-Range("B21").Clear

-Range("C21").Clear

-Range("D21").Clear

-Range("A21").Value = "xlDialogChangeLink"

-Range("B21").Value = 166

-Range("C21").Value = num

-B21 = Range("B21").Value

-C21 = Range("C21").Value

-If B21 = C21 Then

-Range("D21").Value = "OK"

-Else

-Range("D21").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogChartAddData(ByRef num)

-Range("A22").Clear

-Range("B22").Clear

-Range("C22").Clear

-Range("D22").Clear

-Range("A22").Value = "xlDialogChartAddData"

-Range("B22").Value = 392

-Range("C22").Value = num

-B22 = Range("B22").Value

-C22 = Range("C22").Value

-If B22 = C22 Then

-Range("D22").Value = "OK"

-Else

-Range("D22").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogChartLocation(ByRef num)

-Range("A23").Clear

-Range("B23").Clear

-Range("C23").Clear

-Range("D23").Clear

-Range("A23").Value = "xlDialogChartLocation"

-Range("B23").Value = 527

-Range("C23").Value = num

-B23 = Range("B23").Value

-C23 = Range("C23").Value

-If B23 = C23 Then

-Range("D23").Value = "OK"

-Else

-Range("D23").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogChartOptionDataLabelMultiple(ByRef num)

-Range("A24").Clear

-Range("B24").Clear

-Range("C24").Clear

-Range("D24").Clear

-Range("A24").Value = "xlDialogChartOptionDataLabelMultiple"

-Range("B24").Value = 724

-Range("C24").Value = num

-B24 = Range("B24").Value

-C24 = Range("C24").Value

-If B24 = C24 Then

-Range("D24").Value = "OK"

-Else

-Range("D24").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogChartOptionDataLabels(ByRef num)

-Range("A25").Clear

-Range("B25").Clear

-Range("C25").Clear

-Range("D25").Clear

-Range("A25").Value = "xlDialogChartOptionDataLabels"

-Range("B25").Value = 505

-Range("C25").Value = num

-B25 = Range("B25").Value

-C25 = Range("C25").Value

-If B25 = C25 Then

-Range("D25").Value = "OK"

-Else

-Range("D25").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogChartOptionDataTable(ByRef num)

-Range("A26").Clear

-Range("B26").Clear

-Range("C26").Clear

-Range("D26").Clear

-Range("A26").Value = "xlDialogChartOptionDataTable"

-Range("B26").Value = 506

-Range("C26").Value = num

-B26 = Range("B26").Value

-C26 = Range("C26").Value

-If B26 = C26 Then

-Range("D26").Value = "OK"

-Else

-Range("D26").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogChartSourceData(ByRef num)

-Range("A27").Clear

-Range("B27").Clear

-Range("C27").Clear

-Range("D27").Clear

-Range("A27").Value = "xlDialogChartSourceData"

-Range("B27").Value = 540

-Range("C27").Value = num

-B27 = Range("B27").Value

-C27 = Range("C27").Value

-If B27 = C27 Then

-Range("D27").Value = "OK"

-Else

-Range("D27").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogChartTrend(ByRef num)

-Range("A28").Clear

-Range("B28").Clear

-Range("C28").Clear

-Range("D28").Clear

-Range("A28").Value = "xlDialogChartTrend"

-Range("B28").Value = 350

-Range("C28").Value = num

-B28 = Range("B28").Value

-C28 = Range("C28").Value

-If B28 = C28 Then

-Range("D28").Value = "OK"

-Else

-Range("D28").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogChartType(ByRef num)

-Range("A29").Clear

-Range("B29").Clear

-Range("C29").Clear

-Range("D29").Clear

-Range("A29").Value = "xlDialogChartType"

-Range("B29").Value = 526

-Range("C29").Value = num

-B29 = Range("B29").Value

-C29 = Range("C29").Value

-If B29 = C29 Then

-Range("D29").Value = "OK"

-Else

-Range("D29").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogChartWizard(ByRef num)

-Range("A30").Clear

-Range("B30").Clear

-Range("C30").Clear

-Range("D30").Clear

-Range("A30").Value = "xlDialogChartWizard"

-Range("B30").Value = 288

-Range("C30").Value = num

-B30 = Range("B30").Value

-C30 = Range("C30").Value

-If B30 = C30 Then

-Range("D30").Value = "OK"

-Else

-Range("D30").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogChechboxProperties(ByRef num)

-Range("A31").Clear

-Range("B31").Clear

-Range("C31").Clear

-Range("D31").Clear

-Range("A31").Value = "xlDialogChechboxProperties"

-Range("B31").Value = 435

-Range("C31").Value = num

-B31 = Range("B31").Value

-C31 = Range("C31").Value

-If B31 = C31 Then

-Range("D31").Value = "OK"

-Else

-Range("D31").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogClear(ByRef num)

-Range("A32").Clear

-Range("B32").Clear

-Range("C32").Clear

-Range("D32").Clear

-Range("A32").Value = "xlDialogClear"

-Range("B32").Value = 52

-Range("C32").Value = num

-B32 = Range("B32").Value

-C32 = Range("C32").Value

-If B32 = C32 Then

-Range("D32").Value = "OK"

-Else

-Range("D32").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogColorPalette(ByRef num)

-Range("A33").Clear

-Range("B33").Clear

-Range("C33").Clear

-Range("D33").Clear

-Range("A33").Value = "xlDialogColorPalette"

-Range("B33").Value = 161

-Range("C33").Value = num

-B33 = Range("B33").Value

-C33 = Range("C33").Value

-If B33 = C33 Then

-Range("D33").Value = "OK"

-Else

-Range("D33").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogColumnWidth(ByRef num)

-Range("A34").Clear

-Range("B34").Clear

-Range("C34").Clear

-Range("D34").Clear

-Range("A34").Value = "xlDialogColumnWidth"

-Range("B34").Value = 47

-Range("C34").Value = num

-B34 = Range("B34").Value

-C34 = Range("C34").Value

-If B34 = C34 Then

-Range("D34").Value = "OK"

-Else

-Range("D34").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogCombination(ByRef num)

-Range("A35").Clear

-Range("B35").Clear

-Range("C35").Clear

-Range("D35").Clear

-Range("A35").Value = "xlDialogCombination"

-Range("B35").Value = 73

-Range("C35").Value = num

-B35 = Range("B35").Value

-C35 = Range("C35").Value

-If B35 = C35 Then

-Range("D35").Value = "OK"

-Else

-Range("D35").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogConditionalFormatting(ByRef num)

-Range("A36").Clear

-Range("B36").Clear

-Range("C36").Clear

-Range("D36").Clear

-Range("A36").Value = "xlDialogConditionalFormatting"

-Range("B36").Value = 583

-Range("C36").Value = num

-B36 = Range("B36").Value

-C36 = Range("C36").Value

-If B36 = C36 Then

-Range("D36").Value = "OK"

-Else

-Range("D36").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogConsolidate(ByRef num)

-Range("A37").Clear

-Range("B37").Clear

-Range("C37").Clear

-Range("D37").Clear

-Range("A37").Value = "xlDialogConsolidate"

-Range("B37").Value = 191

-Range("C37").Value = num

-B37 = Range("B37").Value

-C37 = Range("C37").Value

-If B37 = C37 Then

-Range("D37").Value = "OK"

-Else

-Range("D37").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogCopyChart(ByRef num)

-Range("A38").Clear

-Range("B38").Clear

-Range("C38").Clear

-Range("D38").Clear

-Range("A38").Value = "xlDialogCopyChart"

-Range("B38").Value = 147

-Range("C38").Value = num

-B38 = Range("B38").Value

-C38 = Range("C38").Value

-If B38 = C38 Then

-Range("D38").Value = "OK"

-Else

-Range("D38").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogCopyPicture(ByRef num)

-Range("A39").Clear

-Range("B39").Clear

-Range("C39").Clear

-Range("D39").Clear

-Range("A39").Value = "xlDialogCopyPicture"

-Range("B39").Value = 108

-Range("C39").Value = num

-B39 = Range("B39").Value

-C39 = Range("C39").Value

-If B39 = C39 Then

-Range("D39").Value = "OK"

-Else

-Range("D39").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogCreateList(ByRef num)

-Range("A40").Clear

-Range("B40").Clear

-Range("C40").Clear

-Range("D40").Clear

-Range("A40").Value = "xlDialogCreateList"

-Range("B40").Value = 769

-Range("C40").Value = num

-B40 = Range("B40").Value

-C40 = Range("C40").Value

-If B40 = C40 Then

-Range("D40").Value = "OK"

-Else

-Range("D40").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogCreateNames(ByRef num)

-Range("A41").Clear

-Range("B41").Clear

-Range("C41").Clear

-Range("D41").Clear

-Range("A41").Value = "xlDialogCreateNames"

-Range("B41").Value = 62

-Range("C41").Value = num

-B41 = Range("B41").Value

-C41 = Range("C41").Value

-If B41 = C41 Then

-Range("D41").Value = "OK"

-Else

-Range("D41").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogCreatePublisher(ByRef num)

-Range("A42").Clear

-Range("B42").Clear

-Range("C42").Clear

-Range("D42").Clear

-Range("A42").Value = "xlDialogCreatePublisher"

-Range("B42").Value = 217

-Range("C42").Value = num

-B42 = Range("B42").Value

-C42 = Range("C42").Value

-If B42 = C42 Then

-Range("D42").Value = "OK"

-Else

-Range("D42").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogCustomizeToolbar(ByRef num)

-Range("A43").Clear

-Range("B43").Clear

-Range("C43").Clear

-Range("D43").Clear

-Range("A43").Value = "xlDialogCustomizeToolbar"

-Range("B43").Value = 276

-Range("C43").Value = num

-B43 = Range("B43").Value

-C43 = Range("C43").Value

-If B43 = C43 Then

-Range("D43").Value = "OK"

-Else

-Range("D43").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogCustomViews(ByRef num)

-Range("A44").Clear

-Range("B44").Clear

-Range("C44").Clear

-Range("D44").Clear

-Range("A44").Value = "xlDialogCustomViews"

-Range("B44").Value = 493

-Range("C44").Value = num

-B44 = Range("B44").Value

-C44 = Range("C44").Value

-If B44 = C44 Then

-Range("D44").Value = "OK"

-Else

-Range("D44").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogDataDelete(ByRef num)

-Range("A45").Clear

-Range("B45").Clear

-Range("C45").Clear

-Range("D45").Clear

-Range("A45").Value = "xlDialogDataDelete"

-Range("B45").Value = 36

-Range("C45").Value = num

-B45 = Range("B45").Value

-C45 = Range("C45").Value

-If B45 = C45 Then

-Range("D45").Value = "OK"

-Else

-Range("D45").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogDataLabel(ByRef num)

-Range("A46").Clear

-Range("B46").Clear

-Range("C46").Clear

-Range("D46").Clear

-Range("A46").Value = "xlDialogDataLabel"

-Range("B46").Value = 379

-Range("C46").Value = num

-B46 = Range("B46").Value

-C46 = Range("C46").Value

-If B46 = C46 Then

-Range("D46").Value = "OK"

-Else

-Range("D46").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogDataLabelMultiple(ByRef num)

-Range("A47").Clear

-Range("B47").Clear

-Range("C47").Clear

-Range("D47").Clear

-Range("A47").Value = "xlDialogDataLabelMultiple"

-Range("B47").Value = 723

-Range("C47").Value = num

-B47 = Range("B47").Value

-C47 = Range("C47").Value

-If B47 = C47 Then

-Range("D47").Value = "OK"

-Else

-Range("D47").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogDataSeries(ByRef num)

-Range("A48").Clear

-Range("B48").Clear

-Range("C48").Clear

-Range("D48").Clear

-Range("A48").Value = "xlDialogDataSeries"

-Range("B48").Value = 40

-Range("C48").Value = num

-B48 = Range("B48").Value

-C48 = Range("C48").Value

-If B48 = C48 Then

-Range("D48").Value = "OK"

-Else

-Range("D48").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogDataValidation(ByRef num)

-Range("A49").Clear

-Range("B49").Clear

-Range("C49").Clear

-Range("D49").Clear

-Range("A49").Value = "xlDialogDataValidation"

-Range("B49").Value = 525

-Range("C49").Value = num

-B49 = Range("B49").Value

-C49 = Range("C49").Value

-If B49 = C49 Then

-Range("D49").Value = "OK"

-Else

-Range("D49").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogDefineName(ByRef num)

-Range("A50").Clear

-Range("B50").Clear

-Range("C50").Clear

-Range("D50").Clear

-Range("A50").Value = "xlDialogDefineName"

-Range("B50").Value = 61

-Range("C50").Value = num

-B50 = Range("B50").Value

-C50 = Range("C50").Value

-If B50 = C50 Then

-Range("D50").Value = "OK"

-Else

-Range("D50").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogDefineStyle(ByRef num)

-Range("A51").Clear

-Range("B51").Clear

-Range("C51").Clear

-Range("D51").Clear

-Range("A51").Value = "xlDialogDefineStyle"

-Range("B51").Value = 229

-Range("C51").Value = num

-B51 = Range("B51").Value

-C51 = Range("C51").Value

-If B51 = C51 Then

-Range("D51").Value = "OK"

-Else

-Range("D51").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogDeleteFormat(ByRef num)

-Range("A52").Clear

-Range("B52").Clear

-Range("C52").Clear

-Range("D52").Clear

-Range("A52").Value = "xlDialogDeleteFormat"

-Range("B52").Value = 111

-Range("C52").Value = num

-B52 = Range("B52").Value

-C52 = Range("C52").Value

-If B52 = C52 Then

-Range("D52").Value = "OK"

-Else

-Range("D52").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogDeleteName(ByRef num)

-Range("A53").Clear

-Range("B53").Clear

-Range("C53").Clear

-Range("D53").Clear

-Range("A53").Value = "xlDialogDeleteName"

-Range("B53").Value = 110

-Range("C53").Value = num

-B53 = Range("B53").Value

-C53 = Range("C53").Value

-If B53 = C53 Then

-Range("D53").Value = "OK"

-Else

-Range("D53").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogDemote(ByRef num)

-Range("A54").Clear

-Range("B54").Clear

-Range("C54").Clear

-Range("D54").Clear

-Range("A54").Value = "xlDialogDemote"

-Range("B54").Value = 203

-Range("C54").Value = num

-B54 = Range("B54").Value

-C54 = Range("C54").Value

-If B54 = C54 Then

-Range("D54").Value = "OK"

-Else

-Range("D54").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogDisplay(ByRef num)

-Range("A55").Clear

-Range("B55").Clear

-Range("C55").Clear

-Range("D55").Clear

-Range("A55").Value = "xlDialogDisplay"

-Range("B55").Value = 27

-Range("C55").Value = num

-B55 = Range("B55").Value

-C55 = Range("C55").Value

-If B55 = C55 Then

-Range("D55").Value = "OK"

-Else

-Range("D55").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogEditboxProperties(ByRef num)

-Range("A56").Clear

-Range("B56").Clear

-Range("C56").Clear

-Range("D56").Clear

-Range("A56").Value = "xlDialogEditboxProperties"

-Range("B56").Value = 438

-Range("C56").Value = num

-B56 = Range("B56").Value

-C56 = Range("C56").Value

-If B56 = C56 Then

-Range("D56").Value = "OK"

-Else

-Range("D56").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogEditColor(ByRef num)

-Range("A57").Clear

-Range("B57").Clear

-Range("C57").Clear

-Range("D57").Clear

-Range("A57").Value = "xlDialogEditColor"

-Range("B57").Value = 223

-Range("C57").Value = num

-B57 = Range("B57").Value

-C57 = Range("C57").Value

-If B57 = C57 Then

-Range("D57").Value = "OK"

-Else

-Range("D57").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogEditDelete(ByRef num)

-Range("A58").Clear

-Range("B58").Clear

-Range("C58").Clear

-Range("D58").Clear

-Range("A58").Value = "xlDialogEditDelete"

-Range("B58").Value = 54

-Range("C58").Value = num

-B58 = Range("B58").Value

-C58 = Range("C58").Value

-If B58 = C58 Then

-Range("D58").Value = "OK"

-Else

-Range("D58").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogEditionOptions(ByRef num)

-Range("A59").Clear

-Range("B59").Clear

-Range("C59").Clear

-Range("D59").Clear

-Range("A59").Value = "xlDialogEditionOptions"

-Range("B59").Value = 251

-Range("C59").Value = num

-B59 = Range("B59").Value

-C59 = Range("C59").Value

-If B59 = C59 Then

-Range("D59").Value = "OK"

-Else

-Range("D59").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogEditSeries(ByRef num)

-Range("A60").Clear

-Range("B60").Clear

-Range("C60").Clear

-Range("D60").Clear

-Range("A60").Value = "xlDialogEditSeries"

-Range("B60").Value = 228

-Range("C60").Value = num

-B60 = Range("B60").Value

-C60 = Range("C60").Value

-If B60 = C60 Then

-Range("D60").Value = "OK"

-Else

-Range("D60").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogErrorbarX(ByRef num)

-Range("A61").Clear

-Range("B61").Clear

-Range("C61").Clear

-Range("D61").Clear

-Range("A61").Value = "xlDialogErrorbarX"

-Range("B61").Value = 463

-Range("C61").Value = num

-B61 = Range("B61").Value

-C61 = Range("C61").Value

-If B61 = C61 Then

-Range("D61").Value = "OK"

-Else

-Range("D61").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogErrorbarY(ByRef num)

-Range("A62").Clear

-Range("B62").Clear

-Range("C62").Clear

-Range("D62").Clear

-Range("A62").Value = "xlDialogErrorbarY"

-Range("B62").Value = 464

-Range("C62").Value = num

-B62 = Range("B62").Value

-C62 = Range("C62").Value

-If B62 = C62 Then

-Range("D62").Value = "OK"

-Else

-Range("D62").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogErrorChecking(ByRef num)

-Range("A63").Clear

-Range("B63").Clear

-Range("C63").Clear

-Range("D63").Clear

-Range("A63").Value = "xlDialogErrorChecking"

-Range("B63").Value = 732

-Range("C63").Value = num

-B63 = Range("B63").Value

-C63 = Range("C63").Value

-If B63 = C63 Then

-Range("D63").Value = "OK"

-Else

-Range("D63").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogEvaluateFormula(ByRef num)

-Range("A64").Clear

-Range("B64").Clear

-Range("C64").Clear

-Range("D64").Clear

-Range("A64").Value = "xlDialogEvaluateFormula"

-Range("B64").Value = 709

-Range("C64").Value = num

-B64 = Range("B64").Value

-C64 = Range("C64").Value

-If B64 = C64 Then

-Range("D64").Value = "OK"

-Else

-Range("D64").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogExternalDataProperties(ByRef num)

-Range("A65").Clear

-Range("B65").Clear

-Range("C65").Clear

-Range("D65").Clear

-Range("A65").Value = "xlDialogExternalDataProperties"

-Range("B65").Value = 530

-Range("C65").Value = num

-B65 = Range("B65").Value

-C65 = Range("C65").Value

-If B65 = C65 Then

-Range("D65").Value = "OK"

-Else

-Range("D65").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogExtract(ByRef num)

-Range("A66").Clear

-Range("B66").Clear

-Range("C66").Clear

-Range("D66").Clear

-Range("A66").Value = "xlDialogExtract"

-Range("B66").Value = 35

-Range("C66").Value = num

-B66 = Range("B66").Value

-C66 = Range("C66").Value

-If B66 = C66 Then

-Range("D66").Value = "OK"

-Else

-Range("D66").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFileDelete(ByRef num)

-Range("A67").Clear

-Range("B67").Clear

-Range("C67").Clear

-Range("D67").Clear

-Range("A67").Value = "xlDialogFileDelete"

-Range("B67").Value = 6

-Range("C67").Value = num

-B67 = Range("B67").Value

-C67 = Range("C67").Value

-If B67 = C67 Then

-Range("D67").Value = "OK"

-Else

-Range("D67").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFileSharing(ByRef num)

-Range("A68").Clear

-Range("B68").Clear

-Range("C68").Clear

-Range("D68").Clear

-Range("A68").Value = "xlDialogFileSharing"

-Range("B68").Value = 481

-Range("C68").Value = num

-B68 = Range("B68").Value

-C68 = Range("C68").Value

-If B68 = C68 Then

-Range("D68").Value = "OK"

-Else

-Range("D68").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFillGroup(ByRef num)

-Range("A69").Clear

-Range("B69").Clear

-Range("C69").Clear

-Range("D69").Clear

-Range("A69").Value = "xlDialogFillGroup"

-Range("B69").Value = 200

-Range("C69").Value = num

-B69 = Range("B69").Value

-C69 = Range("C69").Value

-If B69 = C69 Then

-Range("D69").Value = "OK"

-Else

-Range("D69").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFillWorkGroup(ByRef num)

-Range("A70").Clear

-Range("B70").Clear

-Range("C70").Clear

-Range("D70").Clear

-Range("A70").Value = "xlDialogFillWorkGroup"

-Range("B70").Value = 301

-Range("C70").Value = num

-B70 = Range("B70").Value

-C70 = Range("C70").Value

-If B70 = C70 Then

-Range("D70").Value = "OK"

-Else

-Range("D70").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFilter(ByRef num)

-Range("A71").Clear

-Range("B71").Clear

-Range("C71").Clear

-Range("D71").Clear

-Range("A71").Value = "xlDialogFilter"

-Range("B71").Value = 447

-Range("C71").Value = num

-B71 = Range("B71").Value

-C71 = Range("C71").Value

-If B71 = C71 Then

-Range("D71").Value = "OK"

-Else

-Range("D71").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFilterAdvanced(ByRef num)

-Range("A72").Clear

-Range("B72").Clear

-Range("C72").Clear

-Range("D72").Clear

-Range("A72").Value = "xlDialogFilterAdvanced"

-Range("B72").Value = 370

-Range("C72").Value = num

-B72 = Range("B72").Value

-C72 = Range("C72").Value

-If B72 = C72 Then

-Range("D72").Value = "OK"

-Else

-Range("D72").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFindFile(ByRef num)

-Range("A73").Clear

-Range("B73").Clear

-Range("C73").Clear

-Range("D73").Clear

-Range("A73").Value = "xlDialogFindFile"

-Range("B73").Value = 475

-Range("C73").Value = num

-B73 = Range("B73").Value

-C73 = Range("C73").Value

-If B73 = C73 Then

-Range("D73").Value = "OK"

-Else

-Range("D73").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFont(ByRef num)

-Range("A74").Clear

-Range("B74").Clear

-Range("C74").Clear

-Range("D74").Clear

-Range("A74").Value = "xlDialogFont"

-Range("B74").Value = 26

-Range("C74").Value = num

-B74 = Range("B74").Value

-C74 = Range("C74").Value

-If B74 = C74 Then

-Range("D74").Value = "OK"

-Else

-Range("D74").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFontProperties(ByRef num)

-Range("A75").Clear

-Range("B75").Clear

-Range("C75").Clear

-Range("D75").Clear

-Range("A75").Value = "xlDialogFontProperties"

-Range("B75").Value = 381

-Range("C75").Value = num

-B75 = Range("B75").Value

-C75 = Range("C75").Value

-If B75 = C75 Then

-Range("D75").Value = "OK"

-Else

-Range("D75").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFormatAuto(ByRef num)

-Range("A76").Clear

-Range("B76").Clear

-Range("C76").Clear

-Range("D76").Clear

-Range("A76").Value = "xlDialogFormatAuto"

-Range("B76").Value = 269

-Range("C76").Value = num

-B76 = Range("B76").Value

-C76 = Range("C76").Value

-If B76 = C76 Then

-Range("D76").Value = "OK"

-Else

-Range("D76").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFormatChart(ByRef num)

-Range("A77").Clear

-Range("B77").Clear

-Range("C77").Clear

-Range("D77").Clear

-Range("A77").Value = "xlDialogFormatChart"

-Range("B77").Value = 465

-Range("C77").Value = num

-B77 = Range("B77").Value

-C77 = Range("C77").Value

-If B77 = C77 Then

-Range("D77").Value = "OK"

-Else

-Range("D77").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFormatCharttype(ByRef num)

-Range("A78").Clear

-Range("B78").Clear

-Range("C78").Clear

-Range("D78").Clear

-Range("A78").Value = "xlDialogFormatCharttype"

-Range("B78").Value = 423

-Range("C78").Value = num

-B78 = Range("B78").Value

-C78 = Range("C78").Value

-If B78 = C78 Then

-Range("D78").Value = "OK"

-Else

-Range("D78").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFormatFont(ByRef num)

-Range("A79").Clear

-Range("B79").Clear

-Range("C79").Clear

-Range("D79").Clear

-Range("A79").Value = "xlDialogFormatFont"

-Range("B79").Value = 150

-Range("C79").Value = num

-B79 = Range("B79").Value

-C79 = Range("C79").Value

-If B79 = C79 Then

-Range("D79").Value = "OK"

-Else

-Range("D79").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFormatLegend(ByRef num)

-Range("A80").Clear

-Range("B80").Clear

-Range("C80").Clear

-Range("D80").Clear

-Range("A80").Value = "xlDialogFormatLegend"

-Range("B80").Value = 88

-Range("C80").Value = num

-B80 = Range("B80").Value

-C80 = Range("C80").Value

-If B80 = C80 Then

-Range("D80").Value = "OK"

-Else

-Range("D80").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFormatMain(ByRef num)

-Range("A81").Clear

-Range("B81").Clear

-Range("C81").Clear

-Range("D81").Clear

-Range("A81").Value = "xlDialogFormatMain"

-Range("B81").Value = 225

-Range("C81").Value = num

-B81 = Range("B81").Value

-C81 = Range("C81").Value

-If B81 = C81 Then

-Range("D81").Value = "OK"

-Else

-Range("D81").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFormatMove(ByRef num)

-Range("A82").Clear

-Range("B82").Clear

-Range("C82").Clear

-Range("D82").Clear

-Range("A82").Value = "xlDialogFormatMove"

-Range("B82").Value = 128

-Range("C82").Value = num

-B82 = Range("B82").Value

-C82 = Range("C82").Value

-If B82 = C82 Then

-Range("D82").Value = "OK"

-Else

-Range("D82").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFormatNumber(ByRef num)

-Range("A83").Clear

-Range("B83").Clear

-Range("C83").Clear

-Range("D83").Clear

-Range("A83").Value = "xlDialogFormatNumber"

-Range("B83").Value = 42

-Range("C83").Value = num

-B83 = Range("B83").Value

-C83 = Range("C83").Value

-If B83 = C83 Then

-Range("D83").Value = "OK"

-Else

-Range("D83").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFormatOverlay(ByRef num)

-Range("A84").Clear

-Range("B84").Clear

-Range("C84").Clear

-Range("D84").Clear

-Range("A84").Value = "xlDialogFormatOverlay"

-Range("B84").Value = 226

-Range("C84").Value = num

-B84 = Range("B84").Value

-C84 = Range("C84").Value

-If B84 = C84 Then

-Range("D84").Value = "OK"

-Else

-Range("D84").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFormatSize(ByRef num)

-Range("A85").Clear

-Range("B85").Clear

-Range("C85").Clear

-Range("D85").Clear

-Range("A85").Value = "xlDialogFormatSize"

-Range("B85").Value = 129

-Range("C85").Value = num

-B85 = Range("B85").Value

-C85 = Range("C85").Value

-If B85 = C85 Then

-Range("D85").Value = "OK"

-Else

-Range("D85").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFormatText(ByRef num)

-Range("A86").Clear

-Range("B86").Clear

-Range("C86").Clear

-Range("D86").Clear

-Range("A86").Value = "xlDialogFormatText"

-Range("B86").Value = 89

-Range("C86").Value = num

-B86 = Range("B86").Value

-C86 = Range("C86").Value

-If B86 = C86 Then

-Range("D86").Value = "OK"

-Else

-Range("D86").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFormulaFind(ByRef num)

-Range("A87").Clear

-Range("B87").Clear

-Range("C87").Clear

-Range("D87").Clear

-Range("A87").Value = "xlDialogFormulaFind"

-Range("B87").Value = 64

-Range("C87").Value = num

-B87 = Range("B87").Value

-C87 = Range("C87").Value

-If B87 = C87 Then

-Range("D87").Value = "OK"

-Else

-Range("D87").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFormulaGoto(ByRef num)

-Range("A88").Clear

-Range("B88").Clear

-Range("C88").Clear

-Range("D88").Clear

-Range("A88").Value = "xlDialogFormulaGoto"

-Range("B88").Value = 63

-Range("C88").Value = num

-B88 = Range("B88").Value

-C88 = Range("C88").Value

-If B88 = C88 Then

-Range("D88").Value = "OK"

-Else

-Range("D88").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFormulaReplace(ByRef num)

-Range("A89").Clear

-Range("B89").Clear

-Range("C89").Clear

-Range("D89").Clear

-Range("A89").Value = "xlDialogFormulaReplace"

-Range("B89").Value = 130

-Range("C89").Value = num

-B89 = Range("B89").Value

-C89 = Range("C89").Value

-If B89 = C89 Then

-Range("D89").Value = "OK"

-Else

-Range("D89").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFunctionWizard(ByRef num)

-Range("A90").Clear

-Range("B90").Clear

-Range("C90").Clear

-Range("D90").Clear

-Range("A90").Value = "xlDialogFunctionWizard"

-Range("B90").Value = 450

-Range("C90").Value = num

-B90 = Range("B90").Value

-C90 = Range("C90").Value

-If B90 = C90 Then

-Range("D90").Value = "OK"

-Else

-Range("D90").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGallery3dArea(ByRef num)

-Range("A91").Clear

-Range("B91").Clear

-Range("C91").Clear

-Range("D91").Clear

-Range("A91").Value = "xlDialogGallery3dArea"

-Range("B91").Value = 193

-Range("C91").Value = num

-B91 = Range("B91").Value

-C91 = Range("C91").Value

-If B91 = C91 Then

-Range("D91").Value = "OK"

-Else

-Range("D91").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGallery3dBar(ByRef num)

-Range("A92").Clear

-Range("B92").Clear

-Range("C92").Clear

-Range("D92").Clear

-Range("A92").Value = "xlDialogGallery3dBar"

-Range("B92").Value = 272

-Range("C92").Value = num

-B92 = Range("B92").Value

-C92 = Range("C92").Value

-If B92 = C92 Then

-Range("D92").Value = "OK"

-Else

-Range("D92").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGallery3dColumn(ByRef num)

-Range("A93").Clear

-Range("B93").Clear

-Range("C93").Clear

-Range("D93").Clear

-Range("A93").Value = "xlDialogGallery3dColumn"

-Range("B93").Value = 194

-Range("C93").Value = num

-B93 = Range("B93").Value

-C93 = Range("C93").Value

-If B93 = C93 Then

-Range("D93").Value = "OK"

-Else

-Range("D93").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGallery3dLine(ByRef num)

-Range("A94").Clear

-Range("B94").Clear

-Range("C94").Clear

-Range("D94").Clear

-Range("A94").Value = "xlDialogGallery3dLine"

-Range("B94").Value = 195

-Range("C94").Value = num

-B94 = Range("B94").Value

-C94 = Range("C94").Value

-If B94 = C94 Then

-Range("D94").Value = "OK"

-Else

-Range("D94").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGallery3dPie(ByRef num)

-Range("A95").Clear

-Range("B95").Clear

-Range("C95").Clear

-Range("D95").Clear

-Range("A95").Value = "xlDialogGallery3dPie"

-Range("B95").Value = 196

-Range("C95").Value = num

-B95 = Range("B95").Value

-C95 = Range("C95").Value

-If B95 = C95 Then

-Range("D95").Value = "OK"

-Else

-Range("D95").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGallery3dSurface(ByRef num)

-Range("A96").Clear

-Range("B96").Clear

-Range("C96").Clear

-Range("D96").Clear

-Range("A96").Value = "xlDialogGallery3dSurface"

-Range("B96").Value = 273

-Range("C96").Value = num

-B96 = Range("B96").Value

-C96 = Range("C96").Value

-If B96 = C96 Then

-Range("D96").Value = "OK"

-Else

-Range("D96").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGalleryArea(ByRef num)

-Range("A97").Clear

-Range("B97").Clear

-Range("C97").Clear

-Range("D97").Clear

-Range("A97").Value = "xlDialogGalleryArea"

-Range("B97").Value = 67

-Range("C97").Value = num

-B97 = Range("B97").Value

-C97 = Range("C97").Value

-If B97 = C97 Then

-Range("D97").Value = "OK"

-Else

-Range("D97").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGalleryBar(ByRef num)

-Range("A98").Clear

-Range("B98").Clear

-Range("C98").Clear

-Range("D98").Clear

-Range("A98").Value = "xlDialogGalleryBar"

-Range("B98").Value = 68

-Range("C98").Value = num

-B98 = Range("B98").Value

-C98 = Range("C98").Value

-If B98 = C98 Then

-Range("D98").Value = "OK"

-Else

-Range("D98").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGalleryColumn(ByRef num)

-Range("A99").Clear

-Range("B99").Clear

-Range("C99").Clear

-Range("D99").Clear

-Range("A99").Value = "xlDialogGalleryColumn"

-Range("B99").Value = 69

-Range("C99").Value = num

-B99 = Range("B99").Value

-C99 = Range("C99").Value

-If B99 = C99 Then

-Range("D99").Value = "OK"

-Else

-Range("D99").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGalleryCustom(ByRef num)

-Range("A100").Clear

-Range("B100").Clear

-Range("C100").Clear

-Range("D100").Clear

-Range("A100").Value = "xlDialogGalleryCustom"

-Range("B100").Value = 388

-Range("C100").Value = num

-B100 = Range("B100").Value

-C100 = Range("C100").Value

-If B100 = C100 Then

-Range("D100").Value = "OK"

-Else

-Range("D100").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGalleryDoughnut(ByRef num)

-Range("A101").Clear

-Range("B101").Clear

-Range("C101").Clear

-Range("D101").Clear

-Range("A101").Value = "xlDialogGalleryDoughnut"

-Range("B101").Value = 344

-Range("C101").Value = num

-B101 = Range("B101").Value

-C101 = Range("C101").Value

-If B101 = C101 Then

-Range("D101").Value = "OK"

-Else

-Range("D101").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGalleryLine(ByRef num)

-Range("A102").Clear

-Range("B102").Clear

-Range("C102").Clear

-Range("D102").Clear

-Range("A102").Value = "xlDialogGalleryLine"

-Range("B102").Value = 70

-Range("C102").Value = num

-B102 = Range("B102").Value

-C102 = Range("C102").Value

-If B102 = C102 Then

-Range("D102").Value = "OK"

-Else

-Range("D102").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGalleryPie(ByRef num)

-Range("A103").Clear

-Range("B103").Clear

-Range("C103").Clear

-Range("D103").Clear

-Range("A103").Value = "xlDialogGalleryPie"

-Range("B103").Value = 71

-Range("C103").Value = num

-B103 = Range("B103").Value

-C103 = Range("C103").Value

-If B103 = C103 Then

-Range("D103").Value = "OK"

-Else

-Range("D103").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGalleryRader(ByRef num)

-Range("A104").Clear

-Range("B104").Clear

-Range("C104").Clear

-Range("D104").Clear

-Range("A104").Value = "xlDialogGalleryRader"

-Range("B104").Value = 249

-Range("C104").Value = num

-B104 = Range("B104").Value

-C104 = Range("C104").Value

-If B104 = C104 Then

-Range("D104").Value = "OK"

-Else

-Range("D104").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGalleryScatter(ByRef num)

-Range("A105").Clear

-Range("B105").Clear

-Range("C105").Clear

-Range("D105").Clear

-Range("A105").Value = "xlDialogGalleryScatter"

-Range("B105").Value = 72

-Range("C105").Value = num

-B105 = Range("B105").Value

-C105 = Range("C105").Value

-If B105 = C105 Then

-Range("D105").Value = "OK"

-Else

-Range("D105").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGoalSeek(ByRef num)

-Range("A106").Clear

-Range("B106").Clear

-Range("C106").Clear

-Range("D106").Clear

-Range("A106").Value = "xlDialogGoalSeek"

-Range("B106").Value = 198

-Range("C106").Value = num

-B106 = Range("B106").Value

-C106 = Range("C106").Value

-If B106 = C106 Then

-Range("D106").Value = "OK"

-Else

-Range("D106").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGridlines(ByRef num)

-Range("A107").Clear

-Range("B107").Clear

-Range("C107").Clear

-Range("D107").Clear

-Range("A107").Value = "xlDialogGridlines"

-Range("B107").Value = 76

-Range("C107").Value = num

-B107 = Range("B107").Value

-C107 = Range("C107").Value

-If B107 = C107 Then

-Range("D107").Value = "OK"

-Else

-Range("D107").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogImportTextFile(ByRef num)

-Range("A108").Clear

-Range("B108").Clear

-Range("C108").Clear

-Range("D108").Clear

-Range("A108").Value = "xlDialogImportTextFile"

-Range("B108").Value = 666

-Range("C108").Value = num

-B108 = Range("B108").Value

-C108 = Range("C108").Value

-If B108 = C108 Then

-Range("D108").Value = "OK"

-Else

-Range("D108").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogInsert(ByRef num)

-Range("A109").Clear

-Range("B109").Clear

-Range("C109").Clear

-Range("D109").Clear

-Range("A109").Value = "xlDialogInsert"

-Range("B109").Value = 55

-Range("C109").Value = num

-B109 = Range("B109").Value

-C109 = Range("C109").Value

-If B109 = C109 Then

-Range("D109").Value = "OK"

-Else

-Range("D109").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogInsertHyperlink(ByRef num)

-Range("A110").Clear

-Range("B110").Clear

-Range("C110").Clear

-Range("D110").Clear

-Range("A110").Value = "xlDialogInsertHyperlink"

-Range("B110").Value = 596

-Range("C110").Value = num

-B110 = Range("B110").Value

-C110 = Range("C110").Value

-If B110 = C110 Then

-Range("D110").Value = "OK"

-Else

-Range("D110").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogInsertNameLabel(ByRef num)

-Range("A111").Clear

-Range("B111").Clear

-Range("C111").Clear

-Range("D111").Clear

-Range("A111").Value = "xlDialogInsertNameLabel"

-Range("B111").Value = 496

-Range("C111").Value = num

-B111 = Range("B111").Value

-C111 = Range("C111").Value

-If B111 = C111 Then

-Range("D111").Value = "OK"

-Else

-Range("D111").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogInsertObject(ByRef num)

-Range("A112").Clear

-Range("B112").Clear

-Range("C112").Clear

-Range("D112").Clear

-Range("A112").Value = "xlDialogInsertObject"

-Range("B112").Value = 259

-Range("C112").Value = num

-B112 = Range("B112").Value

-C112 = Range("C112").Value

-If B112 = C112 Then

-Range("D112").Value = "OK"

-Else

-Range("D112").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogInsertPicture(ByRef num)

-Range("A113").Clear

-Range("B113").Clear

-Range("C113").Clear

-Range("D113").Clear

-Range("A113").Value = "xlDialogInsertPicture"

-Range("B113").Value = 342

-Range("C113").Value = num

-B113 = Range("B113").Value

-C113 = Range("C113").Value

-If B113 = C113 Then

-Range("D113").Value = "OK"

-Else

-Range("D113").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogInsertTitle(ByRef num)

-Range("A114").Clear

-Range("B114").Clear

-Range("C114").Clear

-Range("D114").Clear

-Range("A114").Value = "xlDialogInsertTitle"

-Range("B114").Value = 380

-Range("C114").Value = num

-B114 = Range("B114").Value

-C114 = Range("C114").Value

-If B114 = C114 Then

-Range("D114").Value = "OK"

-Else

-Range("D114").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogLabelProperties(ByRef num)

-Range("A115").Clear

-Range("B115").Clear

-Range("C115").Clear

-Range("D115").Clear

-Range("A115").Value = "xlDialogLabelProperties"

-Range("B115").Value = 436

-Range("C115").Value = num

-B115 = Range("B115").Value

-C115 = Range("C115").Value

-If B115 = C115 Then

-Range("D115").Value = "OK"

-Else

-Range("D115").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogListboxProperties(ByRef num)

-Range("A116").Clear

-Range("B116").Clear

-Range("C116").Clear

-Range("D116").Clear

-Range("A116").Value = "xlDialogListboxProperties"

-Range("B116").Value = 437

-Range("C116").Value = num

-B116 = Range("B116").Value

-C116 = Range("C116").Value

-If B116 = C116 Then

-Range("D116").Value = "OK"

-Else

-Range("D116").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogMacroOptions(ByRef num)

-Range("A117").Clear

-Range("B117").Clear

-Range("C117").Clear

-Range("D117").Clear

-Range("A117").Value = "xlDialogMacroOptions"

-Range("B117").Value = 382

-Range("C117").Value = num

-B117 = Range("B117").Value

-C117 = Range("C117").Value

-If B117 = C117 Then

-Range("D117").Value = "OK"

-Else

-Range("D117").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogMailEditMailer(ByRef num)

-Range("A118").Clear

-Range("B118").Clear

-Range("C118").Clear

-Range("D118").Clear

-Range("A118").Value = "xlDialogMailEditMailer"

-Range("B118").Value = 470

-Range("C118").Value = num

-B118 = Range("B118").Value

-C118 = Range("C118").Value

-If B118 = C118 Then

-Range("D118").Value = "OK"

-Else

-Range("D118").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogMailLogon(ByRef num)

-Range("A119").Clear

-Range("B119").Clear

-Range("C119").Clear

-Range("D119").Clear

-Range("A119").Value = "xlDialogMailLogon"

-Range("B119").Value = 339

-Range("C119").Value = num

-B119 = Range("B119").Value

-C119 = Range("C119").Value

-If B119 = C119 Then

-Range("D119").Value = "OK"

-Else

-Range("D119").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogMailNextLetter(ByRef num)

-Range("A120").Clear

-Range("B120").Clear

-Range("C120").Clear

-Range("D120").Clear

-Range("A120").Value = "xlDialogMailNextLetter"

-Range("B120").Value = 378

-Range("C120").Value = num

-B120 = Range("B120").Value

-C120 = Range("C120").Value

-If B120 = C120 Then

-Range("D120").Value = "OK"

-Else

-Range("D120").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogMainChart(ByRef num)

-Range("A121").Clear

-Range("B121").Clear

-Range("C121").Clear

-Range("D121").Clear

-Range("A121").Value = "xlDialogMainChart"

-Range("B121").Value = 85

-Range("C121").Value = num

-B121 = Range("B121").Value

-C121 = Range("C121").Value

-If B121 = C121 Then

-Range("D121").Value = "OK"

-Else

-Range("D121").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogMainChartType(ByRef num)

-Range("A122").Clear

-Range("B122").Clear

-Range("C122").Clear

-Range("D122").Clear

-Range("A122").Value = "xlDialogMainChartType"

-Range("B122").Value = 185

-Range("C122").Value = num

-B122 = Range("B122").Value

-C122 = Range("C122").Value

-If B122 = C122 Then

-Range("D122").Value = "OK"

-Else

-Range("D122").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogMenuEditor(ByRef num)

-Range("A123").Clear

-Range("B123").Clear

-Range("C123").Clear

-Range("D123").Clear

-Range("A123").Value = "xlDialogMenuEditor"

-Range("B123").Value = 322

-Range("C123").Value = num

-B123 = Range("B123").Value

-C123 = Range("C123").Value

-If B123 = C123 Then

-Range("D123").Value = "OK"

-Else

-Range("D123").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogMove(ByRef num)

-Range("A124").Clear

-Range("B124").Clear

-Range("C124").Clear

-Range("D124").Clear

-Range("A124").Value = "xlDialogMove"

-Range("B124").Value = 262

-Range("C124").Value = num

-B124 = Range("B124").Value

-C124 = Range("C124").Value

-If B124 = C124 Then

-Range("D124").Value = "OK"

-Else

-Range("D124").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogMyPermission(ByRef num)

-Range("A125").Clear

-Range("B125").Clear

-Range("C125").Clear

-Range("D125").Clear

-Range("A125").Value = "xlDialogMyPermission"

-Range("B125").Value = 834

-Range("C125").Value = num

-B125 = Range("B125").Value

-C125 = Range("C125").Value

-If B125 = C125 Then

-Range("D125").Value = "OK"

-Else

-Range("D125").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogNew(ByRef num)

-Range("A126").Clear

-Range("B126").Clear

-Range("C126").Clear

-Range("D126").Clear

-Range("A126").Value = "xlDialogNew"

-Range("B126").Value = 119

-Range("C126").Value = num

-B126 = Range("B126").Value

-C126 = Range("C126").Value

-If B126 = C126 Then

-Range("D126").Value = "OK"

-Else

-Range("D126").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogNewWebQuery(ByRef num)

-Range("A127").Clear

-Range("B127").Clear

-Range("C127").Clear

-Range("D127").Clear

-Range("A127").Value = "xlDialogNewWebQuery"

-Range("B127").Value = 667

-Range("C127").Value = num

-B127 = Range("B127").Value

-C127 = Range("C127").Value

-If B127 = C127 Then

-Range("D127").Value = "OK"

-Else

-Range("D127").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogNote(ByRef num)

-Range("A128").Clear

-Range("B128").Clear

-Range("C128").Clear

-Range("D128").Clear

-Range("A128").Value = "xlDialogNote"

-Range("B128").Value = 154

-Range("C128").Value = num

-B128 = Range("B128").Value

-C128 = Range("C128").Value

-If B128 = C128 Then

-Range("D128").Value = "OK"

-Else

-Range("D128").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogObjectProperties(ByRef num)

-Range("A129").Clear

-Range("B129").Clear

-Range("C129").Clear

-Range("D129").Clear

-Range("A129").Value = "xlDialogObjectProperties"

-Range("B129").Value = 207

-Range("C129").Value = num

-B129 = Range("B129").Value

-C129 = Range("C129").Value

-If B129 = C129 Then

-Range("D129").Value = "OK"

-Else

-Range("D129").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogObjectProtection(ByRef num)

-Range("A130").Clear

-Range("B130").Clear

-Range("C130").Clear

-Range("D130").Clear

-Range("A130").Value = "xlDialogObjectProtection"

-Range("B130").Value = 214

-Range("C130").Value = num

-B130 = Range("B130").Value

-C130 = Range("C130").Value

-If B130 = C130 Then

-Range("D130").Value = "OK"

-Else

-Range("D130").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOpen(ByRef num)

-Range("A131").Clear

-Range("B131").Clear

-Range("C131").Clear

-Range("D131").Clear

-Range("A131").Value = "xlDialogOpen"

-Range("B131").Value = 1

-Range("C131").Value = num

-B131 = Range("B131").Value

-C131 = Range("C131").Value

-If B131 = C131 Then

-Range("D131").Value = "OK"

-Else

-Range("D131").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOpenLinks(ByRef num)

-Range("A132").Clear

-Range("B132").Clear

-Range("C132").Clear

-Range("D132").Clear

-Range("A132").Value = "xlDialogOpenLinks"

-Range("B132").Value = 2

-Range("C132").Value = num

-B132 = Range("B132").Value

-C132 = Range("C132").Value

-If B132 = C132 Then

-Range("D132").Value = "OK"

-Else

-Range("D132").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOpenMail(ByRef num)

-Range("A133").Clear

-Range("B133").Clear

-Range("C133").Clear

-Range("D133").Clear

-Range("A133").Value = "xlDialogOpenMail"

-Range("B133").Value = 188

-Range("C133").Value = num

-B133 = Range("B133").Value

-C133 = Range("C133").Value

-If B133 = C133 Then

-Range("D133").Value = "OK"

-Else

-Range("D133").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOpenText(ByRef num)

-Range("A134").Clear

-Range("B134").Clear

-Range("C134").Clear

-Range("D134").Clear

-Range("A134").Value = "xlDialogOpenText"

-Range("B134").Value = 441

-Range("C134").Value = num

-B134 = Range("B134").Value

-C134 = Range("C134").Value

-If B134 = C134 Then

-Range("D134").Value = "OK"

-Else

-Range("D134").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOptionsCalculation(ByRef num)

-Range("A135").Clear

-Range("B135").Clear

-Range("C135").Clear

-Range("D135").Clear

-Range("A135").Value = "xlDialogOptionsCalculation"

-Range("B135").Value = 318

-Range("C135").Value = num

-B135 = Range("B135").Value

-C135 = Range("C135").Value

-If B135 = C135 Then

-Range("D135").Value = "OK"

-Else

-Range("D135").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOptionsChart(ByRef num)

-Range("A136").Clear

-Range("B136").Clear

-Range("C136").Clear

-Range("D136").Clear

-Range("A136").Value = "xlDialogOptionsChart"

-Range("B136").Value = 325

-Range("C136").Value = num

-B136 = Range("B136").Value

-C136 = Range("C136").Value

-If B136 = C136 Then

-Range("D136").Value = "OK"

-Else

-Range("D136").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOptionsEdit(ByRef num)

-Range("A137").Clear

-Range("B137").Clear

-Range("C137").Clear

-Range("D137").Clear

-Range("A137").Value = "xlDialogOptionsEdit"

-Range("B137").Value = 319

-Range("C137").Value = num

-B137 = Range("B137").Value

-C137 = Range("C137").Value

-If B137 = C137 Then

-Range("D137").Value = "OK"

-Else

-Range("D137").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOptionsGeneral(ByRef num)

-Range("A138").Clear

-Range("B138").Clear

-Range("C138").Clear

-Range("D138").Clear

-Range("A138").Value = "xlDialogOptionsGeneral"

-Range("B138").Value = 356

-Range("C138").Value = num

-B138 = Range("B138").Value

-C138 = Range("C138").Value

-If B138 = C138 Then

-Range("D138").Value = "OK"

-Else

-Range("D138").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOptionsListAdd(ByRef num)

-Range("A139").Clear

-Range("B139").Clear

-Range("C139").Clear

-Range("D139").Clear

-Range("A139").Value = "xlDialogOptionsListAdd"

-Range("B139").Value = 458

-Range("C139").Value = num

-B139 = Range("B139").Value

-C139 = Range("C139").Value

-If B139 = C139 Then

-Range("D139").Value = "OK"

-Else

-Range("D139").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOptionsME(ByRef num)

-Range("A140").Clear

-Range("B140").Clear

-Range("C140").Clear

-Range("D140").Clear

-Range("A140").Value = "xlDialogOptionsME"

-Range("B140").Value = 647

-Range("C140").Value = num

-B140 = Range("B140").Value

-C140 = Range("C140").Value

-If B140 = C140 Then

-Range("D140").Value = "OK"

-Else

-Range("D140").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOptionsTransition(ByRef num)

-Range("A141").Clear

-Range("B141").Clear

-Range("C141").Clear

-Range("D141").Clear

-Range("A141").Value = "xlDialogOptionsTransition"

-Range("B141").Value = 355

-Range("C141").Value = num

-B141 = Range("B141").Value

-C141 = Range("C141").Value

-If B141 = C141 Then

-Range("D141").Value = "OK"

-Else

-Range("D141").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOptionsView(ByRef num)

-Range("A142").Clear

-Range("B142").Clear

-Range("C142").Clear

-Range("D142").Clear

-Range("A142").Value = "xlDialogOptionsView"

-Range("B142").Value = 320

-Range("C142").Value = num

-B142 = Range("B142").Value

-C142 = Range("C142").Value

-If B142 = C142 Then

-Range("D142").Value = "OK"

-Else

-Range("D142").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOutline(ByRef num)

-Range("A143").Clear

-Range("B143").Clear

-Range("C143").Clear

-Range("D143").Clear

-Range("A143").Value = "xlDialogOutline"

-Range("B143").Value = 142

-Range("C143").Value = num

-B143 = Range("B143").Value

-C143 = Range("C143").Value

-If B143 = C143 Then

-Range("D143").Value = "OK"

-Else

-Range("D143").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOverlay(ByRef num)

-Range("A144").Clear

-Range("B144").Clear

-Range("C144").Clear

-Range("D144").Clear

-Range("A144").Value = "xlDialogOverlay"

-Range("B144").Value = 86

-Range("C144").Value = num

-B144 = Range("B144").Value

-C144 = Range("C144").Value

-If B144 = C144 Then

-Range("D144").Value = "OK"

-Else

-Range("D144").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOverlayChartType(ByRef num)

-Range("A145").Clear

-Range("B145").Clear

-Range("C145").Clear

-Range("D145").Clear

-Range("A145").Value = "xlDialogOverlayChartType"

-Range("B145").Value = 186

-Range("C145").Value = num

-B145 = Range("B145").Value

-C145 = Range("C145").Value

-If B145 = C145 Then

-Range("D145").Value = "OK"

-Else

-Range("D145").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPageSetup(ByRef num)

-Range("A146").Clear

-Range("B146").Clear

-Range("C146").Clear

-Range("D146").Clear

-Range("A146").Value = "xlDialogPageSetup"

-Range("B146").Value = 7

-Range("C146").Value = num

-B146 = Range("B146").Value

-C146 = Range("C146").Value

-If B146 = C146 Then

-Range("D146").Value = "OK"

-Else

-Range("D146").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogParse(ByRef num)

-Range("A147").Clear

-Range("B147").Clear

-Range("C147").Clear

-Range("D147").Clear

-Range("A147").Value = "xlDialogParse"

-Range("B147").Value = 91

-Range("C147").Value = num

-B147 = Range("B147").Value

-C147 = Range("C147").Value

-If B147 = C147 Then

-Range("D147").Value = "OK"

-Else

-Range("D147").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPasteNames(ByRef num)

-Range("A148").Clear

-Range("B148").Clear

-Range("C148").Clear

-Range("D148").Clear

-Range("A148").Value = "xlDialogPasteNames"

-Range("B148").Value = 58

-Range("C148").Value = num

-B148 = Range("B148").Value

-C148 = Range("C148").Value

-If B148 = C148 Then

-Range("D148").Value = "OK"

-Else

-Range("D148").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPasteSpecial(ByRef num)

-Range("A149").Clear

-Range("B149").Clear

-Range("C149").Clear

-Range("D149").Clear

-Range("A149").Value = "xlDialogPasteSpecial"

-Range("B149").Value = 53

-Range("C149").Value = num

-B149 = Range("B149").Value

-C149 = Range("C149").Value

-If B149 = C149 Then

-Range("D149").Value = "OK"

-Else

-Range("D149").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPatterns(ByRef num)

-Range("A150").Clear

-Range("B150").Clear

-Range("C150").Clear

-Range("D150").Clear

-Range("A150").Value = "xlDialogPatterns"

-Range("B150").Value = 84

-Range("C150").Value = num

-B150 = Range("B150").Value

-C150 = Range("C150").Value

-If B150 = C150 Then

-Range("D150").Value = "OK"

-Else

-Range("D150").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPermission(ByRef num)

-Range("A151").Clear

-Range("B151").Clear

-Range("C151").Clear

-Range("D151").Clear

-Range("A151").Value = "xlDialogPermission"

-Range("B151").Value = 832

-Range("C151").Value = num

-B151 = Range("B151").Value

-C151 = Range("C151").Value

-If B151 = C151 Then

-Range("D151").Value = "OK"

-Else

-Range("D151").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPhonetic(ByRef num)

-Range("A152").Clear

-Range("B152").Clear

-Range("C152").Clear

-Range("D152").Clear

-Range("A152").Value = "xlDialogPhonetic"

-Range("B152").Value = 656

-Range("C152").Value = num

-B152 = Range("B152").Value

-C152 = Range("C152").Value

-If B152 = C152 Then

-Range("D152").Value = "OK"

-Else

-Range("D152").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPivotCalculatedField(ByRef num)

-Range("A153").Clear

-Range("B153").Clear

-Range("C153").Clear

-Range("D153").Clear

-Range("A153").Value = "xlDialogPivotCalculatedField"

-Range("B153").Value = 570

-Range("C153").Value = num

-B153 = Range("B153").Value

-C153 = Range("C153").Value

-If B153 = C153 Then

-Range("D153").Value = "OK"

-Else

-Range("D153").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPivotCalculatedItem(ByRef num)

-Range("A154").Clear

-Range("B154").Clear

-Range("C154").Clear

-Range("D154").Clear

-Range("A154").Value = "xlDialogPivotCalculatedItem"

-Range("B154").Value = 572

-Range("C154").Value = num

-B154 = Range("B154").Value

-C154 = Range("C154").Value

-If B154 = C154 Then

-Range("D154").Value = "OK"

-Else

-Range("D154").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPivotClientServerSet(ByRef num)

-Range("A155").Clear

-Range("B155").Clear

-Range("C155").Clear

-Range("D155").Clear

-Range("A155").Value = "xlDialogPivotClientServerSet"

-Range("B155").Value = 689

-Range("C155").Value = num

-B155 = Range("B155").Value

-C155 = Range("C155").Value

-If B155 = C155 Then

-Range("D155").Value = "OK"

-Else

-Range("D155").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPivotFieldGroup(ByRef num)

-Range("A156").Clear

-Range("B156").Clear

-Range("C156").Clear

-Range("D156").Clear

-Range("A156").Value = "xlDialogPivotFieldGroup"

-Range("B156").Value = 433

-Range("C156").Value = num

-B156 = Range("B156").Value

-C156 = Range("C156").Value

-If B156 = C156 Then

-Range("D156").Value = "OK"

-Else

-Range("D156").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPivotFieldProperties(ByRef num)

-Range("A157").Clear

-Range("B157").Clear

-Range("C157").Clear

-Range("D157").Clear

-Range("A157").Value = "xlDialogPivotFieldProperties"

-Range("B157").Value = 313

-Range("C157").Value = num

-B157 = Range("B157").Value

-C157 = Range("C157").Value

-If B157 = C157 Then

-Range("D157").Value = "OK"

-Else

-Range("D157").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPivotFieldUngroup(ByRef num)

-Range("A158").Clear

-Range("B158").Clear

-Range("C158").Clear

-Range("D158").Clear

-Range("A158").Value = "xlDialogPivotFieldUngroup"

-Range("B158").Value = 434

-Range("C158").Value = num

-B158 = Range("B158").Value

-C158 = Range("C158").Value

-If B158 = C158 Then

-Range("D158").Value = "OK"

-Else

-Range("D158").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPivotShowPages(ByRef num)

-Range("A159").Clear

-Range("B159").Clear

-Range("C159").Clear

-Range("D159").Clear

-Range("A159").Value = "xlDialogPivotShowPages"

-Range("B159").Value = 421

-Range("C159").Value = num

-B159 = Range("B159").Value

-C159 = Range("C159").Value

-If B159 = C159 Then

-Range("D159").Value = "OK"

-Else

-Range("D159").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPivotSolveOrder(ByRef num)

-Range("A160").Clear

-Range("B160").Clear

-Range("C160").Clear

-Range("D160").Clear

-Range("A160").Value = "xlDialogPivotSolveOrder"

-Range("B160").Value = 568

-Range("C160").Value = num

-B160 = Range("B160").Value

-C160 = Range("C160").Value

-If B160 = C160 Then

-Range("D160").Value = "OK"

-Else

-Range("D160").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPivotTableOptions(ByRef num)

-Range("A161").Clear

-Range("B161").Clear

-Range("C161").Clear

-Range("D161").Clear

-Range("A161").Value = "xlDialogPivotTableOptions"

-Range("B161").Value = 567

-Range("C161").Value = num

-B161 = Range("B161").Value

-C161 = Range("C161").Value

-If B161 = C161 Then

-Range("D161").Value = "OK"

-Else

-Range("D161").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPivotTableWizard(ByRef num)

-Range("A162").Clear

-Range("B162").Clear

-Range("C162").Clear

-Range("D162").Clear

-Range("A162").Value = "xlDialogPivotTableWizard"

-Range("B162").Value = 321

-Range("C162").Value = num

-B162 = Range("B162").Value

-C162 = Range("C162").Value

-If B162 = C162 Then

-Range("D162").Value = "OK"

-Else

-Range("D162").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPlacement(ByRef num)

-Range("A163").Clear

-Range("B163").Clear

-Range("C163").Clear

-Range("D163").Clear

-Range("A163").Value = "xlDialogPlacement"

-Range("B163").Value = 300

-Range("C163").Value = num

-B163 = Range("B163").Value

-C163 = Range("C163").Value

-If B163 = C163 Then

-Range("D163").Value = "OK"

-Else

-Range("D163").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPrint(ByRef num)

-Range("A164").Clear

-Range("B164").Clear

-Range("C164").Clear

-Range("D164").Clear

-Range("A164").Value = "xlDialogPrint"

-Range("B164").Value = 8

-Range("C164").Value = num

-B164 = Range("B164").Value

-C164 = Range("C164").Value

-If B164 = C164 Then

-Range("D164").Value = "OK"

-Else

-Range("D164").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPrintSetup(ByRef num)

-Range("A165").Clear

-Range("B165").Clear

-Range("C165").Clear

-Range("D165").Clear

-Range("A165").Value = "xlDialogPrintSetup"

-Range("B165").Value = 9

-Range("C165").Value = num

-B165 = Range("B165").Value

-C165 = Range("C165").Value

-If B165 = C165 Then

-Range("D165").Value = "OK"

-Else

-Range("D165").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPrintPreview(ByRef num)

-Range("A166").Clear

-Range("B166").Clear

-Range("C166").Clear

-Range("D166").Clear

-Range("A166").Value = "xlDialogPrintPreview"

-Range("B166").Value = 222

-Range("C166").Value = num

-B166 = Range("B166").Value

-C166 = Range("C166").Value

-If B166 = C166 Then

-Range("D166").Value = "OK"

-Else

-Range("D166").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPromote(ByRef num)

-Range("A167").Clear

-Range("B167").Clear

-Range("C167").Clear

-Range("D167").Clear

-Range("A167").Value = "xlDialogPromote"

-Range("B167").Value = 202

-Range("C167").Value = num

-B167 = Range("B167").Value

-C167 = Range("C167").Value

-If B167 = C167 Then

-Range("D167").Value = "OK"

-Else

-Range("D167").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogProperties(ByRef num)

-Range("A168").Clear

-Range("B168").Clear

-Range("C168").Clear

-Range("D168").Clear

-Range("A168").Value = "xlDialogProperties"

-Range("B168").Value = 474

-Range("C168").Value = num

-B168 = Range("B168").Value

-C168 = Range("C168").Value

-If B168 = C168 Then

-Range("D168").Value = "OK"

-Else

-Range("D168").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPropertyFields(ByRef num)

-Range("A169").Clear

-Range("B169").Clear

-Range("C169").Clear

-Range("D169").Clear

-Range("A169").Value = "xlDialogPropertyFields"

-Range("B169").Value = 754

-Range("C169").Value = num

-B169 = Range("B169").Value

-C169 = Range("C169").Value

-If B169 = C169 Then

-Range("D169").Value = "OK"

-Else

-Range("D169").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogProtectDocument(ByRef num)

-Range("A170").Clear

-Range("B170").Clear

-Range("C170").Clear

-Range("D170").Clear

-Range("A170").Value = "xlDialogProtectDocument"

-Range("B170").Value = 28

-Range("C170").Value = num

-B170 = Range("B170").Value

-C170 = Range("C170").Value

-If B170 = C170 Then

-Range("D170").Value = "OK"

-Else

-Range("D170").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogProtectSharing(ByRef num)

-Range("A171").Clear

-Range("B171").Clear

-Range("C171").Clear

-Range("D171").Clear

-Range("A171").Value = "xlDialogProtectSharing"

-Range("B171").Value = 620

-Range("C171").Value = num

-B171 = Range("B171").Value

-C171 = Range("C171").Value

-If B171 = C171 Then

-Range("D171").Value = "OK"

-Else

-Range("D171").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPublishAsWebPage(ByRef num)

-Range("A172").Clear

-Range("B172").Clear

-Range("C172").Clear

-Range("D172").Clear

-Range("A172").Value = "xlDialogPublishAsWebPage"

-Range("B172").Value = 653

-Range("C172").Value = num

-B172 = Range("B172").Value

-C172 = Range("C172").Value

-If B172 = C172 Then

-Range("D172").Value = "OK"

-Else

-Range("D172").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPushbuttonProperties(ByRef num)

-Range("A173").Clear

-Range("B173").Clear

-Range("C173").Clear

-Range("D173").Clear

-Range("A173").Value = "xlDialogPushbuttonProperties"

-Range("B173").Value = 445

-Range("C173").Value = num

-B173 = Range("B173").Value

-C173 = Range("C173").Value

-If B173 = C173 Then

-Range("D173").Value = "OK"

-Else

-Range("D173").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogReplaceFont(ByRef num)

-Range("A174").Clear

-Range("B174").Clear

-Range("C174").Clear

-Range("D174").Clear

-Range("A174").Value = "xlDialogReplaceFont"

-Range("B174").Value = 134

-Range("C174").Value = num

-B174 = Range("B174").Value

-C174 = Range("C174").Value

-If B174 = C174 Then

-Range("D174").Value = "OK"

-Else

-Range("D174").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogRoutingSlip(ByRef num)

-Range("A175").Clear

-Range("B175").Clear

-Range("C175").Clear

-Range("D175").Clear

-Range("A175").Value = "xlDialogRoutingSlip"

-Range("B175").Value = 336

-Range("C175").Value = num

-B175 = Range("B175").Value

-C175 = Range("C175").Value

-If B175 = C175 Then

-Range("D175").Value = "OK"

-Else

-Range("D175").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogRowHeight(ByRef num)

-Range("A176").Clear

-Range("B176").Clear

-Range("C176").Clear

-Range("D176").Clear

-Range("A176").Value = "xlDialogRowHeight"

-Range("B176").Value = 127

-Range("C176").Value = num

-B176 = Range("B176").Value

-C176 = Range("C176").Value

-If B176 = C176 Then

-Range("D176").Value = "OK"

-Else

-Range("D176").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogRun(ByRef num)

-Range("A177").Clear

-Range("B177").Clear

-Range("C177").Clear

-Range("D177").Clear

-Range("A177").Value = "xlDialogRun"

-Range("B177").Value = 17

-Range("C177").Value = num

-B177 = Range("B177").Value

-C177 = Range("C177").Value

-If B177 = C177 Then

-Range("D177").Value = "OK"

-Else

-Range("D177").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSaveAs(ByRef num)

-Range("A178").Clear

-Range("B178").Clear

-Range("C178").Clear

-Range("D178").Clear

-Range("A178").Value = "xlDialogSaveAs"

-Range("B178").Value = 5

-Range("C178").Value = num

-B178 = Range("B178").Value

-C178 = Range("C178").Value

-If B178 = C178 Then

-Range("D178").Value = "OK"

-Else

-Range("D178").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSaveCopyAs(ByRef num)

-Range("A179").Clear

-Range("B179").Clear

-Range("C179").Clear

-Range("D179").Clear

-Range("A179").Value = "xlDialogSaveCopyAs"

-Range("B179").Value = 456

-Range("C179").Value = num

-B179 = Range("B179").Value

-C179 = Range("C179").Value

-If B179 = C179 Then

-Range("D179").Value = "OK"

-Else

-Range("D179").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSaveNewObject(ByRef num)

-Range("A180").Clear

-Range("B180").Clear

-Range("C180").Clear

-Range("D180").Clear

-Range("A180").Value = "xlDialogSaveNewObject"

-Range("B180").Value = 208

-Range("C180").Value = num

-B180 = Range("B180").Value

-C180 = Range("C180").Value

-If B180 = C180 Then

-Range("D180").Value = "OK"

-Else

-Range("D180").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSaveWorkbook(ByRef num)

-Range("A181").Clear

-Range("B181").Clear

-Range("C181").Clear

-Range("D181").Clear

-Range("A181").Value = "xlDialogSaveWorkbook"

-Range("B181").Value = 145

-Range("C181").Value = num

-B181 = Range("B181").Value

-C181 = Range("C181").Value

-If B181 = C181 Then

-Range("D181").Value = "OK"

-Else

-Range("D181").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSaveWorkspace(ByRef num)

-Range("A182").Clear

-Range("B182").Clear

-Range("C182").Clear

-Range("D182").Clear

-Range("A182").Value = "xlDialogSaveWorkspace"

-Range("B182").Value = 285

-Range("C182").Value = num

-B182 = Range("B182").Value

-C182 = Range("C182").Value

-If B182 = C182 Then

-Range("D182").Value = "OK"

-Else

-Range("D182").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogScale(ByRef num)

-Range("A183").Clear

-Range("B183").Clear

-Range("C183").Clear

-Range("D183").Clear

-Range("A183").Value = "xlDialogScale"

-Range("B183").Value = 87

-Range("C183").Value = num

-B183 = Range("B183").Value

-C183 = Range("C183").Value

-If B183 = C183 Then

-Range("D183").Value = "OK"

-Else

-Range("D183").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogScenarioAdd(ByRef num)

-Range("A184").Clear

-Range("B184").Clear

-Range("C184").Clear

-Range("D184").Clear

-Range("A184").Value = "xlDialogScenarioAdd"

-Range("B184").Value = 307

-Range("C184").Value = num

-B184 = Range("B184").Value

-C184 = Range("C184").Value

-If B184 = C184 Then

-Range("D184").Value = "OK"

-Else

-Range("D184").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogScenarioCells(ByRef num)

-Range("A185").Clear

-Range("B185").Clear

-Range("C185").Clear

-Range("D185").Clear

-Range("A185").Value = "xlDialogScenarioCells"

-Range("B185").Value = 305

-Range("C185").Value = num

-B185 = Range("B185").Value

-C185 = Range("C185").Value

-If B185 = C185 Then

-Range("D185").Value = "OK"

-Else

-Range("D185").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogScenarioEdit(ByRef num)

-Range("A186").Clear

-Range("B186").Clear

-Range("C186").Clear

-Range("D186").Clear

-Range("A186").Value = "xlDialogScenarioEdit"

-Range("B186").Value = 308

-Range("C186").Value = num

-B186 = Range("B186").Value

-C186 = Range("C186").Value

-If B186 = C186 Then

-Range("D186").Value = "OK"

-Else

-Range("D186").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogScenarioMerge(ByRef num)

-Range("A187").Clear

-Range("B187").Clear

-Range("C187").Clear

-Range("D187").Clear

-Range("A187").Value = "xlDialogScenarioMerge"

-Range("B187").Value = 473

-Range("C187").Value = num

-B187 = Range("B187").Value

-C187 = Range("C187").Value

-If B187 = C187 Then

-Range("D187").Value = "OK"

-Else

-Range("D187").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogScenarioSummary(ByRef num)

-Range("A188").Clear

-Range("B188").Clear

-Range("C188").Clear

-Range("D188").Clear

-Range("A188").Value = "xlDialogScenarioSummary"

-Range("B188").Value = 311

-Range("C188").Value = num

-B188 = Range("B188").Value

-C188 = Range("C188").Value

-If B188 = C188 Then

-Range("D188").Value = "OK"

-Else

-Range("D188").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogScrollbarProperties(ByRef num)

-Range("A189").Clear

-Range("B189").Clear

-Range("C189").Clear

-Range("D189").Clear

-Range("A189").Value = "xlDialogScrollbarProperties"

-Range("B189").Value = 420

-Range("C189").Value = num

-B189 = Range("B189").Value

-C189 = Range("C189").Value

-If B189 = C189 Then

-Range("D189").Value = "OK"

-Else

-Range("D189").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSearch(ByRef num)

-Range("A190").Clear

-Range("B190").Clear

-Range("C190").Clear

-Range("D190").Clear

-Range("A190").Value = "xlDialogSearch"

-Range("B190").Value = 731

-Range("C190").Value = num

-B190 = Range("B190").Value

-C190 = Range("C190").Value

-If B190 = C190 Then

-Range("D190").Value = "OK"

-Else

-Range("D190").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSelectSpecial(ByRef num)

-Range("A191").Clear

-Range("B191").Clear

-Range("C191").Clear

-Range("D191").Clear

-Range("A191").Value = "xlDialogSelectSpecial"

-Range("B191").Value = 132

-Range("C191").Value = num

-B191 = Range("B191").Value

-C191 = Range("C191").Value

-If B191 = C191 Then

-Range("D191").Value = "OK"

-Else

-Range("D191").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSendMail(ByRef num)

-Range("A192").Clear

-Range("B192").Clear

-Range("C192").Clear

-Range("D192").Clear

-Range("A192").Value = "xlDialogSendMail"

-Range("B192").Value = 189

-Range("C192").Value = num

-B192 = Range("B192").Value

-C192 = Range("C192").Value

-If B192 = C192 Then

-Range("D192").Value = "OK"

-Else

-Range("D192").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSeriesAxes(ByRef num)

-Range("A193").Clear

-Range("B193").Clear

-Range("C193").Clear

-Range("D193").Clear

-Range("A193").Value = "xlDialogSeriesAxes"

-Range("B193").Value = 450

-Range("C193").Value = num

-B193 = Range("B193").Value

-C193 = Range("C193").Value

-If B193 = C193 Then

-Range("D193").Value = "OK"

-Else

-Range("D193").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSeriesOptions(ByRef num)

-Range("A194").Clear

-Range("B194").Clear

-Range("C194").Clear

-Range("D194").Clear

-Range("A194").Value = "xlDialogSeriesOptions"

-Range("B194").Value = 557

-Range("C194").Value = num

-B194 = Range("B194").Value

-C194 = Range("C194").Value

-If B194 = C194 Then

-Range("D194").Value = "OK"

-Else

-Range("D194").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSeriesOrder(ByRef num)

-Range("A195").Clear

-Range("B195").Clear

-Range("C195").Clear

-Range("D195").Clear

-Range("A195").Value = "xlDialogSeriesOrder"

-Range("B195").Value = 466

-Range("C195").Value = num

-B195 = Range("B195").Value

-C195 = Range("C195").Value

-If B195 = C195 Then

-Range("D195").Value = "OK"

-Else

-Range("D195").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSeriesShape(ByRef num)

-Range("A196").Clear

-Range("B196").Clear

-Range("C196").Clear

-Range("D196").Clear

-Range("A196").Value = "xlDialogSeriesShape"

-Range("B196").Value = 504

-Range("C196").Value = num

-B196 = Range("B196").Value

-C196 = Range("C196").Value

-If B196 = C196 Then

-Range("D196").Value = "OK"

-Else

-Range("D196").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSeriesX(ByRef num)

-Range("A197").Clear

-Range("B197").Clear

-Range("C197").Clear

-Range("D197").Clear

-Range("A197").Value = "xlDialogSeriesX"

-Range("B197").Value = 461

-Range("C197").Value = num

-B197 = Range("B197").Value

-C197 = Range("C197").Value

-If B197 = C197 Then

-Range("D197").Value = "OK"

-Else

-Range("D197").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSeriesY(ByRef num)

-Range("A198").Clear

-Range("B198").Clear

-Range("C198").Clear

-Range("D198").Clear

-Range("A198").Value = "xlDialogSeriesY"

-Range("B198").Value = 462

-Range("C198").Value = num

-B198 = Range("B198").Value

-C198 = Range("C198").Value

-If B198 = C198 Then

-Range("D198").Value = "OK"

-Else

-Range("D198").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSetBackgroundPicture(ByRef num)

-Range("A199").Clear

-Range("B199").Clear

-Range("C199").Clear

-Range("D199").Clear

-Range("A199").Value = "xlDialogSetBackgroundPicture"

-Range("B199").Value = 509

-Range("C199").Value = num

-B199 = Range("B199").Value

-C199 = Range("C199").Value

-If B199 = C199 Then

-Range("D199").Value = "OK"

-Else

-Range("D199").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSetPrintTitles(ByRef num)

-Range("A200").Clear

-Range("B200").Clear

-Range("C200").Clear

-Range("D200").Clear

-Range("A200").Value = "xlDialogSetPrintTitles"

-Range("B200").Value = 23

-Range("C200").Value = num

-B200 = Range("B200").Value

-C200 = Range("C200").Value

-If B200 = C200 Then

-Range("D200").Value = "OK"

-Else

-Range("D200").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSetUpdateStatus(ByRef num)

-Range("A201").Clear

-Range("B201").Clear

-Range("C201").Clear

-Range("D201").Clear

-Range("A201").Value = "xlDialogSetUpdateStatus"

-Range("B201").Value = 159

-Range("C201").Value = num

-B201 = Range("B201").Value

-C201 = Range("C201").Value

-If B201 = C201 Then

-Range("D201").Value = "OK"

-Else

-Range("D201").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogShowDetail(ByRef num)

-Range("A202").Clear

-Range("B202").Clear

-Range("C202").Clear

-Range("D202").Clear

-Range("A202").Value = "xlDialogShowDetail"

-Range("B202").Value = 204

-Range("C202").Value = num

-B202 = Range("B202").Value

-C202 = Range("C202").Value

-If B202 = C202 Then

-Range("D202").Value = "OK"

-Else

-Range("D202").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogShowToolbar(ByRef num)

-Range("A203").Clear

-Range("B203").Clear

-Range("C203").Clear

-Range("D203").Clear

-Range("A203").Value = "xlDialogShowToolbar"

-Range("B203").Value = 220

-Range("C203").Value = num

-B203 = Range("B203").Value

-C203 = Range("C203").Value

-If B203 = C203 Then

-Range("D203").Value = "OK"

-Else

-Range("D203").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSize(ByRef num)

-Range("A204").Clear

-Range("B204").Clear

-Range("C204").Clear

-Range("D204").Clear

-Range("A204").Value = "xlDialogSize"

-Range("B204").Value = 261

-Range("C204").Value = num

-B204 = Range("B204").Value

-C204 = Range("C204").Value

-If B204 = C204 Then

-Range("D204").Value = "OK"

-Else

-Range("D204").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSort(ByRef num)

-Range("A205").Clear

-Range("B205").Clear

-Range("C205").Clear

-Range("D205").Clear

-Range("A205").Value = "xlDialogSort"

-Range("B205").Value = 39

-Range("C205").Value = num

-B205 = Range("B205").Value

-C205 = Range("C205").Value

-If B205 = C205 Then

-Range("D205").Value = "OK"

-Else

-Range("D205").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSortSpecial(ByRef num)

-Range("A206").Clear

-Range("B206").Clear

-Range("C206").Clear

-Range("D206").Clear

-Range("A206").Value = "xlDialogSortSpecial"

-Range("B206").Value = 192

-Range("C206").Value = num

-B206 = Range("B206").Value

-C206 = Range("C206").Value

-If B206 = C206 Then

-Range("D206").Value = "OK"

-Else

-Range("D206").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSplit(ByRef num)

-Range("A207").Clear

-Range("B207").Clear

-Range("C207").Clear

-Range("D207").Clear

-Range("A207").Value = "xlDialogSplit"

-Range("B207").Value = 137

-Range("C207").Value = num

-B207 = Range("B207").Value

-C207 = Range("C207").Value

-If B207 = C207 Then

-Range("D207").Value = "OK"

-Else

-Range("D207").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogStandardFont(ByRef num)

-Range("A208").Clear

-Range("B208").Clear

-Range("C208").Clear

-Range("D208").Clear

-Range("A208").Value = "xlDialogStandardFont"

-Range("B208").Value = 190

-Range("C208").Value = num

-B208 = Range("B208").Value

-C208 = Range("C208").Value

-If B208 = C208 Then

-Range("D208").Value = "OK"

-Else

-Range("D208").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogStandardWidth(ByRef num)

-Range("A209").Clear

-Range("B209").Clear

-Range("C209").Clear

-Range("D209").Clear

-Range("A209").Value = "xlDialogStandardWidth"

-Range("B209").Value = 472

-Range("C209").Value = num

-B209 = Range("B209").Value

-C209 = Range("C209").Value

-If B209 = C209 Then

-Range("D209").Value = "OK"

-Else

-Range("D209").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogStyle(ByRef num)

-Range("A210").Clear

-Range("B210").Clear

-Range("C210").Clear

-Range("D210").Clear

-Range("A210").Value = "xlDialogStyle"

-Range("B210").Value = 44

-Range("C210").Value = num

-B210 = Range("B210").Value

-C210 = Range("C210").Value

-If B210 = C210 Then

-Range("D210").Value = "OK"

-Else

-Range("D210").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSubscribeTo(ByRef num)

-Range("A211").Clear

-Range("B211").Clear

-Range("C211").Clear

-Range("D211").Clear

-Range("A211").Value = "xlDialogSubscribeTo"

-Range("B211").Value = 218

-Range("C211").Value = num

-B211 = Range("B211").Value

-C211 = Range("C211").Value

-If B211 = C211 Then

-Range("D211").Value = "OK"

-Else

-Range("D211").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSubtotalCreate(ByRef num)

-Range("A212").Clear

-Range("B212").Clear

-Range("C212").Clear

-Range("D212").Clear

-Range("A212").Value = "xlDialogSubtotalCreate"

-Range("B212").Value = 398

-Range("C212").Value = num

-B212 = Range("B212").Value

-C212 = Range("C212").Value

-If B212 = C212 Then

-Range("D212").Value = "OK"

-Else

-Range("D212").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSummaryInfo(ByRef num)

-Range("A213").Clear

-Range("B213").Clear

-Range("C213").Clear

-Range("D213").Clear

-Range("A213").Value = "xlDialogSummaryInfo"

-Range("B213").Value = 474

-Range("C213").Value = num

-B213 = Range("B213").Value

-C213 = Range("C213").Value

-If B213 = C213 Then

-Range("D213").Value = "OK"

-Else

-Range("D213").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogTable(ByRef num)

-Range("A214").Clear

-Range("B214").Clear

-Range("C214").Clear

-Range("D214").Clear

-Range("A214").Value = "xlDialogTable"

-Range("B214").Value = 41

-Range("C214").Value = num

-B214 = Range("B214").Value

-C214 = Range("C214").Value

-If B214 = C214 Then

-Range("D214").Value = "OK"

-Else

-Range("D214").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogTabOrder(ByRef num)

-Range("A215").Clear

-Range("B215").Clear

-Range("C215").Clear

-Range("D215").Clear

-Range("A215").Value = "xlDialogTabOrder"

-Range("B215").Value = 394

-Range("C215").Value = num

-B215 = Range("B215").Value

-C215 = Range("C215").Value

-If B215 = C215 Then

-Range("D215").Value = "OK"

-Else

-Range("D215").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogTextToColumns(ByRef num)

-Range("A216").Clear

-Range("B216").Clear

-Range("C216").Clear

-Range("D216").Clear

-Range("A216").Value = "xlDialogTextToColumns"

-Range("B216").Value = 422

-Range("C216").Value = num

-B216 = Range("B216").Value

-C216 = Range("C216").Value

-If B216 = C216 Then

-Range("D216").Value = "OK"

-Else

-Range("D216").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogUnhide(ByRef num)

-Range("A217").Clear

-Range("B217").Clear

-Range("C217").Clear

-Range("D217").Clear

-Range("A217").Value = "xlDialogUnhide"

-Range("B217").Value = 94

-Range("C217").Value = num

-B217 = Range("B217").Value

-C217 = Range("C217").Value

-If B217 = C217 Then

-Range("D217").Value = "OK"

-Else

-Range("D217").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogUpdateLink(ByRef num)

-Range("A218").Clear

-Range("B218").Clear

-Range("C218").Clear

-Range("D218").Clear

-Range("A218").Value = "xlDialogUpdateLink"

-Range("B218").Value = 201

-Range("C218").Value = num

-B218 = Range("B218").Value

-C218 = Range("C218").Value

-If B218 = C218 Then

-Range("D218").Value = "OK"

-Else

-Range("D218").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogVbaInsertFile(ByRef num)

-Range("A219").Clear

-Range("B219").Clear

-Range("C219").Clear

-Range("D219").Clear

-Range("A219").Value = "xlDialogVbaInsertFile"

-Range("B219").Value = 328

-Range("C219").Value = num

-B219 = Range("B219").Value

-C219 = Range("C219").Value

-If B219 = C219 Then

-Range("D219").Value = "OK"

-Else

-Range("D219").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogVbaMakeAddin(ByRef num)

-Range("A220").Clear

-Range("B220").Clear

-Range("C220").Clear

-Range("D220").Clear

-Range("A220").Value = "xlDialogVbaMakeAddin"

-Range("B220").Value = 478

-Range("C220").Value = num

-B220 = Range("B220").Value

-C220 = Range("C220").Value

-If B220 = C220 Then

-Range("D220").Value = "OK"

-Else

-Range("D220").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogVbaProcedureDefinition(ByRef num)

-Range("A221").Clear

-Range("B221").Clear

-Range("C221").Clear

-Range("D221").Clear

-Range("A221").Value = "xlDialogVbaProcedureDefinition"

-Range("B221").Value = 330

-Range("C221").Value = num

-B221 = Range("B221").Value

-C221 = Range("C221").Value

-If B221 = C221 Then

-Range("D221").Value = "OK"

-Else

-Range("D221").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogView3d(ByRef num)

-Range("A222").Clear

-Range("B222").Clear

-Range("C222").Clear

-Range("D222").Clear

-Range("A222").Value = "xlDialogView3d"

-Range("B222").Value = 197

-Range("C222").Value = num

-B222 = Range("B222").Value

-C222 = Range("C222").Value

-If B222 = C222 Then

-Range("D222").Value = "OK"

-Else

-Range("D222").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWebOptionsBrowsers(ByRef num)

-Range("A223").Clear

-Range("B223").Clear

-Range("C223").Clear

-Range("D223").Clear

-Range("A223").Value = "xlDialogWebOptionsBrowsers"

-Range("B223").Value = 773

-Range("C223").Value = num

-B223 = Range("B223").Value

-C223 = Range("C223").Value

-If B223 = C223 Then

-Range("D223").Value = "OK"

-Else

-Range("D223").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWebOptionsEncoding(ByRef num)

-Range("A224").Clear

-Range("B224").Clear

-Range("C224").Clear

-Range("D224").Clear

-Range("A224").Value = "xlDialogWebOptionsEncoding"

-Range("B224").Value = 686

-Range("C224").Value = num

-B224 = Range("B224").Value

-C224 = Range("C224").Value

-If B224 = C224 Then

-Range("D224").Value = "OK"

-Else

-Range("D224").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWebOptionsFiles(ByRef num)

-Range("A225").Clear

-Range("B225").Clear

-Range("C225").Clear

-Range("D225").Clear

-Range("A225").Value = "xlDialogWebOptionsFiles"

-Range("B225").Value = 684

-Range("C225").Value = num

-B225 = Range("B225").Value

-C225 = Range("C225").Value

-If B225 = C225 Then

-Range("D225").Value = "OK"

-Else

-Range("D225").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWebOptionsFonts(ByRef num)

-Range("A226").Clear

-Range("B226").Clear

-Range("C226").Clear

-Range("D226").Clear

-Range("A226").Value = "xlDialogWebOptionsFonts"

-Range("B226").Value = 687

-Range("C226").Value = num

-B226 = Range("B226").Value

-C226 = Range("C226").Value

-If B226 = C226 Then

-Range("D226").Value = "OK"

-Else

-Range("D226").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWebOptionsGeneral(ByRef num)

-Range("A227").Clear

-Range("B227").Clear

-Range("C227").Clear

-Range("D227").Clear

-Range("A227").Value = "xlDialogWebOptionsGeneral"

-Range("B227").Value = 683

-Range("C227").Value = num

-B227 = Range("B227").Value

-C227 = Range("C227").Value

-If B227 = C227 Then

-Range("D227").Value = "OK"

-Else

-Range("D227").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWebOptionsPictures(ByRef num)

-Range("A228").Clear

-Range("B228").Clear

-Range("C228").Clear

-Range("D228").Clear

-Range("A228").Value = "xlDialogWebOptionsPictures"

-Range("B228").Value = 685

-Range("C228").Value = num

-B228 = Range("B228").Value

-C228 = Range("C228").Value

-If B228 = C228 Then

-Range("D228").Value = "OK"

-Else

-Range("D228").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWindowMove(ByRef num)

-Range("A229").Clear

-Range("B229").Clear

-Range("C229").Clear

-Range("D229").Clear

-Range("A229").Value = "xlDialogWindowMove"

-Range("B229").Value = 14

-Range("C229").Value = num

-B229 = Range("B229").Value

-C229 = Range("C229").Value

-If B229 = C229 Then

-Range("D229").Value = "OK"

-Else

-Range("D229").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWindowSize(ByRef num)

-Range("A230").Clear

-Range("B230").Clear

-Range("C230").Clear

-Range("D230").Clear

-Range("A230").Value = "xlDialogWindowSize"

-Range("B230").Value = 13

-Range("C230").Value = num

-B230 = Range("B230").Value

-C230 = Range("C230").Value

-If B230 = C230 Then

-Range("D230").Value = "OK"

-Else

-Range("D230").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWorkbookAdd(ByRef num)

-Range("A231").Clear

-Range("B231").Clear

-Range("C231").Clear

-Range("D231").Clear

-Range("A231").Value = "xlDialogWorkbookAdd"

-Range("B231").Value = 281

-Range("C231").Value = num

-B231 = Range("B231").Value

-C231 = Range("C231").Value

-If B231 = C231 Then

-Range("D231").Value = "OK"

-Else

-Range("D231").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWorkbookCopy(ByRef num)

-Range("A232").Clear

-Range("B232").Clear

-Range("C232").Clear

-Range("D232").Clear

-Range("A232").Value = "xlDialogWorkbookCopy"

-Range("B232").Value = 283

-Range("C232").Value = num

-B232 = Range("B232").Value

-C232 = Range("C232").Value

-If B232 = C232 Then

-Range("D232").Value = "OK"

-Else

-Range("D232").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWorkbookInsert(ByRef num)

-Range("A233").Clear

-Range("B233").Clear

-Range("C233").Clear

-Range("D233").Clear

-Range("A233").Value = "xlDialogWorkbookInsert"

-Range("B233").Value = 354

-Range("C233").Value = num

-B233 = Range("B233").Value

-C233 = Range("C233").Value

-If B233 = C233 Then

-Range("D233").Value = "OK"

-Else

-Range("D233").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWorkbookMove(ByRef num)

-Range("A234").Clear

-Range("B234").Clear

-Range("C234").Clear

-Range("D234").Clear

-Range("A234").Value = "xlDialogWorkbookMove"

-Range("B234").Value = 282

-Range("C234").Value = num

-B234 = Range("B234").Value

-C234 = Range("C234").Value

-If B234 = C234 Then

-Range("D234").Value = "OK"

-Else

-Range("D234").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWorkbookName(ByRef num)

-Range("A235").Clear

-Range("B235").Clear

-Range("C235").Clear

-Range("D235").Clear

-Range("A235").Value = "xlDialogWorkbookName"

-Range("B235").Value = 386

-Range("C235").Value = num

-B235 = Range("B235").Value

-C235 = Range("C235").Value

-If B235 = C235 Then

-Range("D235").Value = "OK"

-Else

-Range("D235").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWorkbookNew(ByRef num)

-Range("A236").Clear

-Range("B236").Clear

-Range("C236").Clear

-Range("D236").Clear

-Range("A236").Value = "xlDialogWorkbookNew"

-Range("B236").Value = 302

-Range("C236").Value = num

-B236 = Range("B236").Value

-C236 = Range("C236").Value

-If B236 = C236 Then

-Range("D236").Value = "OK"

-Else

-Range("D236").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWorkbookOptions(ByRef num)

-Range("A237").Clear

-Range("B237").Clear

-Range("C237").Clear

-Range("D237").Clear

-Range("A237").Value = "xlDialogWorkbookOptions"

-Range("B237").Value = 284

-Range("C237").Value = num

-B237 = Range("B237").Value

-C237 = Range("C237").Value

-If B237 = C237 Then

-Range("D237").Value = "OK"

-Else

-Range("D237").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWorkbookProtect(ByRef num)

-Range("A238").Clear

-Range("B238").Clear

-Range("C238").Clear

-Range("D238").Clear

-Range("A238").Value = "xlDialogWorkbookProtect"

-Range("B238").Value = 417

-Range("C238").Value = num

-B238 = Range("B238").Value

-C238 = Range("C238").Value

-If B238 = C238 Then

-Range("D238").Value = "OK"

-Else

-Range("D238").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWorkbookTabSplit(ByRef num)

-Range("A239").Clear

-Range("B239").Clear

-Range("C239").Clear

-Range("D239").Clear

-Range("A239").Value = "xlDialogWorkbookTabSplit"

-Range("B239").Value = 415

-Range("C239").Value = num

-B239 = Range("B239").Value

-C239 = Range("C239").Value

-If B239 = C239 Then

-Range("D239").Value = "OK"

-Else

-Range("D239").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWorkbookUnhide(ByRef num)

-Range("A240").Clear

-Range("B240").Clear

-Range("C240").Clear

-Range("D240").Clear

-Range("A240").Value = "xlDialogWorkbookUnhide"

-Range("B240").Value = 384

-Range("C240").Value = num

-B240 = Range("B240").Value

-C240 = Range("C240").Value

-If B240 = C240 Then

-Range("D240").Value = "OK"

-Else

-Range("D240").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWorkgroup(ByRef num)

-Range("A241").Clear

-Range("B241").Clear

-Range("C241").Clear

-Range("D241").Clear

-Range("A241").Value = "xlDialogWorkgroup"

-Range("B241").Value = 199

-Range("C241").Value = num

-B241 = Range("B241").Value

-C241 = Range("C241").Value

-If B241 = C241 Then

-Range("D241").Value = "OK"

-Else

-Range("D241").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWorkspace(ByRef num)

-Range("A242").Clear

-Range("B242").Clear

-Range("C242").Clear

-Range("D242").Clear

-Range("A242").Value = "xlDialogWorkspace"

-Range("B242").Value = 95

-Range("C242").Value = num

-B242 = Range("B242").Value

-C242 = Range("C242").Value

-If B242 = C242 Then

-Range("D242").Value = "OK"

-Else

-Range("D242").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogZoom(ByRef num)

-Range("A243").Clear

-Range("B243").Clear

-Range("C243").Clear

-Range("D243").Clear

-Range("A243").Value = "xlDialogZoom"

-Range("B243").Value = 256

-Range("C243").Value = num

-B243 = Range("B243").Value

-C243 = Range("C243").Value

-If B243 = C243 Then

-Range("D243").Value = "OK"

-Else

-Range("D243").Value = "NG"

-End If

-End Function

-

-<<<<<<
-======================
-Module4
->>>>>>
-Attribute VB_Name = "Module4"

-

-Sub main_4()

-test_xlErrDiv0 (xlErrDiv0)

-test_xlErrNA (xlErrNA)

-test_xlErrName (xlErrName)

-test_xlErrNull (xlErrNull)

-test_xlErrNum (xlErrNum)

-test_xlErrRef (xlErrRef)

-test_xlErrValue (xlErrValue)

-test_xlCalculatedMember (xlCalculatedMember)

-test_xlCalculatedSet (xlCalculatedSet)

-test_xlCalculationAutomatic (xlCalculationAutomatic)

-test_xlCalculationManual (xlCalculationManual)

-test_xlCalculationSemiautomatic (xlCalculationSemiautomatic)

-test_xlAnyKey (xlAnyKey)

-test_xlEscKey (xlEscKey)

-test_xlNoKey (xlNoKey)

-test_xlCalculating (xlCalculating)

-test_xlDone (xlDone)

-test_xlPending (xlPending)

-test_xlAutomaticScale (xlAutomaticScale)

-test_xlCategoryScale (xlCategoryScale)

-test_xlTimeScale (xlTimeScale)

-test_xlInsertDeleteCells (xlInsertDeleteCells)

-test_xlInsertEntireRows (xlInsertEntireRows)

-test_xlOverwriteCells (xlOverwriteCells)

-test_xlCellTypeAllFormatConditions (xlCellTypeAllFormatConditions)

-test_xlCellTypeAllValidation (xlCellTypeAllValidation)

-test_xlCellTypeBlanks (xlCellTypeBlanks)

-test_xlCellTypeComments (xlCellTypeComments)

-test_xlCellTypeConstants (xlCellTypeConstants)

-test_xlCellTypeFormulas (xlCellTypeFormulas)

-test_xlCellTypeLastCell (xlCellTypeLastCell)

-test_xlCellTypeSameFormatConditions (xlCellTypeSameFormatConditions)

-test_xlCellTypeSameValidation (xlCellTypeSameValidation)

-test_xlCellTypeVisible (xlCellTypeVisible)

-test_xlAnyGallery (xlAnyGallery)

-test_xlBuildIn (xlBuildIn)

-test_xlUserDefined (xlUserDefined)

-test_xlAxis (xlAxis)

-test_xlAxisTitle (xlAxisTitle)

-test_xlChartTitle (xlChartTitle)

-test_xlCorners (xlCorners)

-test_xlDataLabel (xlDataLabel)

-test_xlDataTable (xlDataTable)

-test_xlDisplayUnitLabel (xlDisplayUnitLabel)

-test_xlDownBars (xlDownBars)

-test_xlDropLines (xlDropLines)

-test_xlErrorBars (xlErrorBars)

-test_xlFloor (xlFloor)

-test_xlHiLoLines (xlHiLoLines)

-test_xlLeaderLines (xlLeaderLines)

-test_xlLegend (xlLegend)

-test_xlLegendEntry (xlLegendEntry)

-test_xlLegendKey (xlLegendKey)

-test_xlMajorGridlines (xlMajorGridlines)

-test_xlMinorGridlines (xlMinorGridlines)

-test_xlNothing (xlNothing)

-test_xlPivotChartDropZone (xlPivotChartDropZone)

-test_xlPivotChartFieldButton (xlPivotChartFieldButton)

-test_xlPlotArea (xlPlotArea)

-test_xlRaderAxisLabels (xlRaderAxisLabels)

-test_xlSeries (xlSeries)

-test_xlSeriesLines (xlSeriesLines)

-test_xlShape (xlShape)

-test_xlTrendline (xlTrendline)

-test_xlUpBars (xlUpBars)

-test_xlWalls (xlWalls)

-test_xlXErrorBars (xlXErrorBars)

-test_xlYErrorBars (xlYErrorBars)

-test_xlLocationAsNewSheet (xlLocationAsNewSheet)

-test_xlLocationAsObject (xlLocationAsObject)

-test_xlLocationAutomatic (xlLocationAutomatic)

-test_xlAllFaces (xlAllFaces)

-test_xlEnd (xlEnd)

-test_xlEndSides (xlEndSides)

-test_xlFront (xlFront)

-test_xlFrontEnd (xlFrontEnd)

-test_xlFrontSides (xlFrontSides)

-test_xlSlides (xlSlides)

-test_xlStack (xlStack)

-test_xlStackScale (xlStackScale)

-test_xlStretch (xlStretch)

-test_xlSplitByCustomSplit (xlSplitByCustomSplit)

-test_xlSplitByPercentValue (xlSplitByPercentValue)

-test_xlSplitByPercentPosition (xlSplitByPercentPosition)

-test_xlSplitByValue (xlSplitByValue)

-test_xl3DArea (xl3DArea)

-test_xl3DAreaStacked (xl3DAreaStacked)

-test_xl3DAreaStacked100 (xl3DAreaStacked100)

-test_xl3DBarClustered (xl3DBarClustered)

-test_xl3DBarStacked (xl3DBarStacked)

-test_xl3DBarStacked100 (xl3DBarStacked100)

-test_xl3DColumn (xl3DColumn)

-test_xl3DColumnClustered (xl3DColumnClustered)

-test_xl3DColumnStacked (xl3DColumnStacked)

-test_xl3DColumnStacked100 (xl3DColumnStacked100)

-test_xl3DLine (xl3DLine)

-test_xl3DPie (xl3DPie)

-test_xl3DPieExploded (xl3DPieExploded)

-test_xlArea (xlArea)

-test_xlAreaStacked (xlAreaStacked)

-test_xlAreaStacked100 (xlAreaStacked100)

-test_xlBarClustered (xlBarClustered)

-test_xlBarOfPie (xlBarOfPie)

-test_xlBarStacked (xlBarStacked)

-test_xlBarStacked100 (xlBarStacked100)

-test_xlBubble (xlBubble)

-test_xlBubble3DEffect (xlBubble3DEffect)

-test_xlColumnClustered (xlColumnClustered)

-test_xlColumnStacked (xlColumnStacked)

-test_xlColumnStacked100 (xlColumnStacked100)

-test_xlConeBarClustered (xlConeBarClustered)

-test_xlConeBarStacked (xlConeBarStacked)

-test_xlConeBarStacked100 (xlConeBarStacked100)

-test_xlConeCol (xlConeCol)

-test_xlConeColClustered (xlConeColClustered)

-test_xlConeColStacked (xlConeColStacked)

-test_xlConeColStacked100 (xlConeColStacked100)

-test_xlCylinderBarClustered (xlCylinderBarClustered)

-test_xlCylinderBarStacked (xlCylinderBarStacked)

-test_xlCylinderBarStacked100 (xlCylinderBarStacked100)

-test_xlCylinderCol (xlCylinderCol)

-test_xlCylinderColClustered (xlCylinderColClustered)

-test_xlCylinderColStacked (xlCylinderColStacked)

-test_xlCylinderColStacked100 (xlCylinderColStacked100)

-test_xlDoughnut (xlDoughnut)

-test_xlDoughnutExploded (xlDoughnutExploded)

-test_xlLine (xlLine)

-test_xlLineMarkers (xlLineMarkers)

-test_xlLineMarkersStacked (xlLineMarkersStacked)

-test_xlLineMarkersStacked100 (xlLineMarkersStacked100)

-test_xlLineStacked (xlLineStacked)

-test_xlLineStacked100 (xlLineStacked100)

-test_xlPie (xlPie)

-test_xlPieExploded (xlPieExploded)

-test_xlPieOfPie (xlPieOfPie)

-test_xlPyramidBarClustered (xlPyramidBarClustered)

-test_xlPyramidBarStacked (xlPyramidBarStacked)

-test_xlPyramidBarStacked100 (xlPyramidBarStacked100)

-test_xlPyramidCol (xlPyramidCol)

-test_xlPyramidColClustered (xlPyramidColClustered)

-test_xlPyramidColStacked (xlPyramidColStacked)

-test_xlPyramidColStacked100 (xlPyramidColStacked100)

-test_xlRader (xlRader)

-test_xlRaderFilled (xlRaderFilled)

-test_xlRaderMarkers (xlRaderMarkers)

-test_xlStockHLC (xlStockHLC)

-test_xlStockOHLC (xlStockOHLC)

-test_xlStockVHLC (xlStockVHLC)

-test_xlStockVOHLC (xlStockVOHLC)

-test_xlSurface (xlSurface)

-test_xlSurfaceTopView (xlSurfaceTopView)

-test_xlSurfaceTopViewWireframe (xlSurfaceTopViewWireframe)

-test_xlSurfaceWireframe (xlSurfaceWireframe)

-test_xlXYScatter (xlXYScatter)

-test_xlXYScatterLines (xlXYScatterLines)

-test_xlXYScatterLinesNoMarkers (xlXYScatterLinesNoMarkers)

-test_xlXYScatterSmooth (xlXYScatterSmooth)

-test_xlXYScatterSmoothNoMarkers (xlXYScatterSmoothNoMarkers)

-test_xlClipboardFormatBIFF (xlClipboardFormatBIFF)

-test_xlClipboardFormatBIFF2 (xlClipboardFormatBIFF2)

-test_xlClipboardFormatBIFF3 (xlClipboardFormatBIFF3)

-test_xlClipboardFormatBIFF4 (xlClipboardFormatBIFF4)

-test_xlClipboardFormatBinary (xlClipboardFormatBinary)

-test_xlClipboardFormatBitmap (xlClipboardFormatBitmap)

-test_xlClipboardFormatCGM (xlClipboardFormatCGM)

-test_xlClipboardFormatCSV (xlClipboardFormatCSV)

-test_xlClipboardFormatDIF (xlClipboardFormatDIF)

-test_xlClipboardFormatDspText (xlClipboardFormatDspText)

-test_xlClipboardFormatEmbeddedObject (xlClipboardFormatEmbeddedObject)

-test_xlClipboardFormatEmbedSource (xlClipboardFormatEmbedSource)

-test_xlClipboardFormatLink (xlClipboardFormatLink)

-test_xlClipboardFormatLinkSource (xlClipboardFormatLinkSource)

-test_xlClipboardFormatLinkSourceDesc (xlClipboardFormatLinkSourceDesc)

-test_xlClipboardFormatMovie (xlClipboardFormatMovie)

-test_xlClipboardFormatNative (xlClipboardFormatNative)

-test_xlClipboardFormatObjectDesc (xlClipboardFormatObjectDesc)

-test_xlClipboardFormatObjectLink (xlClipboardFormatObjectLink)

-test_xlClipboardFormatOwnerLink (xlClipboardFormatOwnerLink)

-test_xlClipboardFormatPICT (xlClipboardFormatPICT)

-test_xlClipboardFormatPrintPICT (xlClipboardFormatPrintPICT)

-test_xlClipboardFormatRTF (xlClipboardFormatRTF)

-test_xlClipboardFormatScreenPICT (xlClipboardFormatScreenPICT)

-test_xlClipboardFormatStandardFont (xlClipboardFormatStandardFont)

-test_xlClipboardFormatStandardScale (xlClipboardFormatStandardScale)

-test_xlClipboardFormatSYLK (xlClipboardFormatSYLK)

-test_xlClipboardFormatTable (xlClipboardFormatTable)

-test_xlClipboardFormatText (xlClipboardFormatText)

-test_xlClipboardFormatToolFace (xlClipboardFormatToolFace)

-test_xlClipboardFormatToolFacePICT (xlClipboardFormatToolFacePICT)

-test_xlClipboardFormatToolVALU (xlClipboardFormatToolVALU)

-test_xlClipboardFormatToolWK1 (xlClipboardFormatToolWK1)

-test_xlCmdCube (xlCmdCube)

-test_xlCmdDefault (xlCmdDefault)

-test_xlCmdList (xlCmdList)

-test_xlCmdSql (xlCmdSql)

-test_xlCmdTable (xlCmdTable)

-test_xlColorIndexAutomatic (xlColorIndexAutomatic)

-test_xlColorIndexNone (xlColorIndexNone)

-test_xlDMYFormat (xlDMYFormat)

-test_xlDYMFormat (xlDYMFormat)

-test_xlEMDFormat (xlEMDFormat)

-test_xlGeneralFormat (xlGeneralFormat)

-test_xlMDYFormat (xlMDYFormat)

-test_xlMYDFormat (xlMYDFormat)

-test_xlSkipColumn (xlSkipColumn)

-test_xlTextFormat (xlTextFormat)

-test_xlYDMFormat (xlYDMFormat)

-test_xlYMDFormat (xlYMDFormat)

-test_xlCommandUnderlinesAutomatic (xlCommandUnderlinesAutomatic)

-test_xlCommandUnderlinesOff (xlCommandUnderlinesOff)

-test_xlCommandUnderlinesOn (xlCommandUnderlinesOn)

-test_xlCommentAndIndicator (xlCommentAndIndicator)

-test_xlCommentIndicatorOnly (xlCommentIndicatorOnly)

-test_xlNoIndicator (xlNoIndicator)

-test_xlAverage (xlAverage)

-test_xlCount (xlCount)

-test_xlCountNums (xlCountNums)

-test_xlMax (xlMax)

-test_xlMin (xlMin)

-test_xlProduct (xlProduct)

-test_xlStDev (xlStDev)

-test_xlStDevP (xlStDevP)

-test_xlSum (xlSum)

-test_xlUnknown (xlUnknown)

-test_xlVar (xlVar)

-test_xlVarP (xlVarP)

-test_xlBitmap (xlBitmap)

-test_xlPicture (xlPicture)

-test_xlExtractData (xlExtractData)

-test_xlNormalLoad (xlNormalLoad)

-test_xlRepairFile (xlRepairFile)

-test_xlCreatorCode (xlCreatorCode)

-test_xlHierarchy (xlHierarchy)

-test_xlMeasure (xlMeasure)

-test_xlSet (xlSet)

-test_xlCopy (xlCopy)

-test_xlCut (xlCut)

-test_xlValidAlterInformation (xlValidAlterInformation)

-test_xlValidAlterStop (xlValidAlterStop)

-test_xlValidAlterWarning (xlValidAlterWarning)

-test_xlValidateCustom (xlValidateCustom)

-test_xlValidateDate (xlValidateDate)

-test_xlValidateDecimal (xlValidateDecimal)

-test_xlValidateInputOnly (xlValidateInputOnly)

-test_xlValidateList (xlValidateList)

-test_xlValidateTextLength (xlValidateTextLength)

-test_xlValidateTime (xlValidateTime)

-test_xlValidateWholeNumber (xlValidateWholeNumber)

-test_xlLabelPositionAbove (xlLabelPositionAbove)

-test_xlLabelPositionBelow (xlLabelPositionBelow)

-test_xlLabelPositionBestFit (xlLabelPositionBestFit)

-test_xlLabelPositionBestCenter (xlLabelPositionBestCenter)

-test_xlLabelPositionBestCustom (xlLabelPositionBestCustom)

-test_xlLabelPositionInsideBase (xlLabelPositionInsideBase)

-test_xlLabelPositionInsideEnd (xlLabelPositionInsideEnd)

-test_xlLabelPositionInsideLeft (xlLabelPositionInsideLeft)

-test_xlLabelPositionMixed (xlLabelPositionMixed)

-test_xlLabelPositionOutsideEnd (xlLabelPositionOutsideEnd)

-test_xlLabelPositionRight (xlLabelPositionRight)

-test_xlDataLabelSeparatorDefault (xlDataLabelSeparatorDefault)

-test_xlDataLabelsShowBubbleSizes (xlDataLabelsShowBubbleSizes)

-test_xlDataLabelsShowLabel (xlDataLabelsShowLabel)

-test_xlDataLabelsShowLabelAndPercent (xlDataLabelsShowLabelAndPercent)

-test_xlDataLabelsShowNone (xlDataLabelsShowNone)

-test_xlDataLabelsShowPercent (xlDataLabelsShowPercent)

-test_xlDataLabelsShowValue (xlDataLabelsShowValue)

-test_xlDay (xlDay)

-test_xlMonth (xlMonth)

-test_xlWeekday (xlWeekday)

-test_xlYear (xlYear)

-test_xlAutoFill (xlAutoFill)

-test_xlChronological (xlChronological)

-test_xlDataSeriesLinear (xlDataSeriesLinear)

-test_xlGrowth (xlGrowth)

-test_xlShiftToLeft (xlShiftToLeft)

-test_xlShiftUp (xlShiftUp)

-test_xlDown (xlDown)

-test_xlToLeft (xlToLeft)

-test_xlToRight (xlToRight)

-test_xlUp (xlUp)

-test_xlInterpolated (xlInterpolated)

-test_xlNotPlotted (xlNotPlotted)

-test_xlZero (xlZero)

-test_xlDisplayShapes (xlDisplayShapes)

-test_xlHide (xlHide)

-test_xlPlaceholders (xlPlaceholders)

-test_xlHundredMillions (xlHundredMillions)

-test_xlHundreds (xlHundreds)

-test_xlHundredThousands (xlHundredThousands)

-test_xlMillionMillons (xlMillionMillons)

-test_xlMillions (xlMillions)

-test_xlTenMillions (xlTenMillions)

-test_xlTenThousands (xlTenThousands)

-test_xlThousandMillions (xlThousandMillions)

-test_xlThousands (xlThousands)

-Range("A1").Value = "constant name"

-Range("B1").Value = "OOo result"

-Range("C1").Value = "Excel result"

-Range("D1").Value = "Correct?"

-End Sub

-

-Function test_xlErrDiv0(ByRef num)

-Range("A2").Clear

-Range("B2").Clear

-Range("C2").Clear

-Range("D2").Clear

-Range("A2").Value = "xlErrDiv0"

-Range("B2").Value = 2007

-Range("C2").Value = num

-B2 = Range("B2").Value

-C2 = Range("C2").Value

-If B2 = C2 Then

-Range("D2").Value = "OK"

-Else

-Range("D2").Value = "NG"

-End If

-End Function

-

-Function test_xlErrNA(ByRef num)

-Range("A3").Clear

-Range("B3").Clear

-Range("C3").Clear

-Range("D3").Clear

-Range("A3").Value = "xlErrNA"

-Range("B3").Value = 2042

-Range("C3").Value = num

-B3 = Range("B3").Value

-C3 = Range("C3").Value

-If B3 = C3 Then

-Range("D3").Value = "OK"

-Else

-Range("D3").Value = "NG"

-End If

-End Function

-

-Function test_xlErrName(ByRef num)

-Range("A4").Clear

-Range("B4").Clear

-Range("C4").Clear

-Range("D4").Clear

-Range("A4").Value = "xlErrName"

-Range("B4").Value = 2029

-Range("C4").Value = num

-B4 = Range("B4").Value

-C4 = Range("C4").Value

-If B4 = C4 Then

-Range("D4").Value = "OK"

-Else

-Range("D4").Value = "NG"

-End If

-End Function

-

-Function test_xlErrNull(ByRef num)

-Range("A5").Clear

-Range("B5").Clear

-Range("C5").Clear

-Range("D5").Clear

-Range("A5").Value = "xlErrNull"

-Range("B5").Value = 2000

-Range("C5").Value = num

-B5 = Range("B5").Value

-C5 = Range("C5").Value

-If B5 = C5 Then

-Range("D5").Value = "OK"

-Else

-Range("D5").Value = "NG"

-End If

-End Function

-

-Function test_xlErrNum(ByRef num)

-Range("A6").Clear

-Range("B6").Clear

-Range("C6").Clear

-Range("D6").Clear

-Range("A6").Value = "xlErrNum"

-Range("B6").Value = 2036

-Range("C6").Value = num

-B6 = Range("B6").Value

-C6 = Range("C6").Value

-If B6 = C6 Then

-Range("D6").Value = "OK"

-Else

-Range("D6").Value = "NG"

-End If

-End Function

-

-Function test_xlErrRef(ByRef num)

-Range("A7").Clear

-Range("B7").Clear

-Range("C7").Clear

-Range("D7").Clear

-Range("A7").Value = "xlErrRef"

-Range("B7").Value = 2023

-Range("C7").Value = num

-B7 = Range("B7").Value

-C7 = Range("C7").Value

-If B7 = C7 Then

-Range("D7").Value = "OK"

-Else

-Range("D7").Value = "NG"

-End If

-End Function

-

-Function test_xlErrValue(ByRef num)

-Range("A8").Clear

-Range("B8").Clear

-Range("C8").Clear

-Range("D8").Clear

-Range("A8").Value = "xlErrValue"

-Range("B8").Value = 2015

-Range("C8").Value = num

-B8 = Range("B8").Value

-C8 = Range("C8").Value

-If B8 = C8 Then

-Range("D8").Value = "OK"

-Else

-Range("D8").Value = "NG"

-End If

-End Function

-

-Function test_xlCalculatedMember(ByRef num)

-Range("A9").Clear

-Range("B9").Clear

-Range("C9").Clear

-Range("D9").Clear

-Range("A9").Value = "xlCalculatedMember"

-Range("B9").Value = 0

-Range("C9").Value = num

-B9 = Range("B9").Value

-C9 = Range("C9").Value

-If B9 = C9 Then

-Range("D9").Value = "OK"

-Else

-Range("D9").Value = "NG"

-End If

-End Function

-

-Function test_xlCalculatedSet(ByRef num)

-Range("A10").Clear

-Range("B10").Clear

-Range("C10").Clear

-Range("D10").Clear

-Range("A10").Value = "xlCalculatedSet"

-Range("B10").Value = 1

-Range("C10").Value = num

-B10 = Range("B10").Value

-C10 = Range("C10").Value

-If B10 = C10 Then

-Range("D10").Value = "OK"

-Else

-Range("D10").Value = "NG"

-End If

-End Function

-

-Function test_xlCalculationAutomatic(ByRef num)

-Range("A11").Clear

-Range("B11").Clear

-Range("C11").Clear

-Range("D11").Clear

-Range("A11").Value = "xlCalculationAutomatic"

-Range("B11").Value = -4105

-Range("C11").Value = num

-B11 = Range("B11").Value

-C11 = Range("C11").Value

-If B11 = C11 Then

-Range("D11").Value = "OK"

-Else

-Range("D11").Value = "NG"

-End If

-End Function

-

-Function test_xlCalculationManual(ByRef num)

-Range("A12").Clear

-Range("B12").Clear

-Range("C12").Clear

-Range("D12").Clear

-Range("A12").Value = "xlCalculationManual"

-Range("B12").Value = -4135

-Range("C12").Value = num

-B12 = Range("B12").Value

-C12 = Range("C12").Value

-If B12 = C12 Then

-Range("D12").Value = "OK"

-Else

-Range("D12").Value = "NG"

-End If

-End Function

-

-Function test_xlCalculationSemiautomatic(ByRef num)

-Range("A13").Clear

-Range("B13").Clear

-Range("C13").Clear

-Range("D13").Clear

-Range("A13").Value = "xlCalculationSemiautomatic"

-Range("B13").Value = 2

-Range("C13").Value = num

-B13 = Range("B13").Value

-C13 = Range("C13").Value

-If B13 = C13 Then

-Range("D13").Value = "OK"

-Else

-Range("D13").Value = "NG"

-End If

-End Function

-

-Function test_xlAnyKey(ByRef num)

-Range("A14").Clear

-Range("B14").Clear

-Range("C14").Clear

-Range("D14").Clear

-Range("A14").Value = "xlAnyKey"

-Range("B14").Value = 2

-Range("C14").Value = num

-B14 = Range("B14").Value

-C14 = Range("C14").Value

-If B14 = C14 Then

-Range("D14").Value = "OK"

-Else

-Range("D14").Value = "NG"

-End If

-End Function

-

-Function test_xlEscKey(ByRef num)

-Range("A15").Clear

-Range("B15").Clear

-Range("C15").Clear

-Range("D15").Clear

-Range("A15").Value = "xlEscKey"

-Range("B15").Value = 1

-Range("C15").Value = num

-B15 = Range("B15").Value

-C15 = Range("C15").Value

-If B15 = C15 Then

-Range("D15").Value = "OK"

-Else

-Range("D15").Value = "NG"

-End If

-End Function

-

-Function test_xlNoKey(ByRef num)

-Range("A16").Clear

-Range("B16").Clear

-Range("C16").Clear

-Range("D16").Clear

-Range("A16").Value = "xlNoKey"

-Range("B16").Value = 0

-Range("C16").Value = num

-B16 = Range("B16").Value

-C16 = Range("C16").Value

-If B16 = C16 Then

-Range("D16").Value = "OK"

-Else

-Range("D16").Value = "NG"

-End If

-End Function

-

-Function test_xlCalculating(ByRef num)

-Range("A17").Clear

-Range("B17").Clear

-Range("C17").Clear

-Range("D17").Clear

-Range("A17").Value = "xlCalculating"

-Range("B17").Value = 1

-Range("C17").Value = num

-B17 = Range("B17").Value

-C17 = Range("C17").Value

-If B17 = C17 Then

-Range("D17").Value = "OK"

-Else

-Range("D17").Value = "NG"

-End If

-End Function

-

-Function test_xlDone(ByRef num)

-Range("A18").Clear

-Range("B18").Clear

-Range("C18").Clear

-Range("D18").Clear

-Range("A18").Value = "xlDone"

-Range("B18").Value = 0

-Range("C18").Value = num

-B18 = Range("B18").Value

-C18 = Range("C18").Value

-If B18 = C18 Then

-Range("D18").Value = "OK"

-Else

-Range("D18").Value = "NG"

-End If

-End Function

-

-Function test_xlPending(ByRef num)

-Range("A19").Clear

-Range("B19").Clear

-Range("C19").Clear

-Range("D19").Clear

-Range("A19").Value = "xlPending"

-Range("B19").Value = 2

-Range("C19").Value = num

-B19 = Range("B19").Value

-C19 = Range("C19").Value

-If B19 = C19 Then

-Range("D19").Value = "OK"

-Else

-Range("D19").Value = "NG"

-End If

-End Function

-

-Function test_xlAutomaticScale(ByRef num)

-Range("A20").Clear

-Range("B20").Clear

-Range("C20").Clear

-Range("D20").Clear

-Range("A20").Value = "xlAutomaticScale"

-Range("B20").Value = -4105

-Range("C20").Value = num

-B20 = Range("B20").Value

-C20 = Range("C20").Value

-If B20 = C20 Then

-Range("D20").Value = "OK"

-Else

-Range("D20").Value = "NG"

-End If

-End Function

-

-Function test_xlCategoryScale(ByRef num)

-Range("A21").Clear

-Range("B21").Clear

-Range("C21").Clear

-Range("D21").Clear

-Range("A21").Value = "xlCategoryScale"

-Range("B21").Value = 2

-Range("C21").Value = num

-B21 = Range("B21").Value

-C21 = Range("C21").Value

-If B21 = C21 Then

-Range("D21").Value = "OK"

-Else

-Range("D21").Value = "NG"

-End If

-End Function

-

-Function test_xlTimeScale(ByRef num)

-Range("A22").Clear

-Range("B22").Clear

-Range("C22").Clear

-Range("D22").Clear

-Range("A22").Value = "xlTimeScale"

-Range("B22").Value = 3

-Range("C22").Value = num

-B22 = Range("B22").Value

-C22 = Range("C22").Value

-If B22 = C22 Then

-Range("D22").Value = "OK"

-Else

-Range("D22").Value = "NG"

-End If

-End Function

-

-Function test_xlInsertDeleteCells(ByRef num)

-Range("A23").Clear

-Range("B23").Clear

-Range("C23").Clear

-Range("D23").Clear

-Range("A23").Value = "xlInsertDeleteCells"

-Range("B23").Value = 1

-Range("C23").Value = num

-B23 = Range("B23").Value

-C23 = Range("C23").Value

-If B23 = C23 Then

-Range("D23").Value = "OK"

-Else

-Range("D23").Value = "NG"

-End If

-End Function

-

-Function test_xlInsertEntireRows(ByRef num)

-Range("A24").Clear

-Range("B24").Clear

-Range("C24").Clear

-Range("D24").Clear

-Range("A24").Value = "xlInsertEntireRows"

-Range("B24").Value = 2

-Range("C24").Value = num

-B24 = Range("B24").Value

-C24 = Range("C24").Value

-If B24 = C24 Then

-Range("D24").Value = "OK"

-Else

-Range("D24").Value = "NG"

-End If

-End Function

-

-Function test_xlOverwriteCells(ByRef num)

-Range("A25").Clear

-Range("B25").Clear

-Range("C25").Clear

-Range("D25").Clear

-Range("A25").Value = "xlOverwriteCells"

-Range("B25").Value = 0

-Range("C25").Value = num

-B25 = Range("B25").Value

-C25 = Range("C25").Value

-If B25 = C25 Then

-Range("D25").Value = "OK"

-Else

-Range("D25").Value = "NG"

-End If

-End Function

-

-Function test_xlCellTypeAllFormatConditions(ByRef num)

-Range("A26").Clear

-Range("B26").Clear

-Range("C26").Clear

-Range("D26").Clear

-Range("A26").Value = "xlCellTypeAllFormatConditions"

-Range("B26").Value = -4172

-Range("C26").Value = num

-B26 = Range("B26").Value

-C26 = Range("C26").Value

-If B26 = C26 Then

-Range("D26").Value = "OK"

-Else

-Range("D26").Value = "NG"

-End If

-End Function

-

-Function test_xlCellTypeAllValidation(ByRef num)

-Range("A27").Clear

-Range("B27").Clear

-Range("C27").Clear

-Range("D27").Clear

-Range("A27").Value = "xlCellTypeAllValidation"

-Range("B27").Value = -4174

-Range("C27").Value = num

-B27 = Range("B27").Value

-C27 = Range("C27").Value

-If B27 = C27 Then

-Range("D27").Value = "OK"

-Else

-Range("D27").Value = "NG"

-End If

-End Function

-

-Function test_xlCellTypeBlanks(ByRef num)

-Range("A28").Clear

-Range("B28").Clear

-Range("C28").Clear

-Range("D28").Clear

-Range("A28").Value = "xlCellTypeBlanks"

-Range("B28").Value = 4

-Range("C28").Value = num

-B28 = Range("B28").Value

-C28 = Range("C28").Value

-If B28 = C28 Then

-Range("D28").Value = "OK"

-Else

-Range("D28").Value = "NG"

-End If

-End Function

-

-Function test_xlCellTypeComments(ByRef num)

-Range("A29").Clear

-Range("B29").Clear

-Range("C29").Clear

-Range("D29").Clear

-Range("A29").Value = "xlCellTypeComments"

-Range("B29").Value = -4144

-Range("C29").Value = num

-B29 = Range("B29").Value

-C29 = Range("C29").Value

-If B29 = C29 Then

-Range("D29").Value = "OK"

-Else

-Range("D29").Value = "NG"

-End If

-End Function

-

-Function test_xlCellTypeConstants(ByRef num)

-Range("A30").Clear

-Range("B30").Clear

-Range("C30").Clear

-Range("D30").Clear

-Range("A30").Value = "xlCellTypeConstants"

-Range("B30").Value = 2

-Range("C30").Value = num

-B30 = Range("B30").Value

-C30 = Range("C30").Value

-If B30 = C30 Then

-Range("D30").Value = "OK"

-Else

-Range("D30").Value = "NG"

-End If

-End Function

-

-Function test_xlCellTypeFormulas(ByRef num)

-Range("A31").Clear

-Range("B31").Clear

-Range("C31").Clear

-Range("D31").Clear

-Range("A31").Value = "xlCellTypeFormulas"

-Range("B31").Value = -4123

-Range("C31").Value = num

-B31 = Range("B31").Value

-C31 = Range("C31").Value

-If B31 = C31 Then

-Range("D31").Value = "OK"

-Else

-Range("D31").Value = "NG"

-End If

-End Function

-

-Function test_xlCellTypeLastCell(ByRef num)

-Range("A32").Clear

-Range("B32").Clear

-Range("C32").Clear

-Range("D32").Clear

-Range("A32").Value = "xlCellTypeLastCell"

-Range("B32").Value = 11

-Range("C32").Value = num

-B32 = Range("B32").Value

-C32 = Range("C32").Value

-If B32 = C32 Then

-Range("D32").Value = "OK"

-Else

-Range("D32").Value = "NG"

-End If

-End Function

-

-Function test_xlCellTypeSameFormatConditions(ByRef num)

-Range("A33").Clear

-Range("B33").Clear

-Range("C33").Clear

-Range("D33").Clear

-Range("A33").Value = "xlCellTypeSameFormatConditions"

-Range("B33").Value = -4173

-Range("C33").Value = num

-B33 = Range("B33").Value

-C33 = Range("C33").Value

-If B33 = C33 Then

-Range("D33").Value = "OK"

-Else

-Range("D33").Value = "NG"

-End If

-End Function

-

-Function test_xlCellTypeSameValidation(ByRef num)

-Range("A34").Clear

-Range("B34").Clear

-Range("C34").Clear

-Range("D34").Clear

-Range("A34").Value = "xlCellTypeSameValidation"

-Range("B34").Value = -4175

-Range("C34").Value = num

-B34 = Range("B34").Value

-C34 = Range("C34").Value

-If B34 = C34 Then

-Range("D34").Value = "OK"

-Else

-Range("D34").Value = "NG"

-End If

-End Function

-

-Function test_xlCellTypeVisible(ByRef num)

-Range("A35").Clear

-Range("B35").Clear

-Range("C35").Clear

-Range("D35").Clear

-Range("A35").Value = "xlCellTypeVisible"

-Range("B35").Value = 12

-Range("C35").Value = num

-B35 = Range("B35").Value

-C35 = Range("C35").Value

-If B35 = C35 Then

-Range("D35").Value = "OK"

-Else

-Range("D35").Value = "NG"

-End If

-End Function

-

-Function test_xlAnyGallery(ByRef num)

-Range("A36").Clear

-Range("B36").Clear

-Range("C36").Clear

-Range("D36").Clear

-Range("A36").Value = "xlAnyGallery"

-Range("B36").Value = 23

-Range("C36").Value = num

-B36 = Range("B36").Value

-C36 = Range("C36").Value

-If B36 = C36 Then

-Range("D36").Value = "OK"

-Else

-Range("D36").Value = "NG"

-End If

-End Function

-

-Function test_xlBuildIn(ByRef num)

-Range("A37").Clear

-Range("B37").Clear

-Range("C37").Clear

-Range("D37").Clear

-Range("A37").Value = "xlBuildIn"

-Range("B37").Value = 21

-Range("C37").Value = num

-B37 = Range("B37").Value

-C37 = Range("C37").Value

-If B37 = C37 Then

-Range("D37").Value = "OK"

-Else

-Range("D37").Value = "NG"

-End If

-End Function

-

-Function test_xlUserDefined(ByRef num)

-Range("A38").Clear

-Range("B38").Clear

-Range("C38").Clear

-Range("D38").Clear

-Range("A38").Value = "xlUserDefined"

-Range("B38").Value = 22

-Range("C38").Value = num

-B38 = Range("B38").Value

-C38 = Range("C38").Value

-If B38 = C38 Then

-Range("D38").Value = "OK"

-Else

-Range("D38").Value = "NG"

-End If

-End Function

-

-Function test_xlAxis(ByRef num)

-Range("A39").Clear

-Range("B39").Clear

-Range("C39").Clear

-Range("D39").Clear

-Range("A39").Value = "xlAxis"

-Range("B39").Value = 21

-Range("C39").Value = num

-B39 = Range("B39").Value

-C39 = Range("C39").Value

-If B39 = C39 Then

-Range("D39").Value = "OK"

-Else

-Range("D39").Value = "NG"

-End If

-End Function

-

-Function test_xlAxisTitle(ByRef num)

-Range("A40").Clear

-Range("B40").Clear

-Range("C40").Clear

-Range("D40").Clear

-Range("A40").Value = "xlAxisTitle"

-Range("B40").Value = 17

-Range("C40").Value = num

-B40 = Range("B40").Value

-C40 = Range("C40").Value

-If B40 = C40 Then

-Range("D40").Value = "OK"

-Else

-Range("D40").Value = "NG"

-End If

-End Function

-

-Function test_xlChartTitle(ByRef num)

-Range("A41").Clear

-Range("B41").Clear

-Range("C41").Clear

-Range("D41").Clear

-Range("A41").Value = "xlChartTitle"

-Range("B41").Value = 4

-Range("C41").Value = num

-B41 = Range("B41").Value

-C41 = Range("C41").Value

-If B41 = C41 Then

-Range("D41").Value = "OK"

-Else

-Range("D41").Value = "NG"

-End If

-End Function

-

-Function test_xlCorners(ByRef num)

-Range("A42").Clear

-Range("B42").Clear

-Range("C42").Clear

-Range("D42").Clear

-Range("A42").Value = "xlCorners"

-Range("B42").Value = 6

-Range("C42").Value = num

-B42 = Range("B42").Value

-C42 = Range("C42").Value

-If B42 = C42 Then

-Range("D42").Value = "OK"

-Else

-Range("D42").Value = "NG"

-End If

-End Function

-

-Function test_xlDataLabel(ByRef num)

-Range("A43").Clear

-Range("B43").Clear

-Range("C43").Clear

-Range("D43").Clear

-Range("A43").Value = "xlDataLabel"

-Range("B43").Value = 0

-Range("C43").Value = num

-B43 = Range("B43").Value

-C43 = Range("C43").Value

-If B43 = C43 Then

-Range("D43").Value = "OK"

-Else

-Range("D43").Value = "NG"

-End If

-End Function

-

-Function test_xlDataTable(ByRef num)

-Range("A44").Clear

-Range("B44").Clear

-Range("C44").Clear

-Range("D44").Clear

-Range("A44").Value = "xlDataTable"

-Range("B44").Value = 0

-Range("C44").Value = num

-B44 = Range("B44").Value

-C44 = Range("C44").Value

-If B44 = C44 Then

-Range("D44").Value = "OK"

-Else

-Range("D44").Value = "NG"

-End If

-End Function

-

-Function test_xlDisplayUnitLabel(ByRef num)

-Range("A45").Clear

-Range("B45").Clear

-Range("C45").Clear

-Range("D45").Clear

-Range("A45").Value = "xlDisplayUnitLabel"

-Range("B45").Value = 30

-Range("C45").Value = num

-B45 = Range("B45").Value

-C45 = Range("C45").Value

-If B45 = C45 Then

-Range("D45").Value = "OK"

-Else

-Range("D45").Value = "NG"

-End If

-End Function

-

-Function test_xlDownBars(ByRef num)

-Range("A46").Clear

-Range("B46").Clear

-Range("C46").Clear

-Range("D46").Clear

-Range("A46").Value = "xlDownBars"

-Range("B46").Value = 20

-Range("C46").Value = num

-B46 = Range("B46").Value

-C46 = Range("C46").Value

-If B46 = C46 Then

-Range("D46").Value = "OK"

-Else

-Range("D46").Value = "NG"

-End If

-End Function

-

-Function test_xlDropLines(ByRef num)

-Range("A47").Clear

-Range("B47").Clear

-Range("C47").Clear

-Range("D47").Clear

-Range("A47").Value = "xlDropLines"

-Range("B47").Value = 26

-Range("C47").Value = num

-B47 = Range("B47").Value

-C47 = Range("C47").Value

-If B47 = C47 Then

-Range("D47").Value = "OK"

-Else

-Range("D47").Value = "NG"

-End If

-End Function

-

-Function test_xlErrorBars(ByRef num)

-Range("A48").Clear

-Range("B48").Clear

-Range("C48").Clear

-Range("D48").Clear

-Range("A48").Value = "xlErrorBars"

-Range("B48").Value = 9

-Range("C48").Value = num

-B48 = Range("B48").Value

-C48 = Range("C48").Value

-If B48 = C48 Then

-Range("D48").Value = "OK"

-Else

-Range("D48").Value = "NG"

-End If

-End Function

-

-Function test_xlFloor(ByRef num)

-Range("A49").Clear

-Range("B49").Clear

-Range("C49").Clear

-Range("D49").Clear

-Range("A49").Value = "xlFloor"

-Range("B49").Value = 23

-Range("C49").Value = num

-B49 = Range("B49").Value

-C49 = Range("C49").Value

-If B49 = C49 Then

-Range("D49").Value = "OK"

-Else

-Range("D49").Value = "NG"

-End If

-End Function

-

-Function test_xlHiLoLines(ByRef num)

-Range("A50").Clear

-Range("B50").Clear

-Range("C50").Clear

-Range("D50").Clear

-Range("A50").Value = "xlHiLoLines"

-Range("B50").Value = 25

-Range("C50").Value = num

-B50 = Range("B50").Value

-C50 = Range("C50").Value

-If B50 = C50 Then

-Range("D50").Value = "OK"

-Else

-Range("D50").Value = "NG"

-End If

-End Function

-

-Function test_xlLeaderLines(ByRef num)

-Range("A51").Clear

-Range("B51").Clear

-Range("C51").Clear

-Range("D51").Clear

-Range("A51").Value = "xlLeaderLines"

-Range("B51").Value = 29

-Range("C51").Value = num

-B51 = Range("B51").Value

-C51 = Range("C51").Value

-If B51 = C51 Then

-Range("D51").Value = "OK"

-Else

-Range("D51").Value = "NG"

-End If

-End Function

-

-Function test_xlLegend(ByRef num)

-Range("A52").Clear

-Range("B52").Clear

-Range("C52").Clear

-Range("D52").Clear

-Range("A52").Value = "xlLegend"

-Range("B52").Value = 24

-Range("C52").Value = num

-B52 = Range("B52").Value

-C52 = Range("C52").Value

-If B52 = C52 Then

-Range("D52").Value = "OK"

-Else

-Range("D52").Value = "NG"

-End If

-End Function

-

-Function test_xlLegendEntry(ByRef num)

-Range("A53").Clear

-Range("B53").Clear

-Range("C53").Clear

-Range("D53").Clear

-Range("A53").Value = "xlLegendEntry"

-Range("B53").Value = 12

-Range("C53").Value = num

-B53 = Range("B53").Value

-C53 = Range("C53").Value

-If B53 = C53 Then

-Range("D53").Value = "OK"

-Else

-Range("D53").Value = "NG"

-End If

-End Function

-

-Function test_xlLegendKey(ByRef num)

-Range("A54").Clear

-Range("B54").Clear

-Range("C54").Clear

-Range("D54").Clear

-Range("A54").Value = "xlLegendKey"

-Range("B54").Value = 13

-Range("C54").Value = num

-B54 = Range("B54").Value

-C54 = Range("C54").Value

-If B54 = C54 Then

-Range("D54").Value = "OK"

-Else

-Range("D54").Value = "NG"

-End If

-End Function

-

-Function test_xlMajorGridlines(ByRef num)

-Range("A55").Clear

-Range("B55").Clear

-Range("C55").Clear

-Range("D55").Clear

-Range("A55").Value = "xlMajorGridlines"

-Range("B55").Value = 15

-Range("C55").Value = num

-B55 = Range("B55").Value

-C55 = Range("C55").Value

-If B55 = C55 Then

-Range("D55").Value = "OK"

-Else

-Range("D55").Value = "NG"

-End If

-End Function

-

-Function test_xlMinorGridlines(ByRef num)

-Range("A56").Clear

-Range("B56").Clear

-Range("C56").Clear

-Range("D56").Clear

-Range("A56").Value = "xlMinorGridlines"

-Range("B56").Value = 16

-Range("C56").Value = num

-B56 = Range("B56").Value

-C56 = Range("C56").Value

-If B56 = C56 Then

-Range("D56").Value = "OK"

-Else

-Range("D56").Value = "NG"

-End If

-End Function

-

-Function test_xlNothing(ByRef num)

-Range("A57").Clear

-Range("B57").Clear

-Range("C57").Clear

-Range("D57").Clear

-Range("A57").Value = "xlNothing"

-Range("B57").Value = 28

-Range("C57").Value = num

-B57 = Range("B57").Value

-C57 = Range("C57").Value

-If B57 = C57 Then

-Range("D57").Value = "OK"

-Else

-Range("D57").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotChartDropZone(ByRef num)

-Range("A58").Clear

-Range("B58").Clear

-Range("C58").Clear

-Range("D58").Clear

-Range("A58").Value = "xlPivotChartDropZone"

-Range("B58").Value = 32

-Range("C58").Value = num

-B58 = Range("B58").Value

-C58 = Range("C58").Value

-If B58 = C58 Then

-Range("D58").Value = "OK"

-Else

-Range("D58").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotChartFieldButton(ByRef num)

-Range("A59").Clear

-Range("B59").Clear

-Range("C59").Clear

-Range("D59").Clear

-Range("A59").Value = "xlPivotChartFieldButton"

-Range("B59").Value = 31

-Range("C59").Value = num

-B59 = Range("B59").Value

-C59 = Range("C59").Value

-If B59 = C59 Then

-Range("D59").Value = "OK"

-Else

-Range("D59").Value = "NG"

-End If

-End Function

-

-Function test_xlPlotArea(ByRef num)

-Range("A60").Clear

-Range("B60").Clear

-Range("C60").Clear

-Range("D60").Clear

-Range("A60").Value = "xlPlotArea"

-Range("B60").Value = 19

-Range("C60").Value = num

-B60 = Range("B60").Value

-C60 = Range("C60").Value

-If B60 = C60 Then

-Range("D60").Value = "OK"

-Else

-Range("D60").Value = "NG"

-End If

-End Function

-

-Function test_xlRaderAxisLabels(ByRef num)

-Range("A61").Clear

-Range("B61").Clear

-Range("C61").Clear

-Range("D61").Clear

-Range("A61").Value = "xlRaderAxisLabels"

-Range("B61").Value = 27

-Range("C61").Value = num

-B61 = Range("B61").Value

-C61 = Range("C61").Value

-If B61 = C61 Then

-Range("D61").Value = "OK"

-Else

-Range("D61").Value = "NG"

-End If

-End Function

-

-Function test_xlSeries(ByRef num)

-Range("A62").Clear

-Range("B62").Clear

-Range("C62").Clear

-Range("D62").Clear

-Range("A62").Value = "xlSeries"

-Range("B62").Value = 3

-Range("C62").Value = num

-B62 = Range("B62").Value

-C62 = Range("C62").Value

-If B62 = C62 Then

-Range("D62").Value = "OK"

-Else

-Range("D62").Value = "NG"

-End If

-End Function

-

-Function test_xlSeriesLines(ByRef num)

-Range("A63").Clear

-Range("B63").Clear

-Range("C63").Clear

-Range("D63").Clear

-Range("A63").Value = "xlSeriesLines"

-Range("B63").Value = 22

-Range("C63").Value = num

-B63 = Range("B63").Value

-C63 = Range("C63").Value

-If B63 = C63 Then

-Range("D63").Value = "OK"

-Else

-Range("D63").Value = "NG"

-End If

-End Function

-

-Function test_xlShape(ByRef num)

-Range("A64").Clear

-Range("B64").Clear

-Range("C64").Clear

-Range("D64").Clear

-Range("A64").Value = "xlShape"

-Range("B64").Value = 14

-Range("C64").Value = num

-B64 = Range("B64").Value

-C64 = Range("C64").Value

-If B64 = C64 Then

-Range("D64").Value = "OK"

-Else

-Range("D64").Value = "NG"

-End If

-End Function

-

-Function test_xlTrendline(ByRef num)

-Range("A65").Clear

-Range("B65").Clear

-Range("C65").Clear

-Range("D65").Clear

-Range("A65").Value = "xlTrendline"

-Range("B65").Value = 8

-Range("C65").Value = num

-B65 = Range("B65").Value

-C65 = Range("C65").Value

-If B65 = C65 Then

-Range("D65").Value = "OK"

-Else

-Range("D65").Value = "NG"

-End If

-End Function

-

-Function test_xlUpBars(ByRef num)

-Range("A66").Clear

-Range("B66").Clear

-Range("C66").Clear

-Range("D66").Clear

-Range("A66").Value = "xlUpBars"

-Range("B66").Value = 18

-Range("C66").Value = num

-B66 = Range("B66").Value

-C66 = Range("C66").Value

-If B66 = C66 Then

-Range("D66").Value = "OK"

-Else

-Range("D66").Value = "NG"

-End If

-End Function

-

-Function test_xlWalls(ByRef num)

-Range("A67").Clear

-Range("B67").Clear

-Range("C67").Clear

-Range("D67").Clear

-Range("A67").Value = "xlWalls"

-Range("B67").Value = 5

-Range("C67").Value = num

-B67 = Range("B67").Value

-C67 = Range("C67").Value

-If B67 = C67 Then

-Range("D67").Value = "OK"

-Else

-Range("D67").Value = "NG"

-End If

-End Function

-

-Function test_xlXErrorBars(ByRef num)

-Range("A68").Clear

-Range("B68").Clear

-Range("C68").Clear

-Range("D68").Clear

-Range("A68").Value = "xlXErrorBars"

-Range("B68").Value = 10

-Range("C68").Value = num

-B68 = Range("B68").Value

-C68 = Range("C68").Value

-If B68 = C68 Then

-Range("D68").Value = "OK"

-Else

-Range("D68").Value = "NG"

-End If

-End Function

-

-Function test_xlYErrorBars(ByRef num)

-Range("A69").Clear

-Range("B69").Clear

-Range("C69").Clear

-Range("D69").Clear

-Range("A69").Value = "xlYErrorBars"

-Range("B69").Value = 11

-Range("C69").Value = num

-B69 = Range("B69").Value

-C69 = Range("C69").Value

-If B69 = C69 Then

-Range("D69").Value = "OK"

-Else

-Range("D69").Value = "NG"

-End If

-End Function

-

-Function test_xlLocationAsNewSheet(ByRef num)

-Range("A70").Clear

-Range("B70").Clear

-Range("C70").Clear

-Range("D70").Clear

-Range("A70").Value = "xlLocationAsNewSheet"

-Range("B70").Value = 1

-Range("C70").Value = num

-B70 = Range("B70").Value

-C70 = Range("C70").Value

-If B70 = C70 Then

-Range("D70").Value = "OK"

-Else

-Range("D70").Value = "NG"

-End If

-End Function

-

-Function test_xlLocationAsObject(ByRef num)

-Range("A71").Clear

-Range("B71").Clear

-Range("C71").Clear

-Range("D71").Clear

-Range("A71").Value = "xlLocationAsObject"

-Range("B71").Value = 2

-Range("C71").Value = num

-B71 = Range("B71").Value

-C71 = Range("C71").Value

-If B71 = C71 Then

-Range("D71").Value = "OK"

-Else

-Range("D71").Value = "NG"

-End If

-End Function

-

-Function test_xlLocationAutomatic(ByRef num)

-Range("A72").Clear

-Range("B72").Clear

-Range("C72").Clear

-Range("D72").Clear

-Range("A72").Value = "xlLocationAutomatic"

-Range("B72").Value = 3

-Range("C72").Value = num

-B72 = Range("B72").Value

-C72 = Range("C72").Value

-If B72 = C72 Then

-Range("D72").Value = "OK"

-Else

-Range("D72").Value = "NG"

-End If

-End Function

-

-Function test_xlAllFaces(ByRef num)

-Range("A73").Clear

-Range("B73").Clear

-Range("C73").Clear

-Range("D73").Clear

-Range("A73").Value = "xlAllFaces"

-Range("B73").Value = 7

-Range("C73").Value = num

-B73 = Range("B73").Value

-C73 = Range("C73").Value

-If B73 = C73 Then

-Range("D73").Value = "OK"

-Else

-Range("D73").Value = "NG"

-End If

-End Function

-

-Function test_xlEnd(ByRef num)

-Range("A74").Clear

-Range("B74").Clear

-Range("C74").Clear

-Range("D74").Clear

-Range("A74").Value = "xlEnd"

-Range("B74").Value = 2

-Range("C74").Value = num

-B74 = Range("B74").Value

-C74 = Range("C74").Value

-If B74 = C74 Then

-Range("D74").Value = "OK"

-Else

-Range("D74").Value = "NG"

-End If

-End Function

-

-Function test_xlEndSides(ByRef num)

-Range("A75").Clear

-Range("B75").Clear

-Range("C75").Clear

-Range("D75").Clear

-Range("A75").Value = "xlEndSides"

-Range("B75").Value = 3

-Range("C75").Value = num

-B75 = Range("B75").Value

-C75 = Range("C75").Value

-If B75 = C75 Then

-Range("D75").Value = "OK"

-Else

-Range("D75").Value = "NG"

-End If

-End Function

-

-Function test_xlFront(ByRef num)

-Range("A76").Clear

-Range("B76").Clear

-Range("C76").Clear

-Range("D76").Clear

-Range("A76").Value = "xlFront"

-Range("B76").Value = 4

-Range("C76").Value = num

-B76 = Range("B76").Value

-C76 = Range("C76").Value

-If B76 = C76 Then

-Range("D76").Value = "OK"

-Else

-Range("D76").Value = "NG"

-End If

-End Function

-

-Function test_xlFrontEnd(ByRef num)

-Range("A77").Clear

-Range("B77").Clear

-Range("C77").Clear

-Range("D77").Clear

-Range("A77").Value = "xlFrontEnd"

-Range("B77").Value = 6

-Range("C77").Value = num

-B77 = Range("B77").Value

-C77 = Range("C77").Value

-If B77 = C77 Then

-Range("D77").Value = "OK"

-Else

-Range("D77").Value = "NG"

-End If

-End Function

-

-Function test_xlFrontSides(ByRef num)

-Range("A78").Clear

-Range("B78").Clear

-Range("C78").Clear

-Range("D78").Clear

-Range("A78").Value = "xlFrontSides"

-Range("B78").Value = 5

-Range("C78").Value = num

-B78 = Range("B78").Value

-C78 = Range("C78").Value

-If B78 = C78 Then

-Range("D78").Value = "OK"

-Else

-Range("D78").Value = "NG"

-End If

-End Function

-

-Function test_xlSlides(ByRef num)

-Range("A79").Clear

-Range("B79").Clear

-Range("C79").Clear

-Range("D79").Clear

-Range("A79").Value = "xlSlides"

-Range("B79").Value = 1

-Range("C79").Value = num

-B79 = Range("B79").Value

-C79 = Range("C79").Value

-If B79 = C79 Then

-Range("D79").Value = "OK"

-Else

-Range("D79").Value = "NG"

-End If

-End Function

-

-Function test_xlStack(ByRef num)

-Range("A80").Clear

-Range("B80").Clear

-Range("C80").Clear

-Range("D80").Clear

-Range("A80").Value = "xlStack"

-Range("B80").Value = 2

-Range("C80").Value = num

-B80 = Range("B80").Value

-C80 = Range("C80").Value

-If B80 = C80 Then

-Range("D80").Value = "OK"

-Else

-Range("D80").Value = "NG"

-End If

-End Function

-

-Function test_xlStackScale(ByRef num)

-Range("A81").Clear

-Range("B81").Clear

-Range("C81").Clear

-Range("D81").Clear

-Range("A81").Value = "xlStackScale"

-Range("B81").Value = 3

-Range("C81").Value = num

-B81 = Range("B81").Value

-C81 = Range("C81").Value

-If B81 = C81 Then

-Range("D81").Value = "OK"

-Else

-Range("D81").Value = "NG"

-End If

-End Function

-

-Function test_xlStretch(ByRef num)

-Range("A82").Clear

-Range("B82").Clear

-Range("C82").Clear

-Range("D82").Clear

-Range("A82").Value = "xlStretch"

-Range("B82").Value = 1

-Range("C82").Value = num

-B82 = Range("B82").Value

-C82 = Range("C82").Value

-If B82 = C82 Then

-Range("D82").Value = "OK"

-Else

-Range("D82").Value = "NG"

-End If

-End Function

-

-Function test_xlSplitByCustomSplit(ByRef num)

-Range("A83").Clear

-Range("B83").Clear

-Range("C83").Clear

-Range("D83").Clear

-Range("A83").Value = "xlSplitByCustomSplit"

-Range("B83").Value = 4

-Range("C83").Value = num

-B83 = Range("B83").Value

-C83 = Range("C83").Value

-If B83 = C83 Then

-Range("D83").Value = "OK"

-Else

-Range("D83").Value = "NG"

-End If

-End Function

-

-Function test_xlSplitByPercentValue(ByRef num)

-Range("A84").Clear

-Range("B84").Clear

-Range("C84").Clear

-Range("D84").Clear

-Range("A84").Value = "xlSplitByPercentValue"

-Range("B84").Value = 3

-Range("C84").Value = num

-B84 = Range("B84").Value

-C84 = Range("C84").Value

-If B84 = C84 Then

-Range("D84").Value = "OK"

-Else

-Range("D84").Value = "NG"

-End If

-End Function

-

-Function test_xlSplitByPercentPosition(ByRef num)

-Range("A85").Clear

-Range("B85").Clear

-Range("C85").Clear

-Range("D85").Clear

-Range("A85").Value = "xlSplitByPercentPosition"

-Range("B85").Value = 1

-Range("C85").Value = num

-B85 = Range("B85").Value

-C85 = Range("C85").Value

-If B85 = C85 Then

-Range("D85").Value = "OK"

-Else

-Range("D85").Value = "NG"

-End If

-End Function

-

-Function test_xlSplitByValue(ByRef num)

-Range("A86").Clear

-Range("B86").Clear

-Range("C86").Clear

-Range("D86").Clear

-Range("A86").Value = "xlSplitByValue"

-Range("B86").Value = 2

-Range("C86").Value = num

-B86 = Range("B86").Value

-C86 = Range("C86").Value

-If B86 = C86 Then

-Range("D86").Value = "OK"

-Else

-Range("D86").Value = "NG"

-End If

-End Function

-

-Function test_xl3DArea(ByRef num)

-Range("A87").Clear

-Range("B87").Clear

-Range("C87").Clear

-Range("D87").Clear

-Range("A87").Value = "xl3DArea"

-Range("B87").Value = -4098

-Range("C87").Value = num

-B87 = Range("B87").Value

-C87 = Range("C87").Value

-If B87 = C87 Then

-Range("D87").Value = "OK"

-Else

-Range("D87").Value = "NG"

-End If

-End Function

-

-Function test_xl3DAreaStacked(ByRef num)

-Range("A88").Clear

-Range("B88").Clear

-Range("C88").Clear

-Range("D88").Clear

-Range("A88").Value = "xl3DAreaStacked"

-Range("B88").Value = 78

-Range("C88").Value = num

-B88 = Range("B88").Value

-C88 = Range("C88").Value

-If B88 = C88 Then

-Range("D88").Value = "OK"

-Else

-Range("D88").Value = "NG"

-End If

-End Function

-

-Function test_xl3DAreaStacked100(ByRef num)

-Range("A89").Clear

-Range("B89").Clear

-Range("C89").Clear

-Range("D89").Clear

-Range("A89").Value = "xl3DAreaStacked100"

-Range("B89").Value = 79

-Range("C89").Value = num

-B89 = Range("B89").Value

-C89 = Range("C89").Value

-If B89 = C89 Then

-Range("D89").Value = "OK"

-Else

-Range("D89").Value = "NG"

-End If

-End Function

-

-Function test_xl3DBarClustered(ByRef num)

-Range("A90").Clear

-Range("B90").Clear

-Range("C90").Clear

-Range("D90").Clear

-Range("A90").Value = "xl3DBarClustered"

-Range("B90").Value = 60

-Range("C90").Value = num

-B90 = Range("B90").Value

-C90 = Range("C90").Value

-If B90 = C90 Then

-Range("D90").Value = "OK"

-Else

-Range("D90").Value = "NG"

-End If

-End Function

-

-Function test_xl3DBarStacked(ByRef num)

-Range("A91").Clear

-Range("B91").Clear

-Range("C91").Clear

-Range("D91").Clear

-Range("A91").Value = "xl3DBarStacked"

-Range("B91").Value = 61

-Range("C91").Value = num

-B91 = Range("B91").Value

-C91 = Range("C91").Value

-If B91 = C91 Then

-Range("D91").Value = "OK"

-Else

-Range("D91").Value = "NG"

-End If

-End Function

-

-Function test_xl3DBarStacked100(ByRef num)

-Range("A92").Clear

-Range("B92").Clear

-Range("C92").Clear

-Range("D92").Clear

-Range("A92").Value = "xl3DBarStacked100"

-Range("B92").Value = 62

-Range("C92").Value = num

-B92 = Range("B92").Value

-C92 = Range("C92").Value

-If B92 = C92 Then

-Range("D92").Value = "OK"

-Else

-Range("D92").Value = "NG"

-End If

-End Function

-

-Function test_xl3DColumn(ByRef num)

-Range("A93").Clear

-Range("B93").Clear

-Range("C93").Clear

-Range("D93").Clear

-Range("A93").Value = "xl3DColumn"

-Range("B93").Value = -4100

-Range("C93").Value = num

-B93 = Range("B93").Value

-C93 = Range("C93").Value

-If B93 = C93 Then

-Range("D93").Value = "OK"

-Else

-Range("D93").Value = "NG"

-End If

-End Function

-

-Function test_xl3DColumnClustered(ByRef num)

-Range("A94").Clear

-Range("B94").Clear

-Range("C94").Clear

-Range("D94").Clear

-Range("A94").Value = "xl3DColumnClustered"

-Range("B94").Value = 54

-Range("C94").Value = num

-B94 = Range("B94").Value

-C94 = Range("C94").Value

-If B94 = C94 Then

-Range("D94").Value = "OK"

-Else

-Range("D94").Value = "NG"

-End If

-End Function

-

-Function test_xl3DColumnStacked(ByRef num)

-Range("A95").Clear

-Range("B95").Clear

-Range("C95").Clear

-Range("D95").Clear

-Range("A95").Value = "xl3DColumnStacked"

-Range("B95").Value = 55

-Range("C95").Value = num

-B95 = Range("B95").Value

-C95 = Range("C95").Value

-If B95 = C95 Then

-Range("D95").Value = "OK"

-Else

-Range("D95").Value = "NG"

-End If

-End Function

-

-Function test_xl3DColumnStacked100(ByRef num)

-Range("A96").Clear

-Range("B96").Clear

-Range("C96").Clear

-Range("D96").Clear

-Range("A96").Value = "xl3DColumnStacked100"

-Range("B96").Value = 56

-Range("C96").Value = num

-B96 = Range("B96").Value

-C96 = Range("C96").Value

-If B96 = C96 Then

-Range("D96").Value = "OK"

-Else

-Range("D96").Value = "NG"

-End If

-End Function

-

-Function test_xl3DLine(ByRef num)

-Range("A97").Clear

-Range("B97").Clear

-Range("C97").Clear

-Range("D97").Clear

-Range("A97").Value = "xl3DLine"

-Range("B97").Value = -4101

-Range("C97").Value = num

-B97 = Range("B97").Value

-C97 = Range("C97").Value

-If B97 = C97 Then

-Range("D97").Value = "OK"

-Else

-Range("D97").Value = "NG"

-End If

-End Function

-

-Function test_xl3DPie(ByRef num)

-Range("A98").Clear

-Range("B98").Clear

-Range("C98").Clear

-Range("D98").Clear

-Range("A98").Value = "xl3DPie"

-Range("B98").Value = -4102

-Range("C98").Value = num

-B98 = Range("B98").Value

-C98 = Range("C98").Value

-If B98 = C98 Then

-Range("D98").Value = "OK"

-Else

-Range("D98").Value = "NG"

-End If

-End Function

-

-Function test_xl3DPieExploded(ByRef num)

-Range("A99").Clear

-Range("B99").Clear

-Range("C99").Clear

-Range("D99").Clear

-Range("A99").Value = "xl3DPieExploded"

-Range("B99").Value = 70

-Range("C99").Value = num

-B99 = Range("B99").Value

-C99 = Range("C99").Value

-If B99 = C99 Then

-Range("D99").Value = "OK"

-Else

-Range("D99").Value = "NG"

-End If

-End Function

-

-Function test_xlArea(ByRef num)

-Range("A100").Clear

-Range("B100").Clear

-Range("C100").Clear

-Range("D100").Clear

-Range("A100").Value = "xlArea"

-Range("B100").Value = 1

-Range("C100").Value = num

-B100 = Range("B100").Value

-C100 = Range("C100").Value

-If B100 = C100 Then

-Range("D100").Value = "OK"

-Else

-Range("D100").Value = "NG"

-End If

-End Function

-

-Function test_xlAreaStacked(ByRef num)

-Range("A101").Clear

-Range("B101").Clear

-Range("C101").Clear

-Range("D101").Clear

-Range("A101").Value = "xlAreaStacked"

-Range("B101").Value = 76

-Range("C101").Value = num

-B101 = Range("B101").Value

-C101 = Range("C101").Value

-If B101 = C101 Then

-Range("D101").Value = "OK"

-Else

-Range("D101").Value = "NG"

-End If

-End Function

-

-Function test_xlAreaStacked100(ByRef num)

-Range("A102").Clear

-Range("B102").Clear

-Range("C102").Clear

-Range("D102").Clear

-Range("A102").Value = "xlAreaStacked100"

-Range("B102").Value = 77

-Range("C102").Value = num

-B102 = Range("B102").Value

-C102 = Range("C102").Value

-If B102 = C102 Then

-Range("D102").Value = "OK"

-Else

-Range("D102").Value = "NG"

-End If

-End Function

-

-Function test_xlBarClustered(ByRef num)

-Range("A103").Clear

-Range("B103").Clear

-Range("C103").Clear

-Range("D103").Clear

-Range("A103").Value = "xlBarClustered"

-Range("B103").Value = 57

-Range("C103").Value = num

-B103 = Range("B103").Value

-C103 = Range("C103").Value

-If B103 = C103 Then

-Range("D103").Value = "OK"

-Else

-Range("D103").Value = "NG"

-End If

-End Function

-

-Function test_xlBarOfPie(ByRef num)

-Range("A104").Clear

-Range("B104").Clear

-Range("C104").Clear

-Range("D104").Clear

-Range("A104").Value = "xlBarOfPie"

-Range("B104").Value = 71

-Range("C104").Value = num

-B104 = Range("B104").Value

-C104 = Range("C104").Value

-If B104 = C104 Then

-Range("D104").Value = "OK"

-Else

-Range("D104").Value = "NG"

-End If

-End Function

-

-Function test_xlBarStacked(ByRef num)

-Range("A105").Clear

-Range("B105").Clear

-Range("C105").Clear

-Range("D105").Clear

-Range("A105").Value = "xlBarStacked"

-Range("B105").Value = 58

-Range("C105").Value = num

-B105 = Range("B105").Value

-C105 = Range("C105").Value

-If B105 = C105 Then

-Range("D105").Value = "OK"

-Else

-Range("D105").Value = "NG"

-End If

-End Function

-

-Function test_xlBarStacked100(ByRef num)

-Range("A106").Clear

-Range("B106").Clear

-Range("C106").Clear

-Range("D106").Clear

-Range("A106").Value = "xlBarStacked100"

-Range("B106").Value = 59

-Range("C106").Value = num

-B106 = Range("B106").Value

-C106 = Range("C106").Value

-If B106 = C106 Then

-Range("D106").Value = "OK"

-Else

-Range("D106").Value = "NG"

-End If

-End Function

-

-Function test_xlBubble(ByRef num)

-Range("A107").Clear

-Range("B107").Clear

-Range("C107").Clear

-Range("D107").Clear

-Range("A107").Value = "xlBubble"

-Range("B107").Value = 15

-Range("C107").Value = num

-B107 = Range("B107").Value

-C107 = Range("C107").Value

-If B107 = C107 Then

-Range("D107").Value = "OK"

-Else

-Range("D107").Value = "NG"

-End If

-End Function

-

-Function test_xlBubble3DEffect(ByRef num)

-Range("A108").Clear

-Range("B108").Clear

-Range("C108").Clear

-Range("D108").Clear

-Range("A108").Value = "xlBubble3DEffect"

-Range("B108").Value = 87

-Range("C108").Value = num

-B108 = Range("B108").Value

-C108 = Range("C108").Value

-If B108 = C108 Then

-Range("D108").Value = "OK"

-Else

-Range("D108").Value = "NG"

-End If

-End Function

-

-Function test_xlColumnClustered(ByRef num)

-Range("A109").Clear

-Range("B109").Clear

-Range("C109").Clear

-Range("D109").Clear

-Range("A109").Value = "xlColumnClustered"

-Range("B109").Value = 51

-Range("C109").Value = num

-B109 = Range("B109").Value

-C109 = Range("C109").Value

-If B109 = C109 Then

-Range("D109").Value = "OK"

-Else

-Range("D109").Value = "NG"

-End If

-End Function

-

-Function test_xlColumnStacked(ByRef num)

-Range("A110").Clear

-Range("B110").Clear

-Range("C110").Clear

-Range("D110").Clear

-Range("A110").Value = "xlColumnStacked"

-Range("B110").Value = 52

-Range("C110").Value = num

-B110 = Range("B110").Value

-C110 = Range("C110").Value

-If B110 = C110 Then

-Range("D110").Value = "OK"

-Else

-Range("D110").Value = "NG"

-End If

-End Function

-

-Function test_xlColumnStacked100(ByRef num)

-Range("A111").Clear

-Range("B111").Clear

-Range("C111").Clear

-Range("D111").Clear

-Range("A111").Value = "xlColumnStacked100"

-Range("B111").Value = 53

-Range("C111").Value = num

-B111 = Range("B111").Value

-C111 = Range("C111").Value

-If B111 = C111 Then

-Range("D111").Value = "OK"

-Else

-Range("D111").Value = "NG"

-End If

-End Function

-

-Function test_xlConeBarClustered(ByRef num)

-Range("A112").Clear

-Range("B112").Clear

-Range("C112").Clear

-Range("D112").Clear

-Range("A112").Value = "xlConeBarClustered"

-Range("B112").Value = 102

-Range("C112").Value = num

-B112 = Range("B112").Value

-C112 = Range("C112").Value

-If B112 = C112 Then

-Range("D112").Value = "OK"

-Else

-Range("D112").Value = "NG"

-End If

-End Function

-

-Function test_xlConeBarStacked(ByRef num)

-Range("A113").Clear

-Range("B113").Clear

-Range("C113").Clear

-Range("D113").Clear

-Range("A113").Value = "xlConeBarStacked"

-Range("B113").Value = 103

-Range("C113").Value = num

-B113 = Range("B113").Value

-C113 = Range("C113").Value

-If B113 = C113 Then

-Range("D113").Value = "OK"

-Else

-Range("D113").Value = "NG"

-End If

-End Function

-

-Function test_xlConeBarStacked100(ByRef num)

-Range("A114").Clear

-Range("B114").Clear

-Range("C114").Clear

-Range("D114").Clear

-Range("A114").Value = "xlConeBarStacked100"

-Range("B114").Value = 104

-Range("C114").Value = num

-B114 = Range("B114").Value

-C114 = Range("C114").Value

-If B114 = C114 Then

-Range("D114").Value = "OK"

-Else

-Range("D114").Value = "NG"

-End If

-End Function

-

-Function test_xlConeCol(ByRef num)

-Range("A115").Clear

-Range("B115").Clear

-Range("C115").Clear

-Range("D115").Clear

-Range("A115").Value = "xlConeCol"

-Range("B115").Value = 105

-Range("C115").Value = num

-B115 = Range("B115").Value

-C115 = Range("C115").Value

-If B115 = C115 Then

-Range("D115").Value = "OK"

-Else

-Range("D115").Value = "NG"

-End If

-End Function

-

-Function test_xlConeColClustered(ByRef num)

-Range("A116").Clear

-Range("B116").Clear

-Range("C116").Clear

-Range("D116").Clear

-Range("A116").Value = "xlConeColClustered"

-Range("B116").Value = 99

-Range("C116").Value = num

-B116 = Range("B116").Value

-C116 = Range("C116").Value

-If B116 = C116 Then

-Range("D116").Value = "OK"

-Else

-Range("D116").Value = "NG"

-End If

-End Function

-

-Function test_xlConeColStacked(ByRef num)

-Range("A117").Clear

-Range("B117").Clear

-Range("C117").Clear

-Range("D117").Clear

-Range("A117").Value = "xlConeColStacked"

-Range("B117").Value = 100

-Range("C117").Value = num

-B117 = Range("B117").Value

-C117 = Range("C117").Value

-If B117 = C117 Then

-Range("D117").Value = "OK"

-Else

-Range("D117").Value = "NG"

-End If

-End Function

-

-Function test_xlConeColStacked100(ByRef num)

-Range("A118").Clear

-Range("B118").Clear

-Range("C118").Clear

-Range("D118").Clear

-Range("A118").Value = "xlConeColStacked100"

-Range("B118").Value = 101

-Range("C118").Value = num

-B118 = Range("B118").Value

-C118 = Range("C118").Value

-If B118 = C118 Then

-Range("D118").Value = "OK"

-Else

-Range("D118").Value = "NG"

-End If

-End Function

-

-Function test_xlCylinderBarClustered(ByRef num)

-Range("A119").Clear

-Range("B119").Clear

-Range("C119").Clear

-Range("D119").Clear

-Range("A119").Value = "xlCylinderBarClustered"

-Range("B119").Value = 95

-Range("C119").Value = num

-B119 = Range("B119").Value

-C119 = Range("C119").Value

-If B119 = C119 Then

-Range("D119").Value = "OK"

-Else

-Range("D119").Value = "NG"

-End If

-End Function

-

-Function test_xlCylinderBarStacked(ByRef num)

-Range("A120").Clear

-Range("B120").Clear

-Range("C120").Clear

-Range("D120").Clear

-Range("A120").Value = "xlCylinderBarStacked"

-Range("B120").Value = 96

-Range("C120").Value = num

-B120 = Range("B120").Value

-C120 = Range("C120").Value

-If B120 = C120 Then

-Range("D120").Value = "OK"

-Else

-Range("D120").Value = "NG"

-End If

-End Function

-

-Function test_xlCylinderBarStacked100(ByRef num)

-Range("A121").Clear

-Range("B121").Clear

-Range("C121").Clear

-Range("D121").Clear

-Range("A121").Value = "xlCylinderBarStacked100"

-Range("B121").Value = 97

-Range("C121").Value = num

-B121 = Range("B121").Value

-C121 = Range("C121").Value

-If B121 = C121 Then

-Range("D121").Value = "OK"

-Else

-Range("D121").Value = "NG"

-End If

-End Function

-

-Function test_xlCylinderCol(ByRef num)

-Range("A122").Clear

-Range("B122").Clear

-Range("C122").Clear

-Range("D122").Clear

-Range("A122").Value = "xlCylinderCol"

-Range("B122").Value = 98

-Range("C122").Value = num

-B122 = Range("B122").Value

-C122 = Range("C122").Value

-If B122 = C122 Then

-Range("D122").Value = "OK"

-Else

-Range("D122").Value = "NG"

-End If

-End Function

-

-Function test_xlCylinderColClustered(ByRef num)

-Range("A123").Clear

-Range("B123").Clear

-Range("C123").Clear

-Range("D123").Clear

-Range("A123").Value = "xlCylinderColClustered"

-Range("B123").Value = 92

-Range("C123").Value = num

-B123 = Range("B123").Value

-C123 = Range("C123").Value

-If B123 = C123 Then

-Range("D123").Value = "OK"

-Else

-Range("D123").Value = "NG"

-End If

-End Function

-

-Function test_xlCylinderColStacked(ByRef num)

-Range("A124").Clear

-Range("B124").Clear

-Range("C124").Clear

-Range("D124").Clear

-Range("A124").Value = "xlCylinderColStacked"

-Range("B124").Value = 93

-Range("C124").Value = num

-B124 = Range("B124").Value

-C124 = Range("C124").Value

-If B124 = C124 Then

-Range("D124").Value = "OK"

-Else

-Range("D124").Value = "NG"

-End If

-End Function

-

-Function test_xlCylinderColStacked100(ByRef num)

-Range("A125").Clear

-Range("B125").Clear

-Range("C125").Clear

-Range("D125").Clear

-Range("A125").Value = "xlCylinderColStacked100"

-Range("B125").Value = 94

-Range("C125").Value = num

-B125 = Range("B125").Value

-C125 = Range("C125").Value

-If B125 = C125 Then

-Range("D125").Value = "OK"

-Else

-Range("D125").Value = "NG"

-End If

-End Function

-

-Function test_xlDoughnut(ByRef num)

-Range("A126").Clear

-Range("B126").Clear

-Range("C126").Clear

-Range("D126").Clear

-Range("A126").Value = "xlDoughnut"

-Range("B126").Value = -4120

-Range("C126").Value = num

-B126 = Range("B126").Value

-C126 = Range("C126").Value

-If B126 = C126 Then

-Range("D126").Value = "OK"

-Else

-Range("D126").Value = "NG"

-End If

-End Function

-

-Function test_xlDoughnutExploded(ByRef num)

-Range("A127").Clear

-Range("B127").Clear

-Range("C127").Clear

-Range("D127").Clear

-Range("A127").Value = "xlDoughnutExploded"

-Range("B127").Value = 80

-Range("C127").Value = num

-B127 = Range("B127").Value

-C127 = Range("C127").Value

-If B127 = C127 Then

-Range("D127").Value = "OK"

-Else

-Range("D127").Value = "NG"

-End If

-End Function

-

-Function test_xlLine(ByRef num)

-Range("A128").Clear

-Range("B128").Clear

-Range("C128").Clear

-Range("D128").Clear

-Range("A128").Value = "xlLine"

-Range("B128").Value = 4

-Range("C128").Value = num

-B128 = Range("B128").Value

-C128 = Range("C128").Value

-If B128 = C128 Then

-Range("D128").Value = "OK"

-Else

-Range("D128").Value = "NG"

-End If

-End Function

-

-Function test_xlLineMarkers(ByRef num)

-Range("A129").Clear

-Range("B129").Clear

-Range("C129").Clear

-Range("D129").Clear

-Range("A129").Value = "xlLineMarkers"

-Range("B129").Value = 65

-Range("C129").Value = num

-B129 = Range("B129").Value

-C129 = Range("C129").Value

-If B129 = C129 Then

-Range("D129").Value = "OK"

-Else

-Range("D129").Value = "NG"

-End If

-End Function

-

-Function test_xlLineMarkersStacked(ByRef num)

-Range("A130").Clear

-Range("B130").Clear

-Range("C130").Clear

-Range("D130").Clear

-Range("A130").Value = "xlLineMarkersStacked"

-Range("B130").Value = 66

-Range("C130").Value = num

-B130 = Range("B130").Value

-C130 = Range("C130").Value

-If B130 = C130 Then

-Range("D130").Value = "OK"

-Else

-Range("D130").Value = "NG"

-End If

-End Function

-

-Function test_xlLineMarkersStacked100(ByRef num)

-Range("A131").Clear

-Range("B131").Clear

-Range("C131").Clear

-Range("D131").Clear

-Range("A131").Value = "xlLineMarkersStacked100"

-Range("B131").Value = 67

-Range("C131").Value = num

-B131 = Range("B131").Value

-C131 = Range("C131").Value

-If B131 = C131 Then

-Range("D131").Value = "OK"

-Else

-Range("D131").Value = "NG"

-End If

-End Function

-

-Function test_xlLineStacked(ByRef num)

-Range("A132").Clear

-Range("B132").Clear

-Range("C132").Clear

-Range("D132").Clear

-Range("A132").Value = "xlLineStacked"

-Range("B132").Value = 63

-Range("C132").Value = num

-B132 = Range("B132").Value

-C132 = Range("C132").Value

-If B132 = C132 Then

-Range("D132").Value = "OK"

-Else

-Range("D132").Value = "NG"

-End If

-End Function

-

-Function test_xlLineStacked100(ByRef num)

-Range("A133").Clear

-Range("B133").Clear

-Range("C133").Clear

-Range("D133").Clear

-Range("A133").Value = "xlLineStacked100"

-Range("B133").Value = 64

-Range("C133").Value = num

-B133 = Range("B133").Value

-C133 = Range("C133").Value

-If B133 = C133 Then

-Range("D133").Value = "OK"

-Else

-Range("D133").Value = "NG"

-End If

-End Function

-

-Function test_xlPie(ByRef num)

-Range("A134").Clear

-Range("B134").Clear

-Range("C134").Clear

-Range("D134").Clear

-Range("A134").Value = "xlPie"

-Range("B134").Value = 5

-Range("C134").Value = num

-B134 = Range("B134").Value

-C134 = Range("C134").Value

-If B134 = C134 Then

-Range("D134").Value = "OK"

-Else

-Range("D134").Value = "NG"

-End If

-End Function

-

-Function test_xlPieExploded(ByRef num)

-Range("A135").Clear

-Range("B135").Clear

-Range("C135").Clear

-Range("D135").Clear

-Range("A135").Value = "xlPieExploded"

-Range("B135").Value = 69

-Range("C135").Value = num

-B135 = Range("B135").Value

-C135 = Range("C135").Value

-If B135 = C135 Then

-Range("D135").Value = "OK"

-Else

-Range("D135").Value = "NG"

-End If

-End Function

-

-Function test_xlPieOfPie(ByRef num)

-Range("A136").Clear

-Range("B136").Clear

-Range("C136").Clear

-Range("D136").Clear

-Range("A136").Value = "xlPieOfPie"

-Range("B136").Value = 68

-Range("C136").Value = num

-B136 = Range("B136").Value

-C136 = Range("C136").Value

-If B136 = C136 Then

-Range("D136").Value = "OK"

-Else

-Range("D136").Value = "NG"

-End If

-End Function

-

-Function test_xlPyramidBarClustered(ByRef num)

-Range("A137").Clear

-Range("B137").Clear

-Range("C137").Clear

-Range("D137").Clear

-Range("A137").Value = "xlPyramidBarClustered"

-Range("B137").Value = 109

-Range("C137").Value = num

-B137 = Range("B137").Value

-C137 = Range("C137").Value

-If B137 = C137 Then

-Range("D137").Value = "OK"

-Else

-Range("D137").Value = "NG"

-End If

-End Function

-

-Function test_xlPyramidBarStacked(ByRef num)

-Range("A138").Clear

-Range("B138").Clear

-Range("C138").Clear

-Range("D138").Clear

-Range("A138").Value = "xlPyramidBarStacked"

-Range("B138").Value = 110

-Range("C138").Value = num

-B138 = Range("B138").Value

-C138 = Range("C138").Value

-If B138 = C138 Then

-Range("D138").Value = "OK"

-Else

-Range("D138").Value = "NG"

-End If

-End Function

-

-Function test_xlPyramidBarStacked100(ByRef num)

-Range("A139").Clear

-Range("B139").Clear

-Range("C139").Clear

-Range("D139").Clear

-Range("A139").Value = "xlPyramidBarStacked100"

-Range("B139").Value = 111

-Range("C139").Value = num

-B139 = Range("B139").Value

-C139 = Range("C139").Value

-If B139 = C139 Then

-Range("D139").Value = "OK"

-Else

-Range("D139").Value = "NG"

-End If

-End Function

-

-Function test_xlPyramidCol(ByRef num)

-Range("A140").Clear

-Range("B140").Clear

-Range("C140").Clear

-Range("D140").Clear

-Range("A140").Value = "xlPyramidCol"

-Range("B140").Value = 112

-Range("C140").Value = num

-B140 = Range("B140").Value

-C140 = Range("C140").Value

-If B140 = C140 Then

-Range("D140").Value = "OK"

-Else

-Range("D140").Value = "NG"

-End If

-End Function

-

-Function test_xlPyramidColClustered(ByRef num)

-Range("A141").Clear

-Range("B141").Clear

-Range("C141").Clear

-Range("D141").Clear

-Range("A141").Value = "xlPyramidColClustered"

-Range("B141").Value = 106

-Range("C141").Value = num

-B141 = Range("B141").Value

-C141 = Range("C141").Value

-If B141 = C141 Then

-Range("D141").Value = "OK"

-Else

-Range("D141").Value = "NG"

-End If

-End Function

-

-Function test_xlPyramidColStacked(ByRef num)

-Range("A142").Clear

-Range("B142").Clear

-Range("C142").Clear

-Range("D142").Clear

-Range("A142").Value = "xlPyramidColStacked"

-Range("B142").Value = 107

-Range("C142").Value = num

-B142 = Range("B142").Value

-C142 = Range("C142").Value

-If B142 = C142 Then

-Range("D142").Value = "OK"

-Else

-Range("D142").Value = "NG"

-End If

-End Function

-

-Function test_xlPyramidColStacked100(ByRef num)

-Range("A143").Clear

-Range("B143").Clear

-Range("C143").Clear

-Range("D143").Clear

-Range("A143").Value = "xlPyramidColStacked100"

-Range("B143").Value = 108

-Range("C143").Value = num

-B143 = Range("B143").Value

-C143 = Range("C143").Value

-If B143 = C143 Then

-Range("D143").Value = "OK"

-Else

-Range("D143").Value = "NG"

-End If

-End Function

-

-Function test_xlRader(ByRef num)

-Range("A144").Clear

-Range("B144").Clear

-Range("C144").Clear

-Range("D144").Clear

-Range("A144").Value = "xlRader"

-Range("B144").Value = -4151

-Range("C144").Value = num

-B144 = Range("B144").Value

-C144 = Range("C144").Value

-If B144 = C144 Then

-Range("D144").Value = "OK"

-Else

-Range("D144").Value = "NG"

-End If

-End Function

-

-Function test_xlRaderFilled(ByRef num)

-Range("A145").Clear

-Range("B145").Clear

-Range("C145").Clear

-Range("D145").Clear

-Range("A145").Value = "xlRaderFilled"

-Range("B145").Value = 82

-Range("C145").Value = num

-B145 = Range("B145").Value

-C145 = Range("C145").Value

-If B145 = C145 Then

-Range("D145").Value = "OK"

-Else

-Range("D145").Value = "NG"

-End If

-End Function

-

-Function test_xlRaderMarkers(ByRef num)

-Range("A146").Clear

-Range("B146").Clear

-Range("C146").Clear

-Range("D146").Clear

-Range("A146").Value = "xlRaderMarkers"

-Range("B146").Value = 81

-Range("C146").Value = num

-B146 = Range("B146").Value

-C146 = Range("C146").Value

-If B146 = C146 Then

-Range("D146").Value = "OK"

-Else

-Range("D146").Value = "NG"

-End If

-End Function

-

-Function test_xlStockHLC(ByRef num)

-Range("A147").Clear

-Range("B147").Clear

-Range("C147").Clear

-Range("D147").Clear

-Range("A147").Value = "xlStockHLC"

-Range("B147").Value = 88

-Range("C147").Value = num

-B147 = Range("B147").Value

-C147 = Range("C147").Value

-If B147 = C147 Then

-Range("D147").Value = "OK"

-Else

-Range("D147").Value = "NG"

-End If

-End Function

-

-Function test_xlStockOHLC(ByRef num)

-Range("A148").Clear

-Range("B148").Clear

-Range("C148").Clear

-Range("D148").Clear

-Range("A148").Value = "xlStockOHLC"

-Range("B148").Value = 89

-Range("C148").Value = num

-B148 = Range("B148").Value

-C148 = Range("C148").Value

-If B148 = C148 Then

-Range("D148").Value = "OK"

-Else

-Range("D148").Value = "NG"

-End If

-End Function

-

-Function test_xlStockVHLC(ByRef num)

-Range("A149").Clear

-Range("B149").Clear

-Range("C149").Clear

-Range("D149").Clear

-Range("A149").Value = "xlStockVHLC"

-Range("B149").Value = 90

-Range("C149").Value = num

-B149 = Range("B149").Value

-C149 = Range("C149").Value

-If B149 = C149 Then

-Range("D149").Value = "OK"

-Else

-Range("D149").Value = "NG"

-End If

-End Function

-

-Function test_xlStockVOHLC(ByRef num)

-Range("A150").Clear

-Range("B150").Clear

-Range("C150").Clear

-Range("D150").Clear

-Range("A150").Value = "xlStockVOHLC"

-Range("B150").Value = 91

-Range("C150").Value = num

-B150 = Range("B150").Value

-C150 = Range("C150").Value

-If B150 = C150 Then

-Range("D150").Value = "OK"

-Else

-Range("D150").Value = "NG"

-End If

-End Function

-

-Function test_xlSurface(ByRef num)

-Range("A151").Clear

-Range("B151").Clear

-Range("C151").Clear

-Range("D151").Clear

-Range("A151").Value = "xlSurface"

-Range("B151").Value = 83

-Range("C151").Value = num

-B151 = Range("B151").Value

-C151 = Range("C151").Value

-If B151 = C151 Then

-Range("D151").Value = "OK"

-Else

-Range("D151").Value = "NG"

-End If

-End Function

-

-Function test_xlSurfaceTopView(ByRef num)

-Range("A152").Clear

-Range("B152").Clear

-Range("C152").Clear

-Range("D152").Clear

-Range("A152").Value = "xlSurfaceTopView"

-Range("B152").Value = 85

-Range("C152").Value = num

-B152 = Range("B152").Value

-C152 = Range("C152").Value

-If B152 = C152 Then

-Range("D152").Value = "OK"

-Else

-Range("D152").Value = "NG"

-End If

-End Function

-

-Function test_xlSurfaceTopViewWireframe(ByRef num)

-Range("A153").Clear

-Range("B153").Clear

-Range("C153").Clear

-Range("D153").Clear

-Range("A153").Value = "xlSurfaceTopViewWireframe"

-Range("B153").Value = 86

-Range("C153").Value = num

-B153 = Range("B153").Value

-C153 = Range("C153").Value

-If B153 = C153 Then

-Range("D153").Value = "OK"

-Else

-Range("D153").Value = "NG"

-End If

-End Function

-

-Function test_xlSurfaceWireframe(ByRef num)

-Range("A154").Clear

-Range("B154").Clear

-Range("C154").Clear

-Range("D154").Clear

-Range("A154").Value = "xlSurfaceWireframe"

-Range("B154").Value = 84

-Range("C154").Value = num

-B154 = Range("B154").Value

-C154 = Range("C154").Value

-If B154 = C154 Then

-Range("D154").Value = "OK"

-Else

-Range("D154").Value = "NG"

-End If

-End Function

-

-Function test_xlXYScatter(ByRef num)

-Range("A155").Clear

-Range("B155").Clear

-Range("C155").Clear

-Range("D155").Clear

-Range("A155").Value = "xlXYScatter"

-Range("B155").Value = -4169

-Range("C155").Value = num

-B155 = Range("B155").Value

-C155 = Range("C155").Value

-If B155 = C155 Then

-Range("D155").Value = "OK"

-Else

-Range("D155").Value = "NG"

-End If

-End Function

-

-Function test_xlXYScatterLines(ByRef num)

-Range("A156").Clear

-Range("B156").Clear

-Range("C156").Clear

-Range("D156").Clear

-Range("A156").Value = "xlXYScatterLines"

-Range("B156").Value = 74

-Range("C156").Value = num

-B156 = Range("B156").Value

-C156 = Range("C156").Value

-If B156 = C156 Then

-Range("D156").Value = "OK"

-Else

-Range("D156").Value = "NG"

-End If

-End Function

-

-Function test_xlXYScatterLinesNoMarkers(ByRef num)

-Range("A157").Clear

-Range("B157").Clear

-Range("C157").Clear

-Range("D157").Clear

-Range("A157").Value = "xlXYScatterLinesNoMarkers"

-Range("B157").Value = 75

-Range("C157").Value = num

-B157 = Range("B157").Value

-C157 = Range("C157").Value

-If B157 = C157 Then

-Range("D157").Value = "OK"

-Else

-Range("D157").Value = "NG"

-End If

-End Function

-

-Function test_xlXYScatterSmooth(ByRef num)

-Range("A158").Clear

-Range("B158").Clear

-Range("C158").Clear

-Range("D158").Clear

-Range("A158").Value = "xlXYScatterSmooth"

-Range("B158").Value = 72

-Range("C158").Value = num

-B158 = Range("B158").Value

-C158 = Range("C158").Value

-If B158 = C158 Then

-Range("D158").Value = "OK"

-Else

-Range("D158").Value = "NG"

-End If

-End Function

-

-Function test_xlXYScatterSmoothNoMarkers(ByRef num)

-Range("A159").Clear

-Range("B159").Clear

-Range("C159").Clear

-Range("D159").Clear

-Range("A159").Value = "xlXYScatterSmoothNoMarkers"

-Range("B159").Value = 73

-Range("C159").Value = num

-B159 = Range("B159").Value

-C159 = Range("C159").Value

-If B159 = C159 Then

-Range("D159").Value = "OK"

-Else

-Range("D159").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatBIFF(ByRef num)

-Range("A160").Clear

-Range("B160").Clear

-Range("C160").Clear

-Range("D160").Clear

-Range("A160").Value = "xlClipboardFormatBIFF"

-Range("B160").Value = 8

-Range("C160").Value = num

-B160 = Range("B160").Value

-C160 = Range("C160").Value

-If B160 = C160 Then

-Range("D160").Value = "OK"

-Else

-Range("D160").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatBIFF2(ByRef num)

-Range("A161").Clear

-Range("B161").Clear

-Range("C161").Clear

-Range("D161").Clear

-Range("A161").Value = "xlClipboardFormatBIFF2"

-Range("B161").Value = 18

-Range("C161").Value = num

-B161 = Range("B161").Value

-C161 = Range("C161").Value

-If B161 = C161 Then

-Range("D161").Value = "OK"

-Else

-Range("D161").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatBIFF3(ByRef num)

-Range("A162").Clear

-Range("B162").Clear

-Range("C162").Clear

-Range("D162").Clear

-Range("A162").Value = "xlClipboardFormatBIFF3"

-Range("B162").Value = 20

-Range("C162").Value = num

-B162 = Range("B162").Value

-C162 = Range("C162").Value

-If B162 = C162 Then

-Range("D162").Value = "OK"

-Else

-Range("D162").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatBIFF4(ByRef num)

-Range("A163").Clear

-Range("B163").Clear

-Range("C163").Clear

-Range("D163").Clear

-Range("A163").Value = "xlClipboardFormatBIFF4"

-Range("B163").Value = 30

-Range("C163").Value = num

-B163 = Range("B163").Value

-C163 = Range("C163").Value

-If B163 = C163 Then

-Range("D163").Value = "OK"

-Else

-Range("D163").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatBinary(ByRef num)

-Range("A164").Clear

-Range("B164").Clear

-Range("C164").Clear

-Range("D164").Clear

-Range("A164").Value = "xlClipboardFormatBinary"

-Range("B164").Value = 15

-Range("C164").Value = num

-B164 = Range("B164").Value

-C164 = Range("C164").Value

-If B164 = C164 Then

-Range("D164").Value = "OK"

-Else

-Range("D164").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatBitmap(ByRef num)

-Range("A165").Clear

-Range("B165").Clear

-Range("C165").Clear

-Range("D165").Clear

-Range("A165").Value = "xlClipboardFormatBitmap"

-Range("B165").Value = 9

-Range("C165").Value = num

-B165 = Range("B165").Value

-C165 = Range("C165").Value

-If B165 = C165 Then

-Range("D165").Value = "OK"

-Else

-Range("D165").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatCGM(ByRef num)

-Range("A166").Clear

-Range("B166").Clear

-Range("C166").Clear

-Range("D166").Clear

-Range("A166").Value = "xlClipboardFormatCGM"

-Range("B166").Value = 13

-Range("C166").Value = num

-B166 = Range("B166").Value

-C166 = Range("C166").Value

-If B166 = C166 Then

-Range("D166").Value = "OK"

-Else

-Range("D166").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatCSV(ByRef num)

-Range("A167").Clear

-Range("B167").Clear

-Range("C167").Clear

-Range("D167").Clear

-Range("A167").Value = "xlClipboardFormatCSV"

-Range("B167").Value = 5

-Range("C167").Value = num

-B167 = Range("B167").Value

-C167 = Range("C167").Value

-If B167 = C167 Then

-Range("D167").Value = "OK"

-Else

-Range("D167").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatDIF(ByRef num)

-Range("A168").Clear

-Range("B168").Clear

-Range("C168").Clear

-Range("D168").Clear

-Range("A168").Value = "xlClipboardFormatDIF"

-Range("B168").Value = 4

-Range("C168").Value = num

-B168 = Range("B168").Value

-C168 = Range("C168").Value

-If B168 = C168 Then

-Range("D168").Value = "OK"

-Else

-Range("D168").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatDspText(ByRef num)

-Range("A169").Clear

-Range("B169").Clear

-Range("C169").Clear

-Range("D169").Clear

-Range("A169").Value = "xlClipboardFormatDspText"

-Range("B169").Value = 12

-Range("C169").Value = num

-B169 = Range("B169").Value

-C169 = Range("C169").Value

-If B169 = C169 Then

-Range("D169").Value = "OK"

-Else

-Range("D169").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatEmbeddedObject(ByRef num)

-Range("A170").Clear

-Range("B170").Clear

-Range("C170").Clear

-Range("D170").Clear

-Range("A170").Value = "xlClipboardFormatEmbeddedObject"

-Range("B170").Value = 21

-Range("C170").Value = num

-B170 = Range("B170").Value

-C170 = Range("C170").Value

-If B170 = C170 Then

-Range("D170").Value = "OK"

-Else

-Range("D170").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatEmbedSource(ByRef num)

-Range("A171").Clear

-Range("B171").Clear

-Range("C171").Clear

-Range("D171").Clear

-Range("A171").Value = "xlClipboardFormatEmbedSource"

-Range("B171").Value = 22

-Range("C171").Value = num

-B171 = Range("B171").Value

-C171 = Range("C171").Value

-If B171 = C171 Then

-Range("D171").Value = "OK"

-Else

-Range("D171").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatLink(ByRef num)

-Range("A172").Clear

-Range("B172").Clear

-Range("C172").Clear

-Range("D172").Clear

-Range("A172").Value = "xlClipboardFormatLink"

-Range("B172").Value = 11

-Range("C172").Value = num

-B172 = Range("B172").Value

-C172 = Range("C172").Value

-If B172 = C172 Then

-Range("D172").Value = "OK"

-Else

-Range("D172").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatLinkSource(ByRef num)

-Range("A173").Clear

-Range("B173").Clear

-Range("C173").Clear

-Range("D173").Clear

-Range("A173").Value = "xlClipboardFormatLinkSource"

-Range("B173").Value = 23

-Range("C173").Value = num

-B173 = Range("B173").Value

-C173 = Range("C173").Value

-If B173 = C173 Then

-Range("D173").Value = "OK"

-Else

-Range("D173").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatLinkSourceDesc(ByRef num)

-Range("A174").Clear

-Range("B174").Clear

-Range("C174").Clear

-Range("D174").Clear

-Range("A174").Value = "xlClipboardFormatLinkSourceDesc"

-Range("B174").Value = 32

-Range("C174").Value = num

-B174 = Range("B174").Value

-C174 = Range("C174").Value

-If B174 = C174 Then

-Range("D174").Value = "OK"

-Else

-Range("D174").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatMovie(ByRef num)

-Range("A175").Clear

-Range("B175").Clear

-Range("C175").Clear

-Range("D175").Clear

-Range("A175").Value = "xlClipboardFormatMovie"

-Range("B175").Value = 24

-Range("C175").Value = num

-B175 = Range("B175").Value

-C175 = Range("C175").Value

-If B175 = C175 Then

-Range("D175").Value = "OK"

-Else

-Range("D175").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatNative(ByRef num)

-Range("A176").Clear

-Range("B176").Clear

-Range("C176").Clear

-Range("D176").Clear

-Range("A176").Value = "xlClipboardFormatNative"

-Range("B176").Value = 14

-Range("C176").Value = num

-B176 = Range("B176").Value

-C176 = Range("C176").Value

-If B176 = C176 Then

-Range("D176").Value = "OK"

-Else

-Range("D176").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatObjectDesc(ByRef num)

-Range("A177").Clear

-Range("B177").Clear

-Range("C177").Clear

-Range("D177").Clear

-Range("A177").Value = "xlClipboardFormatObjectDesc"

-Range("B177").Value = 31

-Range("C177").Value = num

-B177 = Range("B177").Value

-C177 = Range("C177").Value

-If B177 = C177 Then

-Range("D177").Value = "OK"

-Else

-Range("D177").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatObjectLink(ByRef num)

-Range("A178").Clear

-Range("B178").Clear

-Range("C178").Clear

-Range("D178").Clear

-Range("A178").Value = "xlClipboardFormatObjectLink"

-Range("B178").Value = 19

-Range("C178").Value = num

-B178 = Range("B178").Value

-C178 = Range("C178").Value

-If B178 = C178 Then

-Range("D178").Value = "OK"

-Else

-Range("D178").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatOwnerLink(ByRef num)

-Range("A179").Clear

-Range("B179").Clear

-Range("C179").Clear

-Range("D179").Clear

-Range("A179").Value = "xlClipboardFormatOwnerLink"

-Range("B179").Value = 17

-Range("C179").Value = num

-B179 = Range("B179").Value

-C179 = Range("C179").Value

-If B179 = C179 Then

-Range("D179").Value = "OK"

-Else

-Range("D179").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatPICT(ByRef num)

-Range("A180").Clear

-Range("B180").Clear

-Range("C180").Clear

-Range("D180").Clear

-Range("A180").Value = "xlClipboardFormatPICT"

-Range("B180").Value = 2

-Range("C180").Value = num

-B180 = Range("B180").Value

-C180 = Range("C180").Value

-If B180 = C180 Then

-Range("D180").Value = "OK"

-Else

-Range("D180").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatPrintPICT(ByRef num)

-Range("A181").Clear

-Range("B181").Clear

-Range("C181").Clear

-Range("D181").Clear

-Range("A181").Value = "xlClipboardFormatPrintPICT"

-Range("B181").Value = 3

-Range("C181").Value = num

-B181 = Range("B181").Value

-C181 = Range("C181").Value

-If B181 = C181 Then

-Range("D181").Value = "OK"

-Else

-Range("D181").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatRTF(ByRef num)

-Range("A182").Clear

-Range("B182").Clear

-Range("C182").Clear

-Range("D182").Clear

-Range("A182").Value = "xlClipboardFormatRTF"

-Range("B182").Value = 7

-Range("C182").Value = num

-B182 = Range("B182").Value

-C182 = Range("C182").Value

-If B182 = C182 Then

-Range("D182").Value = "OK"

-Else

-Range("D182").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatScreenPICT(ByRef num)

-Range("A183").Clear

-Range("B183").Clear

-Range("C183").Clear

-Range("D183").Clear

-Range("A183").Value = "xlClipboardFormatScreenPICT"

-Range("B183").Value = 29

-Range("C183").Value = num

-B183 = Range("B183").Value

-C183 = Range("C183").Value

-If B183 = C183 Then

-Range("D183").Value = "OK"

-Else

-Range("D183").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatStandardFont(ByRef num)

-Range("A184").Clear

-Range("B184").Clear

-Range("C184").Clear

-Range("D184").Clear

-Range("A184").Value = "xlClipboardFormatStandardFont"

-Range("B184").Value = 28

-Range("C184").Value = num

-B184 = Range("B184").Value

-C184 = Range("C184").Value

-If B184 = C184 Then

-Range("D184").Value = "OK"

-Else

-Range("D184").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatStandardScale(ByRef num)

-Range("A185").Clear

-Range("B185").Clear

-Range("C185").Clear

-Range("D185").Clear

-Range("A185").Value = "xlClipboardFormatStandardScale"

-Range("B185").Value = 27

-Range("C185").Value = num

-B185 = Range("B185").Value

-C185 = Range("C185").Value

-If B185 = C185 Then

-Range("D185").Value = "OK"

-Else

-Range("D185").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatSYLK(ByRef num)

-Range("A186").Clear

-Range("B186").Clear

-Range("C186").Clear

-Range("D186").Clear

-Range("A186").Value = "xlClipboardFormatSYLK"

-Range("B186").Value = 6

-Range("C186").Value = num

-B186 = Range("B186").Value

-C186 = Range("C186").Value

-If B186 = C186 Then

-Range("D186").Value = "OK"

-Else

-Range("D186").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatTable(ByRef num)

-Range("A187").Clear

-Range("B187").Clear

-Range("C187").Clear

-Range("D187").Clear

-Range("A187").Value = "xlClipboardFormatTable"

-Range("B187").Value = 16

-Range("C187").Value = num

-B187 = Range("B187").Value

-C187 = Range("C187").Value

-If B187 = C187 Then

-Range("D187").Value = "OK"

-Else

-Range("D187").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatText(ByRef num)

-Range("A188").Clear

-Range("B188").Clear

-Range("C188").Clear

-Range("D188").Clear

-Range("A188").Value = "xlClipboardFormatText"

-Range("B188").Value = 0

-Range("C188").Value = num

-B188 = Range("B188").Value

-C188 = Range("C188").Value

-If B188 = C188 Then

-Range("D188").Value = "OK"

-Else

-Range("D188").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatToolFace(ByRef num)

-Range("A189").Clear

-Range("B189").Clear

-Range("C189").Clear

-Range("D189").Clear

-Range("A189").Value = "xlClipboardFormatToolFace"

-Range("B189").Value = 25

-Range("C189").Value = num

-B189 = Range("B189").Value

-C189 = Range("C189").Value

-If B189 = C189 Then

-Range("D189").Value = "OK"

-Else

-Range("D189").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatToolFacePICT(ByRef num)

-Range("A190").Clear

-Range("B190").Clear

-Range("C190").Clear

-Range("D190").Clear

-Range("A190").Value = "xlClipboardFormatToolFacePICT"

-Range("B190").Value = 26

-Range("C190").Value = num

-B190 = Range("B190").Value

-C190 = Range("C190").Value

-If B190 = C190 Then

-Range("D190").Value = "OK"

-Else

-Range("D190").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatToolVALU(ByRef num)

-Range("A191").Clear

-Range("B191").Clear

-Range("C191").Clear

-Range("D191").Clear

-Range("A191").Value = "xlClipboardFormatToolVALU"

-Range("B191").Value = 1

-Range("C191").Value = num

-B191 = Range("B191").Value

-C191 = Range("C191").Value

-If B191 = C191 Then

-Range("D191").Value = "OK"

-Else

-Range("D191").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatToolWK1(ByRef num)

-Range("A192").Clear

-Range("B192").Clear

-Range("C192").Clear

-Range("D192").Clear

-Range("A192").Value = "xlClipboardFormatToolWK1"

-Range("B192").Value = 10

-Range("C192").Value = num

-B192 = Range("B192").Value

-C192 = Range("C192").Value

-If B192 = C192 Then

-Range("D192").Value = "OK"

-Else

-Range("D192").Value = "NG"

-End If

-End Function

-

-Function test_xlCmdCube(ByRef num)

-Range("A193").Clear

-Range("B193").Clear

-Range("C193").Clear

-Range("D193").Clear

-Range("A193").Value = "xlCmdCube"

-Range("B193").Value = 1

-Range("C193").Value = num

-B193 = Range("B193").Value

-C193 = Range("C193").Value

-If B193 = C193 Then

-Range("D193").Value = "OK"

-Else

-Range("D193").Value = "NG"

-End If

-End Function

-

-Function test_xlCmdDefault(ByRef num)

-Range("A194").Clear

-Range("B194").Clear

-Range("C194").Clear

-Range("D194").Clear

-Range("A194").Value = "xlCmdDefault"

-Range("B194").Value = 4

-Range("C194").Value = num

-B194 = Range("B194").Value

-C194 = Range("C194").Value

-If B194 = C194 Then

-Range("D194").Value = "OK"

-Else

-Range("D194").Value = "NG"

-End If

-End Function

-

-Function test_xlCmdList(ByRef num)

-Range("A195").Clear

-Range("B195").Clear

-Range("C195").Clear

-Range("D195").Clear

-Range("A195").Value = "xlCmdList"

-Range("B195").Value = 5

-Range("C195").Value = num

-B195 = Range("B195").Value

-C195 = Range("C195").Value

-If B195 = C195 Then

-Range("D195").Value = "OK"

-Else

-Range("D195").Value = "NG"

-End If

-End Function

-

-Function test_xlCmdSql(ByRef num)

-Range("A196").Clear

-Range("B196").Clear

-Range("C196").Clear

-Range("D196").Clear

-Range("A196").Value = "xlCmdSql"

-Range("B196").Value = 2

-Range("C196").Value = num

-B196 = Range("B196").Value

-C196 = Range("C196").Value

-If B196 = C196 Then

-Range("D196").Value = "OK"

-Else

-Range("D196").Value = "NG"

-End If

-End Function

-

-Function test_xlCmdTable(ByRef num)

-Range("A197").Clear

-Range("B197").Clear

-Range("C197").Clear

-Range("D197").Clear

-Range("A197").Value = "xlCmdTable"

-Range("B197").Value = 3

-Range("C197").Value = num

-B197 = Range("B197").Value

-C197 = Range("C197").Value

-If B197 = C197 Then

-Range("D197").Value = "OK"

-Else

-Range("D197").Value = "NG"

-End If

-End Function

-

-Function test_xlColorIndexAutomatic(ByRef num)

-Range("A198").Clear

-Range("B198").Clear

-Range("C198").Clear

-Range("D198").Clear

-Range("A198").Value = "xlColorIndexAutomatic"

-Range("B198").Value = -4105

-Range("C198").Value = num

-B198 = Range("B198").Value

-C198 = Range("C198").Value

-If B198 = C198 Then

-Range("D198").Value = "OK"

-Else

-Range("D198").Value = "NG"

-End If

-End Function

-

-Function test_xlColorIndexNone(ByRef num)

-Range("A199").Clear

-Range("B199").Clear

-Range("C199").Clear

-Range("D199").Clear

-Range("A199").Value = "xlColorIndexNone"

-Range("B199").Value = -4142

-Range("C199").Value = num

-B199 = Range("B199").Value

-C199 = Range("C199").Value

-If B199 = C199 Then

-Range("D199").Value = "OK"

-Else

-Range("D199").Value = "NG"

-End If

-End Function

-

-Function test_xlDMYFormat(ByRef num)

-Range("A200").Clear

-Range("B200").Clear

-Range("C200").Clear

-Range("D200").Clear

-Range("A200").Value = "xlDMYFormat"

-Range("B200").Value = 4

-Range("C200").Value = num

-B200 = Range("B200").Value

-C200 = Range("C200").Value

-If B200 = C200 Then

-Range("D200").Value = "OK"

-Else

-Range("D200").Value = "NG"

-End If

-End Function

-

-Function test_xlDYMFormat(ByRef num)

-Range("A201").Clear

-Range("B201").Clear

-Range("C201").Clear

-Range("D201").Clear

-Range("A201").Value = "xlDYMFormat"

-Range("B201").Value = 7

-Range("C201").Value = num

-B201 = Range("B201").Value

-C201 = Range("C201").Value

-If B201 = C201 Then

-Range("D201").Value = "OK"

-Else

-Range("D201").Value = "NG"

-End If

-End Function

-

-Function test_xlEMDFormat(ByRef num)

-Range("A202").Clear

-Range("B202").Clear

-Range("C202").Clear

-Range("D202").Clear

-Range("A202").Value = "xlEMDFormat"

-Range("B202").Value = 10

-Range("C202").Value = num

-B202 = Range("B202").Value

-C202 = Range("C202").Value

-If B202 = C202 Then

-Range("D202").Value = "OK"

-Else

-Range("D202").Value = "NG"

-End If

-End Function

-

-Function test_xlGeneralFormat(ByRef num)

-Range("A203").Clear

-Range("B203").Clear

-Range("C203").Clear

-Range("D203").Clear

-Range("A203").Value = "xlGeneralFormat"

-Range("B203").Value = 1

-Range("C203").Value = num

-B203 = Range("B203").Value

-C203 = Range("C203").Value

-If B203 = C203 Then

-Range("D203").Value = "OK"

-Else

-Range("D203").Value = "NG"

-End If

-End Function

-

-Function test_xlMDYFormat(ByRef num)

-Range("A204").Clear

-Range("B204").Clear

-Range("C204").Clear

-Range("D204").Clear

-Range("A204").Value = "xlMDYFormat"

-Range("B204").Value = 3

-Range("C204").Value = num

-B204 = Range("B204").Value

-C204 = Range("C204").Value

-If B204 = C204 Then

-Range("D204").Value = "OK"

-Else

-Range("D204").Value = "NG"

-End If

-End Function

-

-Function test_xlMYDFormat(ByRef num)

-Range("A205").Clear

-Range("B205").Clear

-Range("C205").Clear

-Range("D205").Clear

-Range("A205").Value = "xlMYDFormat"

-Range("B205").Value = 6

-Range("C205").Value = num

-B205 = Range("B205").Value

-C205 = Range("C205").Value

-If B205 = C205 Then

-Range("D205").Value = "OK"

-Else

-Range("D205").Value = "NG"

-End If

-End Function

-

-Function test_xlSkipColumn(ByRef num)

-Range("A206").Clear

-Range("B206").Clear

-Range("C206").Clear

-Range("D206").Clear

-Range("A206").Value = "xlSkipColumn"

-Range("B206").Value = 9

-Range("C206").Value = num

-B206 = Range("B206").Value

-C206 = Range("C206").Value

-If B206 = C206 Then

-Range("D206").Value = "OK"

-Else

-Range("D206").Value = "NG"

-End If

-End Function

-

-Function test_xlTextFormat(ByRef num)

-Range("A207").Clear

-Range("B207").Clear

-Range("C207").Clear

-Range("D207").Clear

-Range("A207").Value = "xlTextFormat"

-Range("B207").Value = 2

-Range("C207").Value = num

-B207 = Range("B207").Value

-C207 = Range("C207").Value

-If B207 = C207 Then

-Range("D207").Value = "OK"

-Else

-Range("D207").Value = "NG"

-End If

-End Function

-

-Function test_xlYDMFormat(ByRef num)

-Range("A208").Clear

-Range("B208").Clear

-Range("C208").Clear

-Range("D208").Clear

-Range("A208").Value = "xlYDMFormat"

-Range("B208").Value = 8

-Range("C208").Value = num

-B208 = Range("B208").Value

-C208 = Range("C208").Value

-If B208 = C208 Then

-Range("D208").Value = "OK"

-Else

-Range("D208").Value = "NG"

-End If

-End Function

-

-Function test_xlYMDFormat(ByRef num)

-Range("A209").Clear

-Range("B209").Clear

-Range("C209").Clear

-Range("D209").Clear

-Range("A209").Value = "xlYMDFormat"

-Range("B209").Value = 5

-Range("C209").Value = num

-B209 = Range("B209").Value

-C209 = Range("C209").Value

-If B209 = C209 Then

-Range("D209").Value = "OK"

-Else

-Range("D209").Value = "NG"

-End If

-End Function

-

-Function test_xlCommandUnderlinesAutomatic(ByRef num)

-Range("A210").Clear

-Range("B210").Clear

-Range("C210").Clear

-Range("D210").Clear

-Range("A210").Value = "xlCommandUnderlinesAutomatic"

-Range("B210").Value = -4105

-Range("C210").Value = num

-B210 = Range("B210").Value

-C210 = Range("C210").Value

-If B210 = C210 Then

-Range("D210").Value = "OK"

-Else

-Range("D210").Value = "NG"

-End If

-End Function

-

-Function test_xlCommandUnderlinesOff(ByRef num)

-Range("A211").Clear

-Range("B211").Clear

-Range("C211").Clear

-Range("D211").Clear

-Range("A211").Value = "xlCommandUnderlinesOff"

-Range("B211").Value = -4146

-Range("C211").Value = num

-B211 = Range("B211").Value

-C211 = Range("C211").Value

-If B211 = C211 Then

-Range("D211").Value = "OK"

-Else

-Range("D211").Value = "NG"

-End If

-End Function

-

-Function test_xlCommandUnderlinesOn(ByRef num)

-Range("A212").Clear

-Range("B212").Clear

-Range("C212").Clear

-Range("D212").Clear

-Range("A212").Value = "xlCommandUnderlinesOn"

-Range("B212").Value = 1

-Range("C212").Value = num

-B212 = Range("B212").Value

-C212 = Range("C212").Value

-If B212 = C212 Then

-Range("D212").Value = "OK"

-Else

-Range("D212").Value = "NG"

-End If

-End Function

-

-Function test_xlCommentAndIndicator(ByRef num)

-Range("A213").Clear

-Range("B213").Clear

-Range("C213").Clear

-Range("D213").Clear

-Range("A213").Value = "xlCommentAndIndicator"

-Range("B213").Value = 1

-Range("C213").Value = num

-B213 = Range("B213").Value

-C213 = Range("C213").Value

-If B213 = C213 Then

-Range("D213").Value = "OK"

-Else

-Range("D213").Value = "NG"

-End If

-End Function

-

-Function test_xlCommentIndicatorOnly(ByRef num)

-Range("A214").Clear

-Range("B214").Clear

-Range("C214").Clear

-Range("D214").Clear

-Range("A214").Value = "xlCommentIndicatorOnly"

-Range("B214").Value = -1

-Range("C214").Value = num

-B214 = Range("B214").Value

-C214 = Range("C214").Value

-If B214 = C214 Then

-Range("D214").Value = "OK"

-Else

-Range("D214").Value = "NG"

-End If

-End Function

-

-Function test_xlNoIndicator(ByRef num)

-Range("A215").Clear

-Range("B215").Clear

-Range("C215").Clear

-Range("D215").Clear

-Range("A215").Value = "xlNoIndicator"

-Range("B215").Value = 0

-Range("C215").Value = num

-B215 = Range("B215").Value

-C215 = Range("C215").Value

-If B215 = C215 Then

-Range("D215").Value = "OK"

-Else

-Range("D215").Value = "NG"

-End If

-End Function

-

-Function test_xlAverage(ByRef num)

-Range("A216").Clear

-Range("B216").Clear

-Range("C216").Clear

-Range("D216").Clear

-Range("A216").Value = "xlAverage"

-Range("B216").Value = -4106

-Range("C216").Value = num

-B216 = Range("B216").Value

-C216 = Range("C216").Value

-If B216 = C216 Then

-Range("D216").Value = "OK"

-Else

-Range("D216").Value = "NG"

-End If

-End Function

-

-Function test_xlCount(ByRef num)

-Range("A217").Clear

-Range("B217").Clear

-Range("C217").Clear

-Range("D217").Clear

-Range("A217").Value = "xlCount"

-Range("B217").Value = -4112

-Range("C217").Value = num

-B217 = Range("B217").Value

-C217 = Range("C217").Value

-If B217 = C217 Then

-Range("D217").Value = "OK"

-Else

-Range("D217").Value = "NG"

-End If

-End Function

-

-Function test_xlCountNums(ByRef num)

-Range("A218").Clear

-Range("B218").Clear

-Range("C218").Clear

-Range("D218").Clear

-Range("A218").Value = "xlCountNums"

-Range("B218").Value = -4113

-Range("C218").Value = num

-B218 = Range("B218").Value

-C218 = Range("C218").Value

-If B218 = C218 Then

-Range("D218").Value = "OK"

-Else

-Range("D218").Value = "NG"

-End If

-End Function

-

-Function test_xlMax(ByRef num)

-Range("A219").Clear

-Range("B219").Clear

-Range("C219").Clear

-Range("D219").Clear

-Range("A219").Value = "xlMax"

-Range("B219").Value = -4136

-Range("C219").Value = num

-B219 = Range("B219").Value

-C219 = Range("C219").Value

-If B219 = C219 Then

-Range("D219").Value = "OK"

-Else

-Range("D219").Value = "NG"

-End If

-End Function

-

-Function test_xlMin(ByRef num)

-Range("A220").Clear

-Range("B220").Clear

-Range("C220").Clear

-Range("D220").Clear

-Range("A220").Value = "xlMin"

-Range("B220").Value = -4139

-Range("C220").Value = num

-B220 = Range("B220").Value

-C220 = Range("C220").Value

-If B220 = C220 Then

-Range("D220").Value = "OK"

-Else

-Range("D220").Value = "NG"

-End If

-End Function

-

-Function test_xlProduct(ByRef num)

-Range("A221").Clear

-Range("B221").Clear

-Range("C221").Clear

-Range("D221").Clear

-Range("A221").Value = "xlProduct"

-Range("B221").Value = -4149

-Range("C221").Value = num

-B221 = Range("B221").Value

-C221 = Range("C221").Value

-If B221 = C221 Then

-Range("D221").Value = "OK"

-Else

-Range("D221").Value = "NG"

-End If

-End Function

-

-Function test_xlStDev(ByRef num)

-Range("A222").Clear

-Range("B222").Clear

-Range("C222").Clear

-Range("D222").Clear

-Range("A222").Value = "xlStDev"

-Range("B222").Value = -4155

-Range("C222").Value = num

-B222 = Range("B222").Value

-C222 = Range("C222").Value

-If B222 = C222 Then

-Range("D222").Value = "OK"

-Else

-Range("D222").Value = "NG"

-End If

-End Function

-

-Function test_xlStDevP(ByRef num)

-Range("A223").Clear

-Range("B223").Clear

-Range("C223").Clear

-Range("D223").Clear

-Range("A223").Value = "xlStDevP"

-Range("B223").Value = -4156

-Range("C223").Value = num

-B223 = Range("B223").Value

-C223 = Range("C223").Value

-If B223 = C223 Then

-Range("D223").Value = "OK"

-Else

-Range("D223").Value = "NG"

-End If

-End Function

-

-Function test_xlSum(ByRef num)

-Range("A224").Clear

-Range("B224").Clear

-Range("C224").Clear

-Range("D224").Clear

-Range("A224").Value = "xlSum"

-Range("B224").Value = -4157

-Range("C224").Value = num

-B224 = Range("B224").Value

-C224 = Range("C224").Value

-If B224 = C224 Then

-Range("D224").Value = "OK"

-Else

-Range("D224").Value = "NG"

-End If

-End Function

-

-Function test_xlUnknown(ByRef num)

-Range("A225").Clear

-Range("B225").Clear

-Range("C225").Clear

-Range("D225").Clear

-Range("A225").Value = "xlUnknown"

-Range("B225").Value = 1000

-Range("C225").Value = num

-B225 = Range("B225").Value

-C225 = Range("C225").Value

-If B225 = C225 Then

-Range("D225").Value = "OK"

-Else

-Range("D225").Value = "NG"

-End If

-End Function

-

-Function test_xlVar(ByRef num)

-Range("A226").Clear

-Range("B226").Clear

-Range("C226").Clear

-Range("D226").Clear

-Range("A226").Value = "xlVar"

-Range("B226").Value = -4164

-Range("C226").Value = num

-B226 = Range("B226").Value

-C226 = Range("C226").Value

-If B226 = C226 Then

-Range("D226").Value = "OK"

-Else

-Range("D226").Value = "NG"

-End If

-End Function

-

-Function test_xlVarP(ByRef num)

-Range("A227").Clear

-Range("B227").Clear

-Range("C227").Clear

-Range("D227").Clear

-Range("A227").Value = "xlVarP"

-Range("B227").Value = -4165

-Range("C227").Value = num

-B227 = Range("B227").Value

-C227 = Range("C227").Value

-If B227 = C227 Then

-Range("D227").Value = "OK"

-Else

-Range("D227").Value = "NG"

-End If

-End Function

-

-Function test_xlBitmap(ByRef num)

-Range("A228").Clear

-Range("B228").Clear

-Range("C228").Clear

-Range("D228").Clear

-Range("A228").Value = "xlBitmap"

-Range("B228").Value = 2

-Range("C228").Value = num

-B228 = Range("B228").Value

-C228 = Range("C228").Value

-If B228 = C228 Then

-Range("D228").Value = "OK"

-Else

-Range("D228").Value = "NG"

-End If

-End Function

-

-Function test_xlPicture(ByRef num)

-Range("A229").Clear

-Range("B229").Clear

-Range("C229").Clear

-Range("D229").Clear

-Range("A229").Value = "xlPicture"

-Range("B229").Value = -4147

-Range("C229").Value = num

-B229 = Range("B229").Value

-C229 = Range("C229").Value

-If B229 = C229 Then

-Range("D229").Value = "OK"

-Else

-Range("D229").Value = "NG"

-End If

-End Function

-

-Function test_xlExtractData(ByRef num)

-Range("A230").Clear

-Range("B230").Clear

-Range("C230").Clear

-Range("D230").Clear

-Range("A230").Value = "xlExtractData"

-Range("B230").Value = 2

-Range("C230").Value = num

-B230 = Range("B230").Value

-C230 = Range("C230").Value

-If B230 = C230 Then

-Range("D230").Value = "OK"

-Else

-Range("D230").Value = "NG"

-End If

-End Function

-

-Function test_xlNormalLoad(ByRef num)

-Range("A231").Clear

-Range("B231").Clear

-Range("C231").Clear

-Range("D231").Clear

-Range("A231").Value = "xlNormalLoad"

-Range("B231").Value = 0

-Range("C231").Value = num

-B231 = Range("B231").Value

-C231 = Range("C231").Value

-If B231 = C231 Then

-Range("D231").Value = "OK"

-Else

-Range("D231").Value = "NG"

-End If

-End Function

-

-Function test_xlRepairFile(ByRef num)

-Range("A232").Clear

-Range("B232").Clear

-Range("C232").Clear

-Range("D232").Clear

-Range("A232").Value = "xlRepairFile"

-Range("B232").Value = 1

-Range("C232").Value = num

-B232 = Range("B232").Value

-C232 = Range("C232").Value

-If B232 = C232 Then

-Range("D232").Value = "OK"

-Else

-Range("D232").Value = "NG"

-End If

-End Function

-

-Function test_xlCreatorCode(ByRef num)

-Range("A233").Clear

-Range("B233").Clear

-Range("C233").Clear

-Range("D233").Clear

-Range("A233").Value = "xlCreatorCode"

-Range("B233").Value = 1480803660

-Range("C233").Value = num

-B233 = Range("B233").Value

-C233 = Range("C233").Value

-If B233 = C233 Then

-Range("D233").Value = "OK"

-Else

-Range("D233").Value = "NG"

-End If

-End Function

-

-Function test_xlHierarchy(ByRef num)

-Range("A234").Clear

-Range("B234").Clear

-Range("C234").Clear

-Range("D234").Clear

-Range("A234").Value = "xlHierarchy"

-Range("B234").Value = 1

-Range("C234").Value = num

-B234 = Range("B234").Value

-C234 = Range("C234").Value

-If B234 = C234 Then

-Range("D234").Value = "OK"

-Else

-Range("D234").Value = "NG"

-End If

-End Function

-

-Function test_xlMeasure(ByRef num)

-Range("A235").Clear

-Range("B235").Clear

-Range("C235").Clear

-Range("D235").Clear

-Range("A235").Value = "xlMeasure"

-Range("B235").Value = 2

-Range("C235").Value = num

-B235 = Range("B235").Value

-C235 = Range("C235").Value

-If B235 = C235 Then

-Range("D235").Value = "OK"

-Else

-Range("D235").Value = "NG"

-End If

-End Function

-

-Function test_xlSet(ByRef num)

-Range("A236").Clear

-Range("B236").Clear

-Range("C236").Clear

-Range("D236").Clear

-Range("A236").Value = "xlSet"

-Range("B236").Value = 3

-Range("C236").Value = num

-B236 = Range("B236").Value

-C236 = Range("C236").Value

-If B236 = C236 Then

-Range("D236").Value = "OK"

-Else

-Range("D236").Value = "NG"

-End If

-End Function

-

-Function test_xlCopy(ByRef num)

-Range("A237").Clear

-Range("B237").Clear

-Range("C237").Clear

-Range("D237").Clear

-Range("A237").Value = "xlCopy"

-Range("B237").Value = 1

-Range("C237").Value = num

-B237 = Range("B237").Value

-C237 = Range("C237").Value

-If B237 = C237 Then

-Range("D237").Value = "OK"

-Else

-Range("D237").Value = "NG"

-End If

-End Function

-

-Function test_xlCut(ByRef num)

-Range("A238").Clear

-Range("B238").Clear

-Range("C238").Clear

-Range("D238").Clear

-Range("A238").Value = "xlCut"

-Range("B238").Value = 2

-Range("C238").Value = num

-B238 = Range("B238").Value

-C238 = Range("C238").Value

-If B238 = C238 Then

-Range("D238").Value = "OK"

-Else

-Range("D238").Value = "NG"

-End If

-End Function

-

-Function test_xlValidAlterInformation(ByRef num)

-Range("A239").Clear

-Range("B239").Clear

-Range("C239").Clear

-Range("D239").Clear

-Range("A239").Value = "xlValidAlterInformation"

-Range("B239").Value = 3

-Range("C239").Value = num

-B239 = Range("B239").Value

-C239 = Range("C239").Value

-If B239 = C239 Then

-Range("D239").Value = "OK"

-Else

-Range("D239").Value = "NG"

-End If

-End Function

-

-Function test_xlValidAlterStop(ByRef num)

-Range("A240").Clear

-Range("B240").Clear

-Range("C240").Clear

-Range("D240").Clear

-Range("A240").Value = "xlValidAlterStop"

-Range("B240").Value = 1

-Range("C240").Value = num

-B240 = Range("B240").Value

-C240 = Range("C240").Value

-If B240 = C240 Then

-Range("D240").Value = "OK"

-Else

-Range("D240").Value = "NG"

-End If

-End Function

-

-Function test_xlValidAlterWarning(ByRef num)

-Range("A241").Clear

-Range("B241").Clear

-Range("C241").Clear

-Range("D241").Clear

-Range("A241").Value = "xlValidAlterWarning"

-Range("B241").Value = 2

-Range("C241").Value = num

-B241 = Range("B241").Value

-C241 = Range("C241").Value

-If B241 = C241 Then

-Range("D241").Value = "OK"

-Else

-Range("D241").Value = "NG"

-End If

-End Function

-

-Function test_xlValidateCustom(ByRef num)

-Range("A242").Clear

-Range("B242").Clear

-Range("C242").Clear

-Range("D242").Clear

-Range("A242").Value = "xlValidateCustom"

-Range("B242").Value = 7

-Range("C242").Value = num

-B242 = Range("B242").Value

-C242 = Range("C242").Value

-If B242 = C242 Then

-Range("D242").Value = "OK"

-Else

-Range("D242").Value = "NG"

-End If

-End Function

-

-Function test_xlValidateDate(ByRef num)

-Range("A243").Clear

-Range("B243").Clear

-Range("C243").Clear

-Range("D243").Clear

-Range("A243").Value = "xlValidateDate"

-Range("B243").Value = 4

-Range("C243").Value = num

-B243 = Range("B243").Value

-C243 = Range("C243").Value

-If B243 = C243 Then

-Range("D243").Value = "OK"

-Else

-Range("D243").Value = "NG"

-End If

-End Function

-

-Function test_xlValidateDecimal(ByRef num)

-Range("A244").Clear

-Range("B244").Clear

-Range("C244").Clear

-Range("D244").Clear

-Range("A244").Value = "xlValidateDecimal"

-Range("B244").Value = 2

-Range("C244").Value = num

-B244 = Range("B244").Value

-C244 = Range("C244").Value

-If B244 = C244 Then

-Range("D244").Value = "OK"

-Else

-Range("D244").Value = "NG"

-End If

-End Function

-

-Function test_xlValidateInputOnly(ByRef num)

-Range("A245").Clear

-Range("B245").Clear

-Range("C245").Clear

-Range("D245").Clear

-Range("A245").Value = "xlValidateInputOnly"

-Range("B245").Value = 0

-Range("C245").Value = num

-B245 = Range("B245").Value

-C245 = Range("C245").Value

-If B245 = C245 Then

-Range("D245").Value = "OK"

-Else

-Range("D245").Value = "NG"

-End If

-End Function

-

-Function test_xlValidateList(ByRef num)

-Range("A246").Clear

-Range("B246").Clear

-Range("C246").Clear

-Range("D246").Clear

-Range("A246").Value = "xlValidateList"

-Range("B246").Value = 3

-Range("C246").Value = num

-B246 = Range("B246").Value

-C246 = Range("C246").Value

-If B246 = C246 Then

-Range("D246").Value = "OK"

-Else

-Range("D246").Value = "NG"

-End If

-End Function

-

-Function test_xlValidateTextLength(ByRef num)

-Range("A247").Clear

-Range("B247").Clear

-Range("C247").Clear

-Range("D247").Clear

-Range("A247").Value = "xlValidateTextLength"

-Range("B247").Value = 6

-Range("C247").Value = num

-B247 = Range("B247").Value

-C247 = Range("C247").Value

-If B247 = C247 Then

-Range("D247").Value = "OK"

-Else

-Range("D247").Value = "NG"

-End If

-End Function

-

-Function test_xlValidateTime(ByRef num)

-Range("A248").Clear

-Range("B248").Clear

-Range("C248").Clear

-Range("D248").Clear

-Range("A248").Value = "xlValidateTime"

-Range("B248").Value = 5

-Range("C248").Value = num

-B248 = Range("B248").Value

-C248 = Range("C248").Value

-If B248 = C248 Then

-Range("D248").Value = "OK"

-Else

-Range("D248").Value = "NG"

-End If

-End Function

-

-Function test_xlValidateWholeNumber(ByRef num)

-Range("A249").Clear

-Range("B249").Clear

-Range("C249").Clear

-Range("D249").Clear

-Range("A249").Value = "xlValidateWholeNumber"

-Range("B249").Value = 1

-Range("C249").Value = num

-B249 = Range("B249").Value

-C249 = Range("C249").Value

-If B249 = C249 Then

-Range("D249").Value = "OK"

-Else

-Range("D249").Value = "NG"

-End If

-End Function

-

-Function test_xlLabelPositionAbove(ByRef num)

-Range("A250").Clear

-Range("B250").Clear

-Range("C250").Clear

-Range("D250").Clear

-Range("A250").Value = "xlLabelPositionAbove"

-Range("B250").Value = 0

-Range("C250").Value = num

-B250 = Range("B250").Value

-C250 = Range("C250").Value

-If B250 = C250 Then

-Range("D250").Value = "OK"

-Else

-Range("D250").Value = "NG"

-End If

-End Function

-

-Function test_xlLabelPositionBelow(ByRef num)

-Range("A251").Clear

-Range("B251").Clear

-Range("C251").Clear

-Range("D251").Clear

-Range("A251").Value = "xlLabelPositionBelow"

-Range("B251").Value = 1

-Range("C251").Value = num

-B251 = Range("B251").Value

-C251 = Range("C251").Value

-If B251 = C251 Then

-Range("D251").Value = "OK"

-Else

-Range("D251").Value = "NG"

-End If

-End Function

-

-Function test_xlLabelPositionBestFit(ByRef num)

-Range("A252").Clear

-Range("B252").Clear

-Range("C252").Clear

-Range("D252").Clear

-Range("A252").Value = "xlLabelPositionBestFit"

-Range("B252").Value = 5

-Range("C252").Value = num

-B252 = Range("B252").Value

-C252 = Range("C252").Value

-If B252 = C252 Then

-Range("D252").Value = "OK"

-Else

-Range("D252").Value = "NG"

-End If

-End Function

-

-Function test_xlLabelPositionBestCenter(ByRef num)

-Range("A253").Clear

-Range("B253").Clear

-Range("C253").Clear

-Range("D253").Clear

-Range("A253").Value = "xlLabelPositionBestCenter"

-Range("B253").Value = -4108

-Range("C253").Value = num

-B253 = Range("B253").Value

-C253 = Range("C253").Value

-If B253 = C253 Then

-Range("D253").Value = "OK"

-Else

-Range("D253").Value = "NG"

-End If

-End Function

-

-Function test_xlLabelPositionBestCustom(ByRef num)

-Range("A254").Clear

-Range("B254").Clear

-Range("C254").Clear

-Range("D254").Clear

-Range("A254").Value = "xlLabelPositionBestCustom"

-Range("B254").Value = 7

-Range("C254").Value = num

-B254 = Range("B254").Value

-C254 = Range("C254").Value

-If B254 = C254 Then

-Range("D254").Value = "OK"

-Else

-Range("D254").Value = "NG"

-End If

-End Function

-

-Function test_xlLabelPositionInsideBase(ByRef num)

-Range("A255").Clear

-Range("B255").Clear

-Range("C255").Clear

-Range("D255").Clear

-Range("A255").Value = "xlLabelPositionInsideBase"

-Range("B255").Value = 4

-Range("C255").Value = num

-B255 = Range("B255").Value

-C255 = Range("C255").Value

-If B255 = C255 Then

-Range("D255").Value = "OK"

-Else

-Range("D255").Value = "NG"

-End If

-End Function

-

-Function test_xlLabelPositionInsideEnd(ByRef num)

-Range("A256").Clear

-Range("B256").Clear

-Range("C256").Clear

-Range("D256").Clear

-Range("A256").Value = "xlLabelPositionInsideEnd"

-Range("B256").Value = 3

-Range("C256").Value = num

-B256 = Range("B256").Value

-C256 = Range("C256").Value

-If B256 = C256 Then

-Range("D256").Value = "OK"

-Else

-Range("D256").Value = "NG"

-End If

-End Function

-

-Function test_xlLabelPositionInsideLeft(ByRef num)

-Range("A257").Clear

-Range("B257").Clear

-Range("C257").Clear

-Range("D257").Clear

-Range("A257").Value = "xlLabelPositionInsideLeft"

-Range("B257").Value = -4131

-Range("C257").Value = num

-B257 = Range("B257").Value

-C257 = Range("C257").Value

-If B257 = C257 Then

-Range("D257").Value = "OK"

-Else

-Range("D257").Value = "NG"

-End If

-End Function

-

-Function test_xlLabelPositionMixed(ByRef num)

-Range("A258").Clear

-Range("B258").Clear

-Range("C258").Clear

-Range("D258").Clear

-Range("A258").Value = "xlLabelPositionMixed"

-Range("B258").Value = 6

-Range("C258").Value = num

-B258 = Range("B258").Value

-C258 = Range("C258").Value

-If B258 = C258 Then

-Range("D258").Value = "OK"

-Else

-Range("D258").Value = "NG"

-End If

-End Function

-

-Function test_xlLabelPositionOutsideEnd(ByRef num)

-Range("A259").Clear

-Range("B259").Clear

-Range("C259").Clear

-Range("D259").Clear

-Range("A259").Value = "xlLabelPositionOutsideEnd"

-Range("B259").Value = 2

-Range("C259").Value = num

-B259 = Range("B259").Value

-C259 = Range("C259").Value

-If B259 = C259 Then

-Range("D259").Value = "OK"

-Else

-Range("D259").Value = "NG"

-End If

-End Function

-

-Function test_xlLabelPositionRight(ByRef num)

-Range("A260").Clear

-Range("B260").Clear

-Range("C260").Clear

-Range("D260").Clear

-Range("A260").Value = "xlLabelPositionRight"

-Range("B260").Value = -4152

-Range("C260").Value = num

-B260 = Range("B260").Value

-C260 = Range("C260").Value

-If B260 = C260 Then

-Range("D260").Value = "OK"

-Else

-Range("D260").Value = "NG"

-End If

-End Function

-

-Function test_xlDataLabelSeparatorDefault(ByRef num)

-Range("A261").Clear

-Range("B261").Clear

-Range("C261").Clear

-Range("D261").Clear

-Range("A261").Value = "xlDataLabelSeparatorDefault"

-Range("B261").Value = 1

-Range("C261").Value = num

-B261 = Range("B261").Value

-C261 = Range("C261").Value

-If B261 = C261 Then

-Range("D261").Value = "OK"

-Else

-Range("D261").Value = "NG"

-End If

-End Function

-

-Function test_xlDataLabelsShowBubbleSizes(ByRef num)

-Range("A262").Clear

-Range("B262").Clear

-Range("C262").Clear

-Range("D262").Clear

-Range("A262").Value = "xlDataLabelsShowBubbleSizes"

-Range("B262").Value = 6

-Range("C262").Value = num

-B262 = Range("B262").Value

-C262 = Range("C262").Value

-If B262 = C262 Then

-Range("D262").Value = "OK"

-Else

-Range("D262").Value = "NG"

-End If

-End Function

-

-Function test_xlDataLabelsShowLabel(ByRef num)

-Range("A263").Clear

-Range("B263").Clear

-Range("C263").Clear

-Range("D263").Clear

-Range("A263").Value = "xlDataLabelsShowLabel"

-Range("B263").Value = 4

-Range("C263").Value = num

-B263 = Range("B263").Value

-C263 = Range("C263").Value

-If B263 = C263 Then

-Range("D263").Value = "OK"

-Else

-Range("D263").Value = "NG"

-End If

-End Function

-

-Function test_xlDataLabelsShowLabelAndPercent(ByRef num)

-Range("A264").Clear

-Range("B264").Clear

-Range("C264").Clear

-Range("D264").Clear

-Range("A264").Value = "xlDataLabelsShowLabelAndPercent"

-Range("B264").Value = 5

-Range("C264").Value = num

-B264 = Range("B264").Value

-C264 = Range("C264").Value

-If B264 = C264 Then

-Range("D264").Value = "OK"

-Else

-Range("D264").Value = "NG"

-End If

-End Function

-

-Function test_xlDataLabelsShowNone(ByRef num)

-Range("A265").Clear

-Range("B265").Clear

-Range("C265").Clear

-Range("D265").Clear

-Range("A265").Value = "xlDataLabelsShowNone"

-Range("B265").Value = -4142

-Range("C265").Value = num

-B265 = Range("B265").Value

-C265 = Range("C265").Value

-If B265 = C265 Then

-Range("D265").Value = "OK"

-Else

-Range("D265").Value = "NG"

-End If

-End Function

-

-Function test_xlDataLabelsShowPercent(ByRef num)

-Range("A266").Clear

-Range("B266").Clear

-Range("C266").Clear

-Range("D266").Clear

-Range("A266").Value = "xlDataLabelsShowPercent"

-Range("B266").Value = 3

-Range("C266").Value = num

-B266 = Range("B266").Value

-C266 = Range("C266").Value

-If B266 = C266 Then

-Range("D266").Value = "OK"

-Else

-Range("D266").Value = "NG"

-End If

-End Function

-

-Function test_xlDataLabelsShowValue(ByRef num)

-Range("A267").Clear

-Range("B267").Clear

-Range("C267").Clear

-Range("D267").Clear

-Range("A267").Value = "xlDataLabelsShowValue"

-Range("B267").Value = 2

-Range("C267").Value = num

-B267 = Range("B267").Value

-C267 = Range("C267").Value

-If B267 = C267 Then

-Range("D267").Value = "OK"

-Else

-Range("D267").Value = "NG"

-End If

-End Function

-

-Function test_xlDay(ByRef num)

-Range("A268").Clear

-Range("B268").Clear

-Range("C268").Clear

-Range("D268").Clear

-Range("A268").Value = "xlDay"

-Range("B268").Value = 1

-Range("C268").Value = num

-B268 = Range("B268").Value

-C268 = Range("C268").Value

-If B268 = C268 Then

-Range("D268").Value = "OK"

-Else

-Range("D268").Value = "NG"

-End If

-End Function

-

-Function test_xlMonth(ByRef num)

-Range("A269").Clear

-Range("B269").Clear

-Range("C269").Clear

-Range("D269").Clear

-Range("A269").Value = "xlMonth"

-Range("B269").Value = 3

-Range("C269").Value = num

-B269 = Range("B269").Value

-C269 = Range("C269").Value

-If B269 = C269 Then

-Range("D269").Value = "OK"

-Else

-Range("D269").Value = "NG"

-End If

-End Function

-

-Function test_xlWeekday(ByRef num)

-Range("A270").Clear

-Range("B270").Clear

-Range("C270").Clear

-Range("D270").Clear

-Range("A270").Value = "xlWeekday"

-Range("B270").Value = 2

-Range("C270").Value = num

-B270 = Range("B270").Value

-C270 = Range("C270").Value

-If B270 = C270 Then

-Range("D270").Value = "OK"

-Else

-Range("D270").Value = "NG"

-End If

-End Function

-

-Function test_xlYear(ByRef num)

-Range("A271").Clear

-Range("B271").Clear

-Range("C271").Clear

-Range("D271").Clear

-Range("A271").Value = "xlYear"

-Range("B271").Value = 4

-Range("C271").Value = num

-B271 = Range("B271").Value

-C271 = Range("C271").Value

-If B271 = C271 Then

-Range("D271").Value = "OK"

-Else

-Range("D271").Value = "NG"

-End If

-End Function

-

-Function test_xlAutoFill(ByRef num)

-Range("A272").Clear

-Range("B272").Clear

-Range("C272").Clear

-Range("D272").Clear

-Range("A272").Value = "xlAutoFill"

-Range("B272").Value = 4

-Range("C272").Value = num

-B272 = Range("B272").Value

-C272 = Range("C272").Value

-If B272 = C272 Then

-Range("D272").Value = "OK"

-Else

-Range("D272").Value = "NG"

-End If

-End Function

-

-Function test_xlChronological(ByRef num)

-Range("A273").Clear

-Range("B273").Clear

-Range("C273").Clear

-Range("D273").Clear

-Range("A273").Value = "xlChronological"

-Range("B273").Value = 3

-Range("C273").Value = num

-B273 = Range("B273").Value

-C273 = Range("C273").Value

-If B273 = C273 Then

-Range("D273").Value = "OK"

-Else

-Range("D273").Value = "NG"

-End If

-End Function

-

-Function test_xlDataSeriesLinear(ByRef num)

-Range("A274").Clear

-Range("B274").Clear

-Range("C274").Clear

-Range("D274").Clear

-Range("A274").Value = "xlDataSeriesLinear"

-Range("B274").Value = -4132

-Range("C274").Value = num

-B274 = Range("B274").Value

-C274 = Range("C274").Value

-If B274 = C274 Then

-Range("D274").Value = "OK"

-Else

-Range("D274").Value = "NG"

-End If

-End Function

-

-Function test_xlGrowth(ByRef num)

-Range("A275").Clear

-Range("B275").Clear

-Range("C275").Clear

-Range("D275").Clear

-Range("A275").Value = "xlGrowth"

-Range("B275").Value = 2

-Range("C275").Value = num

-B275 = Range("B275").Value

-C275 = Range("C275").Value

-If B275 = C275 Then

-Range("D275").Value = "OK"

-Else

-Range("D275").Value = "NG"

-End If

-End Function

-

-Function test_xlShiftToLeft(ByRef num)

-Range("A276").Clear

-Range("B276").Clear

-Range("C276").Clear

-Range("D276").Clear

-Range("A276").Value = "xlShiftToLeft"

-Range("B276").Value = -4159

-Range("C276").Value = num

-B276 = Range("B276").Value

-C276 = Range("C276").Value

-If B276 = C276 Then

-Range("D276").Value = "OK"

-Else

-Range("D276").Value = "NG"

-End If

-End Function

-

-Function test_xlShiftUp(ByRef num)

-Range("A277").Clear

-Range("B277").Clear

-Range("C277").Clear

-Range("D277").Clear

-Range("A277").Value = "xlShiftUp"

-Range("B277").Value = -4162

-Range("C277").Value = num

-B277 = Range("B277").Value

-C277 = Range("C277").Value

-If B277 = C277 Then

-Range("D277").Value = "OK"

-Else

-Range("D277").Value = "NG"

-End If

-End Function

-

-Function test_xlDown(ByRef num)

-Range("A278").Clear

-Range("B278").Clear

-Range("C278").Clear

-Range("D278").Clear

-Range("A278").Value = "xlDown"

-Range("B278").Value = -4121

-Range("C278").Value = num

-B278 = Range("B278").Value

-C278 = Range("C278").Value

-If B278 = C278 Then

-Range("D278").Value = "OK"

-Else

-Range("D278").Value = "NG"

-End If

-End Function

-

-Function test_xlToLeft(ByRef num)

-Range("A279").Clear

-Range("B279").Clear

-Range("C279").Clear

-Range("D279").Clear

-Range("A279").Value = "xlToLeft"

-Range("B279").Value = -4159

-Range("C279").Value = num

-B279 = Range("B279").Value

-C279 = Range("C279").Value

-If B279 = C279 Then

-Range("D279").Value = "OK"

-Else

-Range("D279").Value = "NG"

-End If

-End Function

-

-Function test_xlToRight(ByRef num)

-Range("A280").Clear

-Range("B280").Clear

-Range("C280").Clear

-Range("D280").Clear

-Range("A280").Value = "xlToRight"

-Range("B280").Value = -4161

-Range("C280").Value = num

-B280 = Range("B280").Value

-C280 = Range("C280").Value

-If B280 = C280 Then

-Range("D280").Value = "OK"

-Else

-Range("D280").Value = "NG"

-End If

-End Function

-

-Function test_xlUp(ByRef num)

-Range("A281").Clear

-Range("B281").Clear

-Range("C281").Clear

-Range("D281").Clear

-Range("A281").Value = "xlUp"

-Range("B281").Value = -4162

-Range("C281").Value = num

-B281 = Range("B281").Value

-C281 = Range("C281").Value

-If B281 = C281 Then

-Range("D281").Value = "OK"

-Else

-Range("D281").Value = "NG"

-End If

-End Function

-

-Function test_xlInterpolated(ByRef num)

-Range("A282").Clear

-Range("B282").Clear

-Range("C282").Clear

-Range("D282").Clear

-Range("A282").Value = "xlInterpolated"

-Range("B282").Value = 3

-Range("C282").Value = num

-B282 = Range("B282").Value

-C282 = Range("C282").Value

-If B282 = C282 Then

-Range("D282").Value = "OK"

-Else

-Range("D282").Value = "NG"

-End If

-End Function

-

-Function test_xlNotPlotted(ByRef num)

-Range("A283").Clear

-Range("B283").Clear

-Range("C283").Clear

-Range("D283").Clear

-Range("A283").Value = "xlNotPlotted"

-Range("B283").Value = 2

-Range("C283").Value = num

-B283 = Range("B283").Value

-C283 = Range("C283").Value

-If B283 = C283 Then

-Range("D283").Value = "OK"

-Else

-Range("D283").Value = "NG"

-End If

-End Function

-

-Function test_xlZero(ByRef num)

-Range("A284").Clear

-Range("B284").Clear

-Range("C284").Clear

-Range("D284").Clear

-Range("A284").Value = "xlZero"

-Range("B284").Value = 1

-Range("C284").Value = num

-B284 = Range("B284").Value

-C284 = Range("C284").Value

-If B284 = C284 Then

-Range("D284").Value = "OK"

-Else

-Range("D284").Value = "NG"

-End If

-End Function

-

-Function test_xlDisplayShapes(ByRef num)

-Range("A285").Clear

-Range("B285").Clear

-Range("C285").Clear

-Range("D285").Clear

-Range("A285").Value = "xlDisplayShapes"

-Range("B285").Value = -4104

-Range("C285").Value = num

-B285 = Range("B285").Value

-C285 = Range("C285").Value

-If B285 = C285 Then

-Range("D285").Value = "OK"

-Else

-Range("D285").Value = "NG"

-End If

-End Function

-

-Function test_xlHide(ByRef num)

-Range("A286").Clear

-Range("B286").Clear

-Range("C286").Clear

-Range("D286").Clear

-Range("A286").Value = "xlHide"

-Range("B286").Value = 3

-Range("C286").Value = num

-B286 = Range("B286").Value

-C286 = Range("C286").Value

-If B286 = C286 Then

-Range("D286").Value = "OK"

-Else

-Range("D286").Value = "NG"

-End If

-End Function

-

-Function test_xlPlaceholders(ByRef num)

-Range("A287").Clear

-Range("B287").Clear

-Range("C287").Clear

-Range("D287").Clear

-Range("A287").Value = "xlPlaceholders"

-Range("B287").Value = 2

-Range("C287").Value = num

-B287 = Range("B287").Value

-C287 = Range("C287").Value

-If B287 = C287 Then

-Range("D287").Value = "OK"

-Else

-Range("D287").Value = "NG"

-End If

-End Function

-

-Function test_xlHundredMillions(ByRef num)

-Range("A288").Clear

-Range("B288").Clear

-Range("C288").Clear

-Range("D288").Clear

-Range("A288").Value = "xlHundredMillions"

-Range("B288").Value = -8

-Range("C288").Value = num

-B288 = Range("B288").Value

-C288 = Range("C288").Value

-If B288 = C288 Then

-Range("D288").Value = "OK"

-Else

-Range("D288").Value = "NG"

-End If

-End Function

-

-Function test_xlHundreds(ByRef num)

-Range("A289").Clear

-Range("B289").Clear

-Range("C289").Clear

-Range("D289").Clear

-Range("A289").Value = "xlHundreds"

-Range("B289").Value = -2

-Range("C289").Value = num

-B289 = Range("B289").Value

-C289 = Range("C289").Value

-If B289 = C289 Then

-Range("D289").Value = "OK"

-Else

-Range("D289").Value = "NG"

-End If

-End Function

-

-Function test_xlHundredThousands(ByRef num)

-Range("A290").Clear

-Range("B290").Clear

-Range("C290").Clear

-Range("D290").Clear

-Range("A290").Value = "xlHundredThousands"

-Range("B290").Value = -5

-Range("C290").Value = num

-B290 = Range("B290").Value

-C290 = Range("C290").Value

-If B290 = C290 Then

-Range("D290").Value = "OK"

-Else

-Range("D290").Value = "NG"

-End If

-End Function

-

-Function test_xlMillionMillons(ByRef num)

-Range("A291").Clear

-Range("B291").Clear

-Range("C291").Clear

-Range("D291").Clear

-Range("A291").Value = "xlMillionMillons"

-Range("B291").Value = -10

-Range("C291").Value = num

-B291 = Range("B291").Value

-C291 = Range("C291").Value

-If B291 = C291 Then

-Range("D291").Value = "OK"

-Else

-Range("D291").Value = "NG"

-End If

-End Function

-

-Function test_xlMillions(ByRef num)

-Range("A292").Clear

-Range("B292").Clear

-Range("C292").Clear

-Range("D292").Clear

-Range("A292").Value = "xlMillions"

-Range("B292").Value = -6

-Range("C292").Value = num

-B292 = Range("B292").Value

-C292 = Range("C292").Value

-If B292 = C292 Then

-Range("D292").Value = "OK"

-Else

-Range("D292").Value = "NG"

-End If

-End Function

-

-Function test_xlTenMillions(ByRef num)

-Range("A293").Clear

-Range("B293").Clear

-Range("C293").Clear

-Range("D293").Clear

-Range("A293").Value = "xlTenMillions"

-Range("B293").Value = -7

-Range("C293").Value = num

-B293 = Range("B293").Value

-C293 = Range("C293").Value

-If B293 = C293 Then

-Range("D293").Value = "OK"

-Else

-Range("D293").Value = "NG"

-End If

-End Function

-

-Function test_xlTenThousands(ByRef num)

-Range("A294").Clear

-Range("B294").Clear

-Range("C294").Clear

-Range("D294").Clear

-Range("A294").Value = "xlTenThousands"

-Range("B294").Value = -4

-Range("C294").Value = num

-B294 = Range("B294").Value

-C294 = Range("C294").Value

-If B294 = C294 Then

-Range("D294").Value = "OK"

-Else

-Range("D294").Value = "NG"

-End If

-End Function

-

-Function test_xlThousandMillions(ByRef num)

-Range("A295").Clear

-Range("B295").Clear

-Range("C295").Clear

-Range("D295").Clear

-Range("A295").Value = "xlThousandMillions"

-Range("B295").Value = -9

-Range("C295").Value = num

-B295 = Range("B295").Value

-C295 = Range("C295").Value

-If B295 = C295 Then

-Range("D295").Value = "OK"

-Else

-Range("D295").Value = "NG"

-End If

-End Function

-

-Function test_xlThousands(ByRef num)

-Range("A296").Clear

-Range("B296").Clear

-Range("C296").Clear

-Range("D296").Clear

-Range("A296").Value = "xlThousands"

-Range("B296").Value = -3

-Range("C296").Value = num

-B296 = Range("B296").Value

-C296 = Range("C296").Value

-If B296 = C296 Then

-Range("D296").Value = "OK"

-Else

-Range("D296").Value = "NG"

-End If

-End Function

-

-<<<<<<
-======================
-Module5
->>>>>>
-Attribute VB_Name = "Module5"

-

-Sub main_5()

-test_XlEditionFormat (XlEditionFormat)

-test_xlAutomaticUpdate (xlAutomaticUpdate)

-test_xlCancel (xlCancel)

-test_xlChangeAttributes (xlChangeAttributes)

-test_xlManualUpdate (xlManualUpdate)

-test_xlOpenSource (xlOpenSource)

-test_xlSelect (xlSelect)

-test_xlSendPublisher (xlSendPublisher)

-test_xlUpdateSubscriber (xlUpdateSubscriber)

-test_xlPublisher (xlPublisher)

-test_xlSubscriber (xlSubscriber)

-test_xlDisabled (xlDisabled)

-test_xlErrorHandler (xlErrorHandler)

-test_xlInterrupt (xlInterrupt)

-test_xlNoRestrictions (xlNoRestrictions)

-test_xlNoSelection (xlNoSelection)

-test_xlUnlockedCells (xlUnlockedCells)

-test_xlCap (xlCap)

-test_xlNoCap (xlNoCap)

-test_xlX (xlX)

-test_xlY (xlY)

-test_xlErrorBarIncludeBoth (xlErrorBarIncludeBoth)

-test_xlErrorBarIncludeMinusValues (xlErrorBarIncludeMinusValues)

-test_xlErrorBarIncludeNone (xlErrorBarIncludeNone)

-test_xlErrorBarIncludePlusValues (xlErrorBarIncludePlusValues)

-test_xlErrorBarTypeCustom (xlErrorBarTypeCustom)

-test_xlErrorBarTypeFixedValue (xlErrorBarTypeFixedValue)

-test_xlErrorBarTypePercent (xlErrorBarTypePercent)

-test_xlErrorBarTypeStDev (xlErrorBarTypeStDev)

-test_xlErrorBarTypeStError (xlErrorBarTypeStError)

-test_xlEmptyCellReferences (xlEmptyCellReferences)

-test_xlEvaluateToError (xlEvaluateToError)

-test_xlInconsistentFormula (xlInconsistentFormula)

-test_xlListDataValidation (xlListDataValidation)

-test_xlNumberAsText (xlNumberAsText)

-test_xlOmittedCells (xlOmittedCells)

-test_xlTextDate (xlTextDate)

-test_xlUnlockedFormulaCells (xlUnlockedFormulaCells)

-test_xlReadOnly (xlReadOnly)

-test_xlReadWrite (xlReadWrite)

-test_xlAddIn (xlAddIn)

-test_xlCSV (xlCSV)

-test_xlCSVMac (xlCSVMac)

-test_xlCSVMSDOS (xlCSVMSDOS)

-test_xlCSVWindows (xlCSVWindows)

-test_xlCurrentPlatformText (xlCurrentPlatformText)

-test_xlDBF2 (xlDBF2)

-test_xlDBF3 (xlDBF3)

-test_xlDBF4 (xlDBF4)

-test_xlDIF (xlDIF)

-test_xlExcel2 (xlExcel2)

-test_xlExcel2FarEast (xlExcel2FarEast)

-test_xlExcel3 (xlExcel3)

-test_xlExcel4 (xlExcel4)

-test_xlExcel4Wordbook (xlExcel4Wordbook)

-test_xlExcel5 (xlExcel5)

-test_xlExcel7 (xlExcel7)

-test_xlExcel9795 (xlExcel9795)

-test_xlHtml (xlHtml)

-test_xlIntlAddIn (xlIntlAddIn)

-test_xlIntlMacro (xlIntlMacro)

-test_xlSYLK (xlSYLK)

-test_xlTemplate (xlTemplate)

-test_xlTextMac (xlTextMac)

-test_xlTextMSDOS (xlTextMSDOS)

-test_xlTextPrinter (xlTextPrinter)

-test_xlTextWindows (xlTextWindows)

-test_xlUnicodeText (xlUnicodeText)

-test_xlWebArchive (xlWebArchive)

-test_xlWJ2WD1 (xlWJ2WD1)

-test_xlWJ3 (xlWJ3)

-test_xlWJ3FJ3 (xlWJ3FJ3)

-test_xlWK1 (xlWK1)

-test_xlWK1ALL (xlWK1ALL)

-test_xlWK1FMT (xlWK1FMT)

-test_xlWK3 (xlWK3)

-test_xlWK3FM3 (xlWK3FM3)

-test_xlWK4 (xlWK4)

-test_xlWKS (xlWKS)

-test_xlWordbookNormal (xlWordbookNormal)

-test_xlWords2FarEast (xlWords2FarEast)

-test_xlWQ1 (xlWQ1)

-test_xlXMLSpredsheet (xlXMLSpredsheet)

-test_xlFillWithAll (xlFillWithAll)

-test_xlFillWithContents (xlFillWithContents)

-test_xlFillWithFormats (xlFillWithFormats)

-test_xlFilterCopy (xlFilterCopy)

-test_xlFilterInPlace (xlFilterInPlace)

-test_xlComments (xlComments)

-test_xlFormulas (xlFormulas)

-test_xlValues (xlValues)

-test_xlButtonControl (xlButtonControl)

-test_xlCheckBox (xlCheckBox)

-test_xlDropDown (xlDropDown)

-test_xlEditBox (xlEditBox)

-test_xlGroupBox (xlGroupBox)

-test_xlLabel (xlLabel)

-test_xlListBox (xlListBox)

-test_xlOptionButton (xlOptionButton)

-test_xlSchollBar (xlSchollBar)

-test_xlSpinner (xlSpinner)

-test_xlBetween (xlBetween)

-test_xlEqual (xlEqual)

-test_xlGreater (xlGreater)

-test_xlGreaterEqual (xlGreaterEqual)

-test_xlLess (xlLess)

-test_xlLessEqual (xlLessEqual)

-test_xlNotBetween (xlNotBetween)

-test_xlNotEqual (xlNotEqual)

-test_xlCellValue (xlCellValue)

-test_xlExpression (xlExpression)

-test_xlColumnLabels (xlColumnLabels)

-test_xlMixedLabels (xlMixedLabels)

-test_xlNoLabels (xlNoLabels)

-test_xlRowLabels (xlRowLabels)

-test_xlHAlignCenter (xlHAlignCenter)

-test_xlHAlignCenterAcrossSelection (xlHAlignCenterAcrossSelection)

-test_xlHAlignDistributed (xlHAlignDistributed)

-test_xlHAlignFull (xlHAlignFull)

-test_xlHAlignGeneral (xlHAlignGeneral)

-test_xlHAlignJustify (xlHAlignJustify)

-test_xlHAlignLeft (xlHAlignLeft)

-test_xlHAlignRight (xlHAlignRight)

-test_xlHebrewFullScript (xlHebrewFullScript)

-test_xlHebrewMixedAuthorizedScript (xlHebrewMixedAuthorizedScript)

-test_xlHebrewMixedScript (xlHebrewMixedScript)

-test_xlHebrewPartialScript (xlHebrewPartialScript)

-test_xlAllChanges (xlAllChanges)

-test_xlNotYetReviewed (xlNotYetReviewed)

-test_xlSinceMyLastSave (xlSinceMyLastSave)

-test_xlHtmlCalc (xlHtmlCalc)

-test_xlHtmlChart (xlHtmlChart)

-test_xlHtmlList (xlHtmlList)

-test_xlHtmlStatic (xlHtmlStatic)

-test_xlIMEModeAlpha (xlIMEModeAlpha)

-test_xlIMEModeAlphaFull (xlIMEModeAlphaFull)

-test_xlIMEModeDisable (xlIMEModeDisable)

-test_xlIMEModeHangul (xlIMEModeHangul)

-test_xlIMEModeHangulFull (xlIMEModeHangulFull)

-test_xlIMEModeHiragana (xlIMEModeHiragana)

-test_xlIMEModeKatakana (xlIMEModeKatakana)

-test_xlIMEModeKatakanaHalf (xlIMEModeKatakanaHalf)

-test_xlIMEModeNoControl (xlIMEModeNoControl)

-test_xlIMEModeOff (xlIMEModeOff)

-test_xlIMEModeOn (xlIMEModeOn)

-test_xlPivotTableReport (xlPivotTableReport)

-test_xlQueryTable (xlQueryTable)

-test_xlFormatFromLeftOrAbove (xlFormatFromLeftOrAbove)

-test_xlFormatFromRightOrAbove (xlFormatFromRightOrAbove)

-test_xlShiftDown (xlShiftDown)

-test_xlShiftToRight (xlShiftToRight)

-test_xlOutline (xlOutline)

-test_xlTabular (xlTabular)

-test_xlLegendPositionBottom (xlLegendPositionBottom)

-test_xlLegendPositionCorner (xlLegendPositionCorner)

-test_xlLegendPositionLeft (xlLegendPositionLeft)

-test_xlLegendPositionRight (xlLegendPositionRight)

-test_xlLegendPositionTop (xlLegendPositionTop)

-test_xlContinuous (xlContinuous)

-test_xlDash (xlDash)

-test_xlDashDot (xlDashDot)

-test_xlDashDotDot (xlDashDotDot)

-test_xlDot (xlDot)

-test_xlDouble (xlDouble)

-test_xlLineStyleNone (xlLineStyleNone)

-test_xlSlantDashDot (xlSlantDashDot)

-test_xlExcelLink (xlExcelLink)

-test_xlPublishers (xlPublishers)

-test_xlSubscribers (xlSubscribers)

-test_xlEditionDate (xlEditionDate)

-test_xlLinkInfoStatus (xlLinkInfoStatus)

-test_xlUpdateState (xlUpdateState)

-test_xlLinkInfoOLELinks (xlLinkInfoOLELinks)

-test_xlLinkInfoPublishers (xlLinkInfoPublishers)

-test_xlLinkInfoSubscribers (xlLinkInfoSubscribers)

-test_xlLinkStatusCopiedValues (xlLinkStatusCopiedValues)

-test_xlLinkStatusIndeterminate (xlLinkStatusIndeterminate)

-test_xlLinkStatusInvalidName (xlLinkStatusInvalidName)

-test_xlLinkStatusMissingFile (xlLinkStatusMissingFile)

-test_xlLinkStatusMissingSheet (xlLinkStatusMissingSheet)

-test_xlLinkStatusNotStarted (xlLinkStatusNotStarted)

-test_xlLinkStatusOK (xlLinkStatusOK)

-test_xlLinkStatusOld (xlLinkStatusOld)

-test_xlLinkStatusSourceNotCalculated (xlLinkStatusSourceNotCalculated)

-test_xlLinkStatusSourceNotOpen (xlLinkStatusSourceNotOpen)

-test_xlLinkStatusSourceOpen (xlLinkStatusSourceOpen)

-test_xlLinkTypeExcelLinks (xlLinkTypeExcelLinks)

-test_xlLinkTypeOLELinks (xlLinkTypeOLELinks)

-test_xlListConflictDialog (xlListConflictDialog)

-test_xlListConflictDiscardAllConflicts (xlListConflictDiscardAllConflicts)

-test_xlListConflictError (xlListConflictError)

-test_xlListConflictRetryAllConflicts (xlListConflictRetryAllConflicts)

-test_xlListDataTypeCheckbox (xlListDataTypeCheckbox)

-test_xlListDataTypeChoice (xlListDataTypeChoice)

-test_xlListDataTypeChoiceMulti (xlListDataTypeChoiceMulti)

-test_xlListDataTypeCounter (xlListDataTypeCounter)

-test_xlListDataTypeCurrency (xlListDataTypeCurrency)

-test_xlListDataTypeDateTime (xlListDataTypeDateTime)

-test_xlListDataTypeHyperLink (xlListDataTypeHyperLink)

-test_xlListDataTypeListLookup (xlListDataTypeListLookup)

-test_xlListDataTypeMultiLineRichText (xlListDataTypeMultiLineRichText)

-test_xlListDataTypeMultiLineText (xlListDataTypeMultiLineText)

-test_xlListDataTypeNone (xlListDataTypeNone)

-test_xlListDataTypeNumber (xlListDataTypeNumber)

-test_xlListDataTypeText (xlListDataTypeText)

-test_xlSrcExternal (xlSrcExternal)

-test_xlSrcRange (xlSrcRange)

-test_xlSrcXml (xlSrcXml)

-test_xlColumnHeader (xlColumnHeader)

-test_xlColumnItem (xlColumnItem)

-test_xlDataHeader (xlDataHeader)

-test_xlDataItem (xlDataItem)

-test_xlPageHeader (xlPageHeader)

-test_xlPageItem (xlPageItem)

-test_xlRowHeader (xlRowHeader)

-test_xlRowItem (xlRowItem)

-test_xlTableBody (xlTableBody)

-test_xlPart (xlPart)

-test_xlWhole (xlWhole)

-test_xlMicrosoftAccess (xlMicrosoftAccess)

-test_xlMicrosoftFoxPro (xlMicrosoftFoxPro)

-test_xlMicrosoftMail (xlMicrosoftMail)

-test_xlMicrosoftPowerPoint (xlMicrosoftPowerPoint)

-test_xlMicrosoftProject (xlMicrosoftProject)

-test_xlMicrosoftSchedulePlus (xlMicrosoftSchedulePlus)

-test_xlMicrosoftWord (xlMicrosoftWord)

-test_xlMAPI (xlMAPI)

-test_xlNoMailSystem (xlNoMailSystem)

-test_xlPowerTalk (xlPowerTalk)

-test_xlMarkerStyleAutomatic (xlMarkerStyleAutomatic)

-test_xlMarkerStyleCircle (xlMarkerStyleCircle)

-test_xlMarkerStyleDash (xlMarkerStyleDash)

-test_xlMarkerStyleDiamond (xlMarkerStyleDiamond)

-test_xlMarkerStyleDot (xlMarkerStyleDot)

-test_xlMarkerStyleNone (xlMarkerStyleNone)

-test_xlMarkerStylePicture (xlMarkerStylePicture)

-test_xlMarkerStylePlus (xlMarkerStylePlus)

-test_xlMarkerStyleSquare (xlMarkerStyleSquare)

-test_xlMarkerStyleStar (xlMarkerStyleStar)

-test_xlMarkerStyleTiangle (xlMarkerStyleTiangle)

-test_xlMarkerStyleX (xlMarkerStyleX)

-test_xlNoButton (xlNoButton)

-test_xlPrimaryButton (xlPrimaryButton)

-test_xlSecondaryButton (xlSecondaryButton)

-test_xlDefault (xlDefault)

-test_xlIBeam (xlIBeam)

-test_xlNorthwestArrow (xlNorthwestArrow)

-test_xlWait (xlWait)

-test_XlOLEControl (XlOLEControl)

-test_XlOLEEmbed (XlOLEEmbed)

-test_XlOLELink (XlOLELink)

-test_XlVerbOpen (XlVerbOpen)

-test_XlVerbPrimary (XlVerbPrimary)

-test_xlFitToPage (xlFitToPage)

-test_xlFullPage (xlFullPage)

-test_xlScreenSize (xlScreenSize)

-test_xlDownThenOver (xlDownThenOver)

-test_xlOverThenDown (xlOverThenDown)

-test_xlDownward (xlDownward)

-test_xlHorizontal (xlHorizontal)

-test_xlUpward (xlUpward)

-test_xlVertical (xlVertical)

-test_xlBlanks (xlBlanks)

-test_xlButton (xlButton)

-test_xlDataAndLabel (xlDataAndLabel)

-test_xlDataOnly (xlDataOnly)

-test_xlFirstRow (xlFirstRow)

-test_xlLabelOnly (xlLabelOnly)

-test_xlOrigin (xlOrigin)

-test_XlPageBreakAutomatic (XlPageBreakAutomatic)

-test_XlPageBreakManual (XlPageBreakManual)

-test_XlPageBreakNone (XlPageBreakNone)

-test_xlPageBreakFull (xlPageBreakFull)

-test_xlPageBreakPartial (xlPageBreakPartial)

-test_xlLandscape (xlLandscape)

-test_xlPortrait (xlPortrait)

-test_xlPaper10x14 (xlPaper10x14)

-test_xlPaper11x17 (xlPaper11x17)

-test_xlPaperA3 (xlPaperA3)

-test_xlPaperA4Small (xlPaperA4Small)

-test_xlPaperA5 (xlPaperA5)

-test_xlPaperB4 (xlPaperB4)

-test_xlPaperB5 (xlPaperB5)

-test_xlPaperCsheet (xlPaperCsheet)

-test_xlPaperDsheet (xlPaperDsheet)

-test_xlPaperEnvelope10 (xlPaperEnvelope10)

-test_xlPaperEnvelope11 (xlPaperEnvelope11)

-test_xlPaperEnvelope12 (xlPaperEnvelope12)

-test_xlPaperEnvelope14 (xlPaperEnvelope14)

-test_xlPaperEnvelope9 (xlPaperEnvelope9)

-test_xlPaperEnvelopeB4 (xlPaperEnvelopeB4)

-test_xlPaperEnvelopeB5 (xlPaperEnvelopeB5)

-test_xlPaperEnvelopeB6 (xlPaperEnvelopeB6)

-test_xlPaperEnvelopeC3 (xlPaperEnvelopeC3)

-test_xlPaperEnvelopeC4 (xlPaperEnvelopeC4)

-test_xlPaperEnvelopeC5 (xlPaperEnvelopeC5)

-test_xlPaperEnvelopeC6 (xlPaperEnvelopeC6)

-test_xlPaperEnvelopeC65 (xlPaperEnvelopeC65)

-test_xlPaperEnvelopeDL (xlPaperEnvelopeDL)

-test_xlPaperEnvelopeItaly (xlPaperEnvelopeItaly)

-test_xlPaperEnvelopeMonarch (xlPaperEnvelopeMonarch)

-test_xlPaperEnvelopePersonal (xlPaperEnvelopePersonal)

-test_xlPaperEsheet (xlPaperEsheet)

-test_xlPaperExective (xlPaperExective)

-test_xlPaperFanfoldLegalGerman (xlPaperFanfoldLegalGerman)

-test_xlPaperFanfoldStdGerman (xlPaperFanfoldStdGerman)

-test_xlPaperFanfoldUS (xlPaperFanfoldUS)

-test_xlPaperFolio (xlPaperFolio)

-test_xlPaperLedger (xlPaperLedger)

-test_xlPaperLegal (xlPaperLegal)

-test_xlPaperLetter (xlPaperLetter)

-test_xlPaperLetterSmall (xlPaperLetterSmall)

-test_xlPaperNote (xlPaperNote)

-test_xlPaperQuarto (xlPaperQuarto)

-test_xlPaperStatement (xlPaperStatement)

-test_xlPaperTabloid (xlPaperTabloid)

-test_xlPaperUser (xlPaperUser)

-test_xlParameterTypeBigInt (xlParameterTypeBigInt)

-test_xlParameterTypeBinary (xlParameterTypeBinary)

-test_xlParameterTypeBit (xlParameterTypeBit)

-test_xlParameterTypeChar (xlParameterTypeChar)

-test_xlParameterTypeData (xlParameterTypeData)

-test_xlParameterTypeDecimal (xlParameterTypeDecimal)

-test_xlParameterTypeDouble (xlParameterTypeDouble)

-test_xlParameterTypeFloat (xlParameterTypeFloat)

-test_xlParameterTypeInteger (xlParameterTypeInteger)

-test_xlParameterTypeLongVarBinary (xlParameterTypeLongVarBinary)

-test_xlParameterTypeLongVarChar (xlParameterTypeLongVarChar)

-test_xlParameterTypeNumeric (xlParameterTypeNumeric)

-test_xlParameterTypeReal (xlParameterTypeReal)

-test_xlParameterTypeSmallInt (xlParameterTypeSmallInt)

-test_xlParameterTypeTime (xlParameterTypeTime)

-test_xlParameterTypeTimestamp (xlParameterTypeTimestamp)

-test_xlParameterTypeTinyInt (xlParameterTypeTinyInt)

-test_xlParameterTypeUnknown (xlParameterTypeUnknown)

-test_xlParameterTypeVarBinary (xlParameterTypeVarBinary)

-test_xlParameterTypeVarChar (xlParameterTypeVarChar)

-test_xlParameterTypeWChar (xlParameterTypeWChar)

-test_xlConstant (xlConstant)

-test_xlPrompt (xlPrompt)

-test_xlRange (xlRange)

-test_xlPasteSpecialOperationAdd (xlPasteSpecialOperationAdd)

-test_xlPasteSpecialOperationDivide (xlPasteSpecialOperationDivide)

-test_xlPasteSpecialOperationMultiply (xlPasteSpecialOperationMultiply)

-test_xlPasteSpecialOperationNone (xlPasteSpecialOperationNone)

-test_xlPasteSpecialOperationSubstract (xlPasteSpecialOperationSubstract)

-test_xlPasteAll (xlPasteAll)

-test_xlPasteAllExceptBorders (xlPasteAllExceptBorders)

-test_xlPasteAllColumnWidths (xlPasteAllColumnWidths)

-test_xlPasteComments (xlPasteComments)

-test_xlPasteFormats (xlPasteFormats)

-test_xlPasteFormulas (xlPasteFormulas)

-test_xlPasteFormulasAndNumberFormats (xlPasteFormulasAndNumberFormats)

-test_xlPasteValidation (xlPasteValidation)

-test_xlPasteValues (xlPasteValues)

-test_xlPasteValuesAndNumberFormats (xlPasteValuesAndNumberFormats)

-test_xlPatternAutomatic (xlPatternAutomatic)

-test_xlPatternChecker (xlPatternChecker)

-test_xlPatternCrissCross (xlPatternCrissCross)

-test_xlPatternDown (xlPatternDown)

-test_xlPatternGray16 (xlPatternGray16)

-test_xlPatternGray25 (xlPatternGray25)

-test_xlPatternGray50 (xlPatternGray50)

-test_xlPatternGray75 (xlPatternGray75)

-test_xlPatternGray8 (xlPatternGray8)

-test_xlPatternGrid (xlPatternGrid)

-test_xlPatternHorizontal (xlPatternHorizontal)

-test_xlPatternLightDown (xlPatternLightDown)

-test_xlPatternLightHorizontal (xlPatternLightHorizontal)

-test_xlPatternLightUp (xlPatternLightUp)

-test_xlPatternLightVertical (xlPatternLightVertical)

-test_xlPatternNone (xlPatternNone)

-test_xlPatternSemiGray75 (xlPatternSemiGray75)

-test_xlPatternSolid (xlPatternSolid)

-test_xlPatternUp (xlPatternUp)

-test_xlPatternVertical (xlPatternVertical)

-test_XlPhoneticAlignCenter (XlPhoneticAlignCenter)

-test_XlPhoneticAlignDistributed (XlPhoneticAlignDistributed)

-test_XlPhoneticAlignLeft (XlPhoneticAlignLeft)

-test_XlPhoneticAlignNoControl (XlPhoneticAlignNoControl)

-test_xlPrinter (xlPrinter)

-test_xlScreen (xlScreen)

-test_xlBMP (xlBMP)

-test_xlCGM (xlCGM)

-test_xlDRW (xlDRW)

-test_xlDXF (xlDXF)

-test_xlEPS (xlEPS)

-test_xlHGL (xlHGL)

-test_xlPCT (xlPCT)

-test_xlPCX (xlPCX)

-test_xlPIC (xlPIC)

-test_xlPLT (xlPLT)

-test_xlTIF (xlTIF)

-test_xlWMF (xlWMF)

-test_xlWPG (xlWPG)

-test_xlPivotCellBlankCell (xlPivotCellBlankCell)

-test_xlPivotCellCustomSubtotal (xlPivotCellCustomSubtotal)

-test_xlPivotCellDataField (xlPivotCellDataField)

-test_xlPivotCellDataPivotField (xlPivotCellDataPivotField)

-test_xlPivotCellGrandTotal (xlPivotCellGrandTotal)

-test_xlPivotCellPageFieldItem (xlPivotCellPageFieldItem)

-test_xlPivotCellPivotField (xlPivotCellPivotField)

-test_xlPivotCellPivotItem (xlPivotCellPivotItem)

-test_xlPivotCellSubtotal (xlPivotCellSubtotal)

-test_xlPivotCellValue (xlPivotCellValue)

-test_xlDifferenceFrom (xlDifferenceFrom)

-test_xlIndex (xlIndex)

-test_xlNoAdditionalCalculation (xlNoAdditionalCalculation)

-test_xlPercentDifferenceFrom (xlPercentDifferenceFrom)

-test_xlPercentOf (xlPercentOf)

-test_xlPercentOfColumn (xlPercentOfColumn)

-test_xlPercentOfRow (xlPercentOfRow)

-test_xlPercentOfTotal (xlPercentOfTotal)

-test_xlRunningTotal (xlRunningTotal)

-test_xlDate (xlDate)

-test_xlNumber (xlNumber)

-test_xlText (xlText)

-test_xlColumnField (xlColumnField)

-test_xlDataField (xlDataField)

-test_xlHidden (xlHidden)

-test_xlPageField (xlPageField)

-test_xlRowField (xlRowField)

-test_xlPTClassic (xlPTClassic)

-test_xlPTNone (xlPTNone)

-test_xlReport1 (xlReport1)

-test_xlReport10 (xlReport10)

-test_xlReport2 (xlReport2)

-test_xlReport3 (xlReport3)

-test_xlReport4 (xlReport4)

-test_xlReport5 (xlReport5)

-test_xlReport6 (xlReport6)

-test_xlReport7 (xlReport7)

-test_xlReport8 (xlReport8)

-test_xlReport9 (xlReport9)

-test_xlTable1 (xlTable1)

-test_xlTable10 (xlTable10)

-test_xlTable2 (xlTable2)

-test_xlTable3 (xlTable3)

-test_xlTable4 (xlTable4)

-test_xlTable5 (xlTable5)

-test_xlTable6 (xlTable6)

-test_xlTable7 (xlTable7)

-test_xlTable8 (xlTable8)

-test_xlTable9 (xlTable9)

-test_xlMissingItemsDefault (xlMissingItemsDefault)

-test_xlMissingItemsMax (xlMissingItemsMax)

-test_xlMissingItemsNone (xlMissingItemsNone)

-test_xlConsolidation (xlConsolidation)

-test_xlDatabase (xlDatabase)

-test_xlExternal (xlExternal)

-test_xlPivotTable (xlPivotTable)

-test_xlScenario (xlScenario)

-test_xlPivotTableVersion10 (xlPivotTableVersion10)

-test_xlPivotTableVersion2000 (xlPivotTableVersion2000)

-test_xlPivotTableCurrent (xlPivotTableCurrent)

-test_xlFreeFloating (xlFreeFloating)

-test_xlMove (xlMove)

-test_xlMoveAndSize (xlMoveAndSize)

-test_xlMacintosh (xlMacintosh)

-test_xlMSDOS (xlMSDOS)

-test_xlWindows (xlWindows)

-test_xlPrintErrorsBlank (xlPrintErrorsBlank)

-test_xlPrintErrorsDash (xlPrintErrorsDash)

-test_xlPrintErrorsDisplayed (xlPrintErrorsDisplayed)

-test_xlPrintErrorsNA (xlPrintErrorsNA)

-test_xlPrintLocation (xlPrintLocation)

-test_xlPrintNoComments (xlPrintNoComments)

-test_xlPrintSheetEnd (xlPrintSheetEnd)

-test_xlPriorityHigh (xlPriorityHigh)

-test_xlPriorityLow (xlPriorityLow)

-test_xlPriorityNormal (xlPriorityNormal)

-test_xlADORecordset (xlADORecordset)

-test_xlDAORecordset (xlDAORecordset)

-test_xlODBCQuery (xlODBCQuery)

-test_xlOLEDBQuery (xlOLEDBQuery)

-test_xlTextImport (xlTextImport)

-test_xlWebQuery (xlWebQuery)

-test_xlRangeAutoFormat3DEffects1 (xlRangeAutoFormat3DEffects1)

-test_xlRangeAutoFormat3DEffects2 (xlRangeAutoFormat3DEffects2)

-test_xlRangeAutoFormatAccounting1 (xlRangeAutoFormatAccounting1)

-test_xlRangeAutoFormatAccounting2 (xlRangeAutoFormatAccounting2)

-test_xlRangeAutoFormatAccounting3 (xlRangeAutoFormatAccounting3)

-test_xlRangeAutoFormatAccounting4 (xlRangeAutoFormatAccounting4)

-test_xlRangeAutoFormatClassic1 (xlRangeAutoFormatClassic1)

-test_xlRangeAutoFormatClassic2 (xlRangeAutoFormatClassic2)

-test_xlRangeAutoFormatClassic3 (xlRangeAutoFormatClassic3)

-test_xlRangeAutoFormatClassicPivotTable (xlRangeAutoFormatClassicPivotTable)

-test_xlRangeAutoFormatColor1 (xlRangeAutoFormatColor1)

-test_xlRangeAutoFormatColor2 (xlRangeAutoFormatColor2)

-test_xlRangeAutoFormatColor3 (xlRangeAutoFormatColor3)

-test_xlRangeAutoFormatList1 (xlRangeAutoFormatList1)

-test_xlRangeAutoFormatList2 (xlRangeAutoFormatList2)

-test_xlRangeAutoFormatList3 (xlRangeAutoFormatList3)

-test_xlRangeAutoFormatLocalFormat1 (xlRangeAutoFormatLocalFormat1)

-test_xlRangeAutoFormatLocalFormat2 (xlRangeAutoFormatLocalFormat2)

-test_xlRangeAutoFormatLocalFormat3 (xlRangeAutoFormatLocalFormat3)

-test_xlRangeAutoFormatLocalFormat4 (xlRangeAutoFormatLocalFormat4)

-test_xlRangeAutoFormatNone (xlRangeAutoFormatNone)

-test_xlRangeAutoFormatPTNone (xlRangeAutoFormatPTNone)

-test_xlRangeAutoFormatReport1 (xlRangeAutoFormatReport1)

-test_xlRangeAutoFormatReport10 (xlRangeAutoFormatReport10)

-test_xlRangeAutoFormatReport2 (xlRangeAutoFormatReport2)

-test_xlRangeAutoFormatReport3 (xlRangeAutoFormatReport3)

-test_xlRangeAutoFormatReport4 (xlRangeAutoFormatReport4)

-test_xlRangeAutoFormatReport5 (xlRangeAutoFormatReport5)

-test_xlRangeAutoFormatReport6 (xlRangeAutoFormatReport6)

-test_xlRangeAutoFormatReport7 (xlRangeAutoFormatReport7)

-test_xlRangeAutoFormatReport8 (xlRangeAutoFormatReport8)

-test_xlRangeAutoFormatReport9 (xlRangeAutoFormatReport9)

-test_xlRangeAutoFormatSimple (xlRangeAutoFormatSimple)

-test_xlRangeAutoFormatTable1 (xlRangeAutoFormatTable1)

-test_xlRangeAutoFormatTable10 (xlRangeAutoFormatTable10)

-test_xlRangeAutoFormatTable2 (xlRangeAutoFormatTable2)

-test_xlRangeAutoFormatTable3 (xlRangeAutoFormatTable3)

-test_xlRangeAutoFormatTable4 (xlRangeAutoFormatTable4)

-test_xlRangeAutoFormatTable5 (xlRangeAutoFormatTable5)

-test_xlRangeAutoFormatTable6 (xlRangeAutoFormatTable6)

-test_xlRangeAutoFormatTable7 (xlRangeAutoFormatTable7)

-test_xlRangeAutoFormatTable8 (xlRangeAutoFormatTable8)

-test_xlRangeAutoFormatTable9 (xlRangeAutoFormatTable9)

-test_xlRangeValueDefault (xlRangeValueDefault)

-test_xlRangeValueMSPersistXML (xlRangeValueMSPersistXML)

-test_xlRangeValueXMLSpreadsheet (xlRangeValueXMLSpreadsheet)

-test_xlA1 (xlA1)

-test_xlR1C1 (xlR1C1)

-test_xlAbsolute (xlAbsolute)

-test_xlAbsRowRelColumn (xlAbsRowRelColumn)

-test_xlRelative (xlRelative)

-test_xlRelRowAbsColumn (xlRelRowAbsColumn)

-test_xlAlways (xlAlways)

-test_xlAsRequired (xlAsRequired)

-test_xlNever (xlNever)

-test_xlAllAtOnce (xlAllAtOnce)

-test_xlOneAfterAnother (xlOneAfterAnother)

-test_xlNotYetRouted (xlNotYetRouted)

-test_xlRoutingComplete (xlRoutingComplete)

-test_xlRoutingInProgress (xlRoutingInProgress)

-test_xlColumns (xlColumns)

-test_xlRows (xlRows)

-test_xlAutoActivate (xlAutoActivate)

-test_xlAutoClose (xlAutoClose)

-test_xlAutoDeactivate (xlAutoDeactivate)

-test_xlAutoOpen (xlAutoOpen)

-test_xlDoNotSaveChanges (xlDoNotSaveChanges)

-test_xlSaveChanges (xlSaveChanges)

-test_xlExclusive (xlExclusive)

-test_xlNoChange (xlNoChange)

-test_xlShared (xlShared)

-test_xlLocalSessionsChanges (xlLocalSessionsChanges)

-test_xlOtherSessionsChanges (xlOtherSessionsChanges)

-test_xlUserResolution (xlUserResolution)

-test_xlScaleLinear (xlScaleLinear)

-test_xlScaleLogarithmicr (xlScaleLogarithmicr)

-test_xlNext (xlNext)

-test_xlPrevious (xlPrevious)

-test_xlByColumns (xlByColumns)

-test_xlByRows (xlByRows)

-test_xlWithinSheet (xlWithinSheet)

-test_xlWithinWorkbook (xlWithinWorkbook)

-test_xlChart (xlChart)

-test_xlDialogSheet (xlDialogSheet)

-test_xlExcel4IntMacroSheet (xlExcel4IntMacroSheet)

-test_xlExcel4MacroSheet (xlExcel4MacroSheet)

-test_xlWorkSheet (xlWorkSheet)

-test_xlSheetHidden (xlSheetHidden)

-test_xlSheetVeryHidden (xlSheetVeryHidden)

-test_xlSheetVisible (xlSheetVisible)

-test_xlSizeIsArea (xlSizeIsArea)

-test_xlSizeIsWidth (xlSizeIsWidth)

-test_xlSmartTagControlActiveX (xlSmartTagControlActiveX)

-test_xlSmartTagControlButton (xlSmartTagControlButton)

-test_xlSmartTagControlCheckbox (xlSmartTagControlCheckbox)

-test_xlSmartTagControlCombo (xlSmartTagControlCombo)

-test_xlSmartTagControlHelp (xlSmartTagControlHelp)

-test_xlSmartTagControlHelpURL (xlSmartTagControlHelpURL)

-test_xlSmartTagControlImage (xlSmartTagControlImage)

-test_xlSmartTagControlLabel (xlSmartTagControlLabel)

-test_xlSmartTagControlLink (xlSmartTagControlLink)

-test_xlSmartTagControlListbox (xlSmartTagControlListbox)

-test_xlSmartTagControlRadioGroup (xlSmartTagControlRadioGroup)

-test_xlSmartTagControlSeparator (xlSmartTagControlSeparator)

-test_xlSmartTagControlSmartTag (xlSmartTagControlSmartTag)

-test_xlSmartTagControlTextbox (xlSmartTagControlTextbox)

-test_xlButtonOnly (xlButtonOnly)

-test_xlDisplayNone (xlDisplayNone)

-test_xlIndicatorAndButton (xlIndicatorAndButton)

-test_xlSortNormal (xlSortNormal)

-test_xlSortTextAsNumbers (xlSortTextAsNumbers)

-test_xlPinYin (xlPinYin)

-test_xlStroke (xlStroke)

-test_xlCodePage (xlCodePage)

-test_xlSyllabary (xlSyllabary)

-test_xlAscending (xlAscending)

-test_xlDescending (xlDescending)

-test_xlSortColumns (xlSortColumns)

-test_xlSortRows (xlSortRows)

-test_xlSortLabels (xlSortLabels)

-test_xlSortValues (xlSortValues)

-test_xlSourceAutoFilter (xlSourceAutoFilter)

-test_xlSourceChart (xlSourceChart)

-test_xlSourcePivotTable (xlSourcePivotTable)

-test_xlSourcePrintArea (xlSourcePrintArea)

-test_xlSourceQuery (xlSourceQuery)

-test_xlSourceRange (xlSourceRange)

-test_xlSourceSheet (xlSourceSheet)

-test_xlSourceWordbook (xlSourceWordbook)

-test_xlSpeakByColumns (xlSpeakByColumns)

-test_xlSpeakByRows (xlSpeakByRows)

-test_xlErrors (xlErrors)

-test_xlLogical (xlLogical)

-test_xlNumbers (xlNumbers)

-test_xlTextValues (xlTextValues)

-test_xlSubscribeToPicture (xlSubscribeToPicture)

-test_xlSubscribeToText (xlSubscribeToText)

-test_xlAtBottom (xlAtBottom)

-test_xlAtTop (xlAtTop)

-test_xlSummaryOnLeft (xlSummaryOnLeft)

-test_xlSummaryOnRight (xlSummaryOnRight)

-test_xlStandardSummary (xlStandardSummary)

-test_xlSummaryPivotTable (xlSummaryPivotTable)

-test_xlSummaryAbove (xlSummaryAbove)

-test_xlSummaryBelow (xlSummaryBelow)

-test_xlTabPositionFirst (xlTabPositionFirst)

-test_xlTabPositionLast (xlTabPositionLast)

-test_xlDelimited (xlDelimited)

-test_xlFixedWidth (xlFixedWidth)

-test_xlTextQualifierDoubleQuote (xlTextQualifierDoubleQuote)

-test_xlTextQualifierNone (xlTextQualifierNone)

-test_xlTextQualifierSingleQuote (xlTextQualifierSingleQuote)

-test_xlTextVisualLTR (xlTextVisualLTR)

-test_xlTextVisualRTL (xlTextVisualRTL)

-test_XlTickLabelOrientationAutomatic (XlTickLabelOrientationAutomatic)

-test_XlTickLabelOrientationDownward (XlTickLabelOrientationDownward)

-test_XlTickLabelOrientationHorizontal (XlTickLabelOrientationHorizontal)

-test_XlTickLabelOrientationUpward (XlTickLabelOrientationUpward)

-test_XlTickLabelOrientationVertical (XlTickLabelOrientationVertical)

-test_xlTickLabelPositionHigh (xlTickLabelPositionHigh)

-test_xlTickLabelPositionLow (xlTickLabelPositionLow)

-test_xlTickLabelPositionNextToAxis (xlTickLabelPositionNextToAxis)

-test_xlTickLabelPositionNone (xlTickLabelPositionNone)

-test_xlTickMarkCross (xlTickMarkCross)

-test_xlTickMarkInside (xlTickMarkInside)

-test_xlTickMarkNone (xlTickMarkNone)

-test_xlTickMarkOutside (xlTickMarkOutside)

-test_xlDays (xlDays)

-test_xlMonths (xlMonths)

-test_xlYears (xlYears)

-test_xlNoButtonChanges (xlNoButtonChanges)

-test_xlNoChanges (xlNoChanges)

-test_xlNoDockingChanges (xlNoDockingChanges)

-test_xlNoShapeChanges (xlNoShapeChanges)

-test_xlToolbarProtectionNone (xlToolbarProtectionNone)

-test_xlTotalsCalculationAverage (xlTotalsCalculationAverage)

-test_xlTotalsCalculationCount (xlTotalsCalculationCount)

-test_xlTotalsCalculationCountNums (xlTotalsCalculationCountNums)

-test_xlTotalsCalculationCountMax (xlTotalsCalculationCountMax)

-test_xlTotalsCalculationCountMin (xlTotalsCalculationCountMin)

-test_xlTotalsCalculationCountNone (xlTotalsCalculationCountNone)

-test_xlTotalsCalculationCountStdDev (xlTotalsCalculationCountStdDev)

-test_xlTotalsCalculationCountSum (xlTotalsCalculationCountSum)

-test_xlTotalsCalculationCountVar (xlTotalsCalculationCountVar)

-test_xlExponential (xlExponential)

-test_xlLinear (xlLinear)

-test_xlLogarithmic (xlLogarithmic)

-test_xlMovingAvg (xlMovingAvg)

-test_xlPolynomial (xlPolynomial)

-test_xlPower (xlPower)

-test_XlUnderlineStyleDouble (XlUnderlineStyleDouble)

-test_XlUnderlineStyleDoubleAccounting (XlUnderlineStyleDoubleAccounting)

-test_XlUnderlineStyleNone (XlUnderlineStyleNone)

-test_XlUnderlineStyleSingle (XlUnderlineStyleSingle)

-test_XlUnderlineStyleSingleAccounting (XlUnderlineStyleSingleAccounting)

-test_XlUpdateLinksAlways (XlUpdateLinksAlways)

-test_XlUpdateLinksNever (XlUpdateLinksNever)

-test_XlUpdateLinksUserSetting (XlUpdateLinksUserSetting)

-test_xlVAlignBottom (xlVAlignBottom)

-test_xlVAlignCenter (xlVAlignCenter)

-test_xlVAlignDistributed (xlVAlignDistributed)

-test_xlVAlignJustify (xlVAlignJustify)

-test_xlVAlignTop (xlVAlignTop)

-test_XlWBATChart (XlWBATChart)

-test_XlWBATExcel4IntlMacroSheet (XlWBATExcel4IntlMacroSheet)

-test_XlWBATExcel4MacroSheet (XlWBATExcel4MacroSheet)

-test_XlWBATWorksheet (XlWBATWorksheet)

-test_xlWebFormattingAll (xlWebFormattingAll)

-test_xlWebFormattingNone (xlWebFormattingNone)

-test_xlWebFormattingRTF (xlWebFormattingRTF)

-test_xlAllTables (xlAllTables)

-test_xlEntirePage (xlEntirePage)

-test_xlSpecifiedTables (xlSpecifiedTables)

-test_xlMaximized (xlMaximized)

-test_xlMinimized (xlMinimized)

-test_xlNormal (xlNormal)

-test_xlChartAsWindow (xlChartAsWindow)

-test_xlChartInPlace (xlChartInPlace)

-test_xlClipboard (xlClipboard)

-test_xlInfo (xlInfo)

-test_xlWordbook (xlWordbook)

-test_xlNormalView (xlNormalView)

-test_xlPageBreakPreview (xlPageBreakPreview)

-test_xlCommand (xlCommand)

-test_xlFunction (xlFunction)

-test_xlnotXLM (xlnotXLM)

-test_xlXmlExportSuccess (xlXmlExportSuccess)

-test_xlXmlExportValidationFailed (xlXmlExportValidationFailed)

-test_xlXmlImportElementsTruncated (xlXmlImportElementsTruncated)

-test_xlXmlImportSuccess (xlXmlImportSuccess)

-test_xlXmlImportValidationFailed (xlXmlImportValidationFailed)

-test_xlXmlLoadImportToList (xlXmlLoadImportToList)

-test_xlXmlLoadMapXml (xlXmlLoadMapXml)

-test_xlXmlLoadOpenXml (xlXmlLoadOpenXml)

-test_xlXmlLoadPromptUser (xlXmlLoadPromptUser)

-test_xlGuess (xlGuess)

-test_xlNo (xlNo)

-test_xlYes (xlYes)

-Range("A1").Value = "constant name"

-Range("B1").Value = "OOo result"

-Range("C1").Value = "Excel result"

-Range("D1").Value = "Correct?"

-End Sub

-

-Function test_XlEditionFormat(ByRef num)

-Range("A2").Clear

-Range("B2").Clear

-Range("C2").Clear

-Range("D2").Clear

-Range("A2").Value = "XlEditionFormat"

-Range("B2").Value = 0

-Range("C2").Value = num

-B2 = Range("B2").Value

-C2 = Range("C2").Value

-If B2 = C2 Then

-Range("D2").Value = "OK"

-Else

-Range("D2").Value = "NG"

-End If

-End Function

-

-Function test_xlAutomaticUpdate(ByRef num)

-Range("A3").Clear

-Range("B3").Clear

-Range("C3").Clear

-Range("D3").Clear

-Range("A3").Value = "xlAutomaticUpdate"

-Range("B3").Value = 4

-Range("C3").Value = num

-B3 = Range("B3").Value

-C3 = Range("C3").Value

-If B3 = C3 Then

-Range("D3").Value = "OK"

-Else

-Range("D3").Value = "NG"

-End If

-End Function

-

-Function test_xlCancel(ByRef num)

-Range("A4").Clear

-Range("B4").Clear

-Range("C4").Clear

-Range("D4").Clear

-Range("A4").Value = "xlCancel"

-Range("B4").Value = 1

-Range("C4").Value = num

-B4 = Range("B4").Value

-C4 = Range("C4").Value

-If B4 = C4 Then

-Range("D4").Value = "OK"

-Else

-Range("D4").Value = "NG"

-End If

-End Function

-

-Function test_xlChangeAttributes(ByRef num)

-Range("A5").Clear

-Range("B5").Clear

-Range("C5").Clear

-Range("D5").Clear

-Range("A5").Value = "xlChangeAttributes"

-Range("B5").Value = 6

-Range("C5").Value = num

-B5 = Range("B5").Value

-C5 = Range("C5").Value

-If B5 = C5 Then

-Range("D5").Value = "OK"

-Else

-Range("D5").Value = "NG"

-End If

-End Function

-

-Function test_xlManualUpdate(ByRef num)

-Range("A6").Clear

-Range("B6").Clear

-Range("C6").Clear

-Range("D6").Clear

-Range("A6").Value = "xlManualUpdate"

-Range("B6").Value = 5

-Range("C6").Value = num

-B6 = Range("B6").Value

-C6 = Range("C6").Value

-If B6 = C6 Then

-Range("D6").Value = "OK"

-Else

-Range("D6").Value = "NG"

-End If

-End Function

-

-Function test_xlOpenSource(ByRef num)

-Range("A7").Clear

-Range("B7").Clear

-Range("C7").Clear

-Range("D7").Clear

-Range("A7").Value = "xlOpenSource"

-Range("B7").Value = 3

-Range("C7").Value = num

-B7 = Range("B7").Value

-C7 = Range("C7").Value

-If B7 = C7 Then

-Range("D7").Value = "OK"

-Else

-Range("D7").Value = "NG"

-End If

-End Function

-

-Function test_xlSelect(ByRef num)

-Range("A8").Clear

-Range("B8").Clear

-Range("C8").Clear

-Range("D8").Clear

-Range("A8").Value = "xlSelect"

-Range("B8").Value = 3

-Range("C8").Value = num

-B8 = Range("B8").Value

-C8 = Range("C8").Value

-If B8 = C8 Then

-Range("D8").Value = "OK"

-Else

-Range("D8").Value = "NG"

-End If

-End Function

-

-Function test_xlSendPublisher(ByRef num)

-Range("A9").Clear

-Range("B9").Clear

-Range("C9").Clear

-Range("D9").Clear

-Range("A9").Value = "xlSendPublisher"

-Range("B9").Value = 2

-Range("C9").Value = num

-B9 = Range("B9").Value

-C9 = Range("C9").Value

-If B9 = C9 Then

-Range("D9").Value = "OK"

-Else

-Range("D9").Value = "NG"

-End If

-End Function

-

-Function test_xlUpdateSubscriber(ByRef num)

-Range("A10").Clear

-Range("B10").Clear

-Range("C10").Clear

-Range("D10").Clear

-Range("A10").Value = "xlUpdateSubscriber"

-Range("B10").Value = 2

-Range("C10").Value = num

-B10 = Range("B10").Value

-C10 = Range("C10").Value

-If B10 = C10 Then

-Range("D10").Value = "OK"

-Else

-Range("D10").Value = "NG"

-End If

-End Function

-

-Function test_xlPublisher(ByRef num)

-Range("A11").Clear

-Range("B11").Clear

-Range("C11").Clear

-Range("D11").Clear

-Range("A11").Value = "xlPublisher"

-Range("B11").Value = 1

-Range("C11").Value = num

-B11 = Range("B11").Value

-C11 = Range("C11").Value

-If B11 = C11 Then

-Range("D11").Value = "OK"

-Else

-Range("D11").Value = "NG"

-End If

-End Function

-

-Function test_xlSubscriber(ByRef num)

-Range("A12").Clear

-Range("B12").Clear

-Range("C12").Clear

-Range("D12").Clear

-Range("A12").Value = "xlSubscriber"

-Range("B12").Value = 2

-Range("C12").Value = num

-B12 = Range("B12").Value

-C12 = Range("C12").Value

-If B12 = C12 Then

-Range("D12").Value = "OK"

-Else

-Range("D12").Value = "NG"

-End If

-End Function

-

-Function test_xlDisabled(ByRef num)

-Range("A13").Clear

-Range("B13").Clear

-Range("C13").Clear

-Range("D13").Clear

-Range("A13").Value = "xlDisabled"

-Range("B13").Value = 0

-Range("C13").Value = num

-B13 = Range("B13").Value

-C13 = Range("C13").Value

-If B13 = C13 Then

-Range("D13").Value = "OK"

-Else

-Range("D13").Value = "NG"

-End If

-End Function

-

-Function test_xlErrorHandler(ByRef num)

-Range("A14").Clear

-Range("B14").Clear

-Range("C14").Clear

-Range("D14").Clear

-Range("A14").Value = "xlErrorHandler"

-Range("B14").Value = 2

-Range("C14").Value = num

-B14 = Range("B14").Value

-C14 = Range("C14").Value

-If B14 = C14 Then

-Range("D14").Value = "OK"

-Else

-Range("D14").Value = "NG"

-End If

-End Function

-

-Function test_xlInterrupt(ByRef num)

-Range("A15").Clear

-Range("B15").Clear

-Range("C15").Clear

-Range("D15").Clear

-Range("A15").Value = "xlInterrupt"

-Range("B15").Value = 1

-Range("C15").Value = num

-B15 = Range("B15").Value

-C15 = Range("C15").Value

-If B15 = C15 Then

-Range("D15").Value = "OK"

-Else

-Range("D15").Value = "NG"

-End If

-End Function

-

-Function test_xlNoRestrictions(ByRef num)

-Range("A16").Clear

-Range("B16").Clear

-Range("C16").Clear

-Range("D16").Clear

-Range("A16").Value = "xlNoRestrictions"

-Range("B16").Value = 0

-Range("C16").Value = num

-B16 = Range("B16").Value

-C16 = Range("C16").Value

-If B16 = C16 Then

-Range("D16").Value = "OK"

-Else

-Range("D16").Value = "NG"

-End If

-End Function

-

-Function test_xlNoSelection(ByRef num)

-Range("A17").Clear

-Range("B17").Clear

-Range("C17").Clear

-Range("D17").Clear

-Range("A17").Value = "xlNoSelection"

-Range("B17").Value = -4142

-Range("C17").Value = num

-B17 = Range("B17").Value

-C17 = Range("C17").Value

-If B17 = C17 Then

-Range("D17").Value = "OK"

-Else

-Range("D17").Value = "NG"

-End If

-End Function

-

-Function test_xlUnlockedCells(ByRef num)

-Range("A18").Clear

-Range("B18").Clear

-Range("C18").Clear

-Range("D18").Clear

-Range("A18").Value = "xlUnlockedCells"

-Range("B18").Value = 1

-Range("C18").Value = num

-B18 = Range("B18").Value

-C18 = Range("C18").Value

-If B18 = C18 Then

-Range("D18").Value = "OK"

-Else

-Range("D18").Value = "NG"

-End If

-End Function

-

-Function test_xlCap(ByRef num)

-Range("A19").Clear

-Range("B19").Clear

-Range("C19").Clear

-Range("D19").Clear

-Range("A19").Value = "xlCap"

-Range("B19").Value = 1

-Range("C19").Value = num

-B19 = Range("B19").Value

-C19 = Range("C19").Value

-If B19 = C19 Then

-Range("D19").Value = "OK"

-Else

-Range("D19").Value = "NG"

-End If

-End Function

-

-Function test_xlNoCap(ByRef num)

-Range("A20").Clear

-Range("B20").Clear

-Range("C20").Clear

-Range("D20").Clear

-Range("A20").Value = "xlNoCap"

-Range("B20").Value = 2

-Range("C20").Value = num

-B20 = Range("B20").Value

-C20 = Range("C20").Value

-If B20 = C20 Then

-Range("D20").Value = "OK"

-Else

-Range("D20").Value = "NG"

-End If

-End Function

-

-Function test_xlX(ByRef num)

-Range("A21").Clear

-Range("B21").Clear

-Range("C21").Clear

-Range("D21").Clear

-Range("A21").Value = "xlX"

-Range("B21").Value = -4168

-Range("C21").Value = num

-B21 = Range("B21").Value

-C21 = Range("C21").Value

-If B21 = C21 Then

-Range("D21").Value = "OK"

-Else

-Range("D21").Value = "NG"

-End If

-End Function

-

-Function test_xlY(ByRef num)

-Range("A22").Clear

-Range("B22").Clear

-Range("C22").Clear

-Range("D22").Clear

-Range("A22").Value = "xlY"

-Range("B22").Value = 1

-Range("C22").Value = num

-B22 = Range("B22").Value

-C22 = Range("C22").Value

-If B22 = C22 Then

-Range("D22").Value = "OK"

-Else

-Range("D22").Value = "NG"

-End If

-End Function

-

-Function test_xlErrorBarIncludeBoth(ByRef num)

-Range("A23").Clear

-Range("B23").Clear

-Range("C23").Clear

-Range("D23").Clear

-Range("A23").Value = "xlErrorBarIncludeBoth"

-Range("B23").Value = 1

-Range("C23").Value = num

-B23 = Range("B23").Value

-C23 = Range("C23").Value

-If B23 = C23 Then

-Range("D23").Value = "OK"

-Else

-Range("D23").Value = "NG"

-End If

-End Function

-

-Function test_xlErrorBarIncludeMinusValues(ByRef num)

-Range("A24").Clear

-Range("B24").Clear

-Range("C24").Clear

-Range("D24").Clear

-Range("A24").Value = "xlErrorBarIncludeMinusValues"

-Range("B24").Value = 3

-Range("C24").Value = num

-B24 = Range("B24").Value

-C24 = Range("C24").Value

-If B24 = C24 Then

-Range("D24").Value = "OK"

-Else

-Range("D24").Value = "NG"

-End If

-End Function

-

-Function test_xlErrorBarIncludeNone(ByRef num)

-Range("A25").Clear

-Range("B25").Clear

-Range("C25").Clear

-Range("D25").Clear

-Range("A25").Value = "xlErrorBarIncludeNone"

-Range("B25").Value = -4142

-Range("C25").Value = num

-B25 = Range("B25").Value

-C25 = Range("C25").Value

-If B25 = C25 Then

-Range("D25").Value = "OK"

-Else

-Range("D25").Value = "NG"

-End If

-End Function

-

-Function test_xlErrorBarIncludePlusValues(ByRef num)

-Range("A26").Clear

-Range("B26").Clear

-Range("C26").Clear

-Range("D26").Clear

-Range("A26").Value = "xlErrorBarIncludePlusValues"

-Range("B26").Value = 2

-Range("C26").Value = num

-B26 = Range("B26").Value

-C26 = Range("C26").Value

-If B26 = C26 Then

-Range("D26").Value = "OK"

-Else

-Range("D26").Value = "NG"

-End If

-End Function

-

-Function test_xlErrorBarTypeCustom(ByRef num)

-Range("A27").Clear

-Range("B27").Clear

-Range("C27").Clear

-Range("D27").Clear

-Range("A27").Value = "xlErrorBarTypeCustom"

-Range("B27").Value = -4144

-Range("C27").Value = num

-B27 = Range("B27").Value

-C27 = Range("C27").Value

-If B27 = C27 Then

-Range("D27").Value = "OK"

-Else

-Range("D27").Value = "NG"

-End If

-End Function

-

-Function test_xlErrorBarTypeFixedValue(ByRef num)

-Range("A28").Clear

-Range("B28").Clear

-Range("C28").Clear

-Range("D28").Clear

-Range("A28").Value = "xlErrorBarTypeFixedValue"

-Range("B28").Value = 1

-Range("C28").Value = num

-B28 = Range("B28").Value

-C28 = Range("C28").Value

-If B28 = C28 Then

-Range("D28").Value = "OK"

-Else

-Range("D28").Value = "NG"

-End If

-End Function

-

-Function test_xlErrorBarTypePercent(ByRef num)

-Range("A29").Clear

-Range("B29").Clear

-Range("C29").Clear

-Range("D29").Clear

-Range("A29").Value = "xlErrorBarTypePercent"

-Range("B29").Value = 2

-Range("C29").Value = num

-B29 = Range("B29").Value

-C29 = Range("C29").Value

-If B29 = C29 Then

-Range("D29").Value = "OK"

-Else

-Range("D29").Value = "NG"

-End If

-End Function

-

-Function test_xlErrorBarTypeStDev(ByRef num)

-Range("A30").Clear

-Range("B30").Clear

-Range("C30").Clear

-Range("D30").Clear

-Range("A30").Value = "xlErrorBarTypeStDev"

-Range("B30").Value = -4155

-Range("C30").Value = num

-B30 = Range("B30").Value

-C30 = Range("C30").Value

-If B30 = C30 Then

-Range("D30").Value = "OK"

-Else

-Range("D30").Value = "NG"

-End If

-End Function

-

-Function test_xlErrorBarTypeStError(ByRef num)

-Range("A31").Clear

-Range("B31").Clear

-Range("C31").Clear

-Range("D31").Clear

-Range("A31").Value = "xlErrorBarTypeStError"

-Range("B31").Value = 4

-Range("C31").Value = num

-B31 = Range("B31").Value

-C31 = Range("C31").Value

-If B31 = C31 Then

-Range("D31").Value = "OK"

-Else

-Range("D31").Value = "NG"

-End If

-End Function

-

-Function test_xlEmptyCellReferences(ByRef num)

-Range("A32").Clear

-Range("B32").Clear

-Range("C32").Clear

-Range("D32").Clear

-Range("A32").Value = "xlEmptyCellReferences"

-Range("B32").Value = 7

-Range("C32").Value = num

-B32 = Range("B32").Value

-C32 = Range("C32").Value

-If B32 = C32 Then

-Range("D32").Value = "OK"

-Else

-Range("D32").Value = "NG"

-End If

-End Function

-

-Function test_xlEvaluateToError(ByRef num)

-Range("A33").Clear

-Range("B33").Clear

-Range("C33").Clear

-Range("D33").Clear

-Range("A33").Value = "xlEvaluateToError"

-Range("B33").Value = 1

-Range("C33").Value = num

-B33 = Range("B33").Value

-C33 = Range("C33").Value

-If B33 = C33 Then

-Range("D33").Value = "OK"

-Else

-Range("D33").Value = "NG"

-End If

-End Function

-

-Function test_xlInconsistentFormula(ByRef num)

-Range("A34").Clear

-Range("B34").Clear

-Range("C34").Clear

-Range("D34").Clear

-Range("A34").Value = "xlInconsistentFormula"

-Range("B34").Value = 4

-Range("C34").Value = num

-B34 = Range("B34").Value

-C34 = Range("C34").Value

-If B34 = C34 Then

-Range("D34").Value = "OK"

-Else

-Range("D34").Value = "NG"

-End If

-End Function

-

-Function test_xlListDataValidation(ByRef num)

-Range("A35").Clear

-Range("B35").Clear

-Range("C35").Clear

-Range("D35").Clear

-Range("A35").Value = "xlListDataValidation"

-Range("B35").Value = 8

-Range("C35").Value = num

-B35 = Range("B35").Value

-C35 = Range("C35").Value

-If B35 = C35 Then

-Range("D35").Value = "OK"

-Else

-Range("D35").Value = "NG"

-End If

-End Function

-

-Function test_xlNumberAsText(ByRef num)

-Range("A36").Clear

-Range("B36").Clear

-Range("C36").Clear

-Range("D36").Clear

-Range("A36").Value = "xlNumberAsText"

-Range("B36").Value = 3

-Range("C36").Value = num

-B36 = Range("B36").Value

-C36 = Range("C36").Value

-If B36 = C36 Then

-Range("D36").Value = "OK"

-Else

-Range("D36").Value = "NG"

-End If

-End Function

-

-Function test_xlOmittedCells(ByRef num)

-Range("A37").Clear

-Range("B37").Clear

-Range("C37").Clear

-Range("D37").Clear

-Range("A37").Value = "xlOmittedCells"

-Range("B37").Value = 5

-Range("C37").Value = num

-B37 = Range("B37").Value

-C37 = Range("C37").Value

-If B37 = C37 Then

-Range("D37").Value = "OK"

-Else

-Range("D37").Value = "NG"

-End If

-End Function

-

-Function test_xlTextDate(ByRef num)

-Range("A38").Clear

-Range("B38").Clear

-Range("C38").Clear

-Range("D38").Clear

-Range("A38").Value = "xlTextDate"

-Range("B38").Value = 2

-Range("C38").Value = num

-B38 = Range("B38").Value

-C38 = Range("C38").Value

-If B38 = C38 Then

-Range("D38").Value = "OK"

-Else

-Range("D38").Value = "NG"

-End If

-End Function

-

-Function test_xlUnlockedFormulaCells(ByRef num)

-Range("A39").Clear

-Range("B39").Clear

-Range("C39").Clear

-Range("D39").Clear

-Range("A39").Value = "xlUnlockedFormulaCells"

-Range("B39").Value = 6

-Range("C39").Value = num

-B39 = Range("B39").Value

-C39 = Range("C39").Value

-If B39 = C39 Then

-Range("D39").Value = "OK"

-Else

-Range("D39").Value = "NG"

-End If

-End Function

-

-Function test_xlReadOnly(ByRef num)

-Range("A40").Clear

-Range("B40").Clear

-Range("C40").Clear

-Range("D40").Clear

-Range("A40").Value = "xlReadOnly"

-Range("B40").Value = 3

-Range("C40").Value = num

-B40 = Range("B40").Value

-C40 = Range("C40").Value

-If B40 = C40 Then

-Range("D40").Value = "OK"

-Else

-Range("D40").Value = "NG"

-End If

-End Function

-

-Function test_xlReadWrite(ByRef num)

-Range("A41").Clear

-Range("B41").Clear

-Range("C41").Clear

-Range("D41").Clear

-Range("A41").Value = "xlReadWrite"

-Range("B41").Value = 2

-Range("C41").Value = num

-B41 = Range("B41").Value

-C41 = Range("C41").Value

-If B41 = C41 Then

-Range("D41").Value = "OK"

-Else

-Range("D41").Value = "NG"

-End If

-End Function

-

-Function test_xlAddIn(ByRef num)

-Range("A42").Clear

-Range("B42").Clear

-Range("C42").Clear

-Range("D42").Clear

-Range("A42").Value = "xlAddIn"

-Range("B42").Value = 18

-Range("C42").Value = num

-B42 = Range("B42").Value

-C42 = Range("C42").Value

-If B42 = C42 Then

-Range("D42").Value = "OK"

-Else

-Range("D42").Value = "NG"

-End If

-End Function

-

-Function test_xlCSV(ByRef num)

-Range("A43").Clear

-Range("B43").Clear

-Range("C43").Clear

-Range("D43").Clear

-Range("A43").Value = "xlCSV"

-Range("B43").Value = 6

-Range("C43").Value = num

-B43 = Range("B43").Value

-C43 = Range("C43").Value

-If B43 = C43 Then

-Range("D43").Value = "OK"

-Else

-Range("D43").Value = "NG"

-End If

-End Function

-

-Function test_xlCSVMac(ByRef num)

-Range("A44").Clear

-Range("B44").Clear

-Range("C44").Clear

-Range("D44").Clear

-Range("A44").Value = "xlCSVMac"

-Range("B44").Value = 22

-Range("C44").Value = num

-B44 = Range("B44").Value

-C44 = Range("C44").Value

-If B44 = C44 Then

-Range("D44").Value = "OK"

-Else

-Range("D44").Value = "NG"

-End If

-End Function

-

-Function test_xlCSVMSDOS(ByRef num)

-Range("A45").Clear

-Range("B45").Clear

-Range("C45").Clear

-Range("D45").Clear

-Range("A45").Value = "xlCSVMSDOS"

-Range("B45").Value = 24

-Range("C45").Value = num

-B45 = Range("B45").Value

-C45 = Range("C45").Value

-If B45 = C45 Then

-Range("D45").Value = "OK"

-Else

-Range("D45").Value = "NG"

-End If

-End Function

-

-Function test_xlCSVWindows(ByRef num)

-Range("A46").Clear

-Range("B46").Clear

-Range("C46").Clear

-Range("D46").Clear

-Range("A46").Value = "xlCSVWindows"

-Range("B46").Value = 23

-Range("C46").Value = num

-B46 = Range("B46").Value

-C46 = Range("C46").Value

-If B46 = C46 Then

-Range("D46").Value = "OK"

-Else

-Range("D46").Value = "NG"

-End If

-End Function

-

-Function test_xlCurrentPlatformText(ByRef num)

-Range("A47").Clear

-Range("B47").Clear

-Range("C47").Clear

-Range("D47").Clear

-Range("A47").Value = "xlCurrentPlatformText"

-Range("B47").Value = -4158

-Range("C47").Value = num

-B47 = Range("B47").Value

-C47 = Range("C47").Value

-If B47 = C47 Then

-Range("D47").Value = "OK"

-Else

-Range("D47").Value = "NG"

-End If

-End Function

-

-Function test_xlDBF2(ByRef num)

-Range("A48").Clear

-Range("B48").Clear

-Range("C48").Clear

-Range("D48").Clear

-Range("A48").Value = "xlDBF2"

-Range("B48").Value = 7

-Range("C48").Value = num

-B48 = Range("B48").Value

-C48 = Range("C48").Value

-If B48 = C48 Then

-Range("D48").Value = "OK"

-Else

-Range("D48").Value = "NG"

-End If

-End Function

-

-Function test_xlDBF3(ByRef num)

-Range("A49").Clear

-Range("B49").Clear

-Range("C49").Clear

-Range("D49").Clear

-Range("A49").Value = "xlDBF3"

-Range("B49").Value = 8

-Range("C49").Value = num

-B49 = Range("B49").Value

-C49 = Range("C49").Value

-If B49 = C49 Then

-Range("D49").Value = "OK"

-Else

-Range("D49").Value = "NG"

-End If

-End Function

-

-Function test_xlDBF4(ByRef num)

-Range("A50").Clear

-Range("B50").Clear

-Range("C50").Clear

-Range("D50").Clear

-Range("A50").Value = "xlDBF4"

-Range("B50").Value = 11

-Range("C50").Value = num

-B50 = Range("B50").Value

-C50 = Range("C50").Value

-If B50 = C50 Then

-Range("D50").Value = "OK"

-Else

-Range("D50").Value = "NG"

-End If

-End Function

-

-Function test_xlDIF(ByRef num)

-Range("A51").Clear

-Range("B51").Clear

-Range("C51").Clear

-Range("D51").Clear

-Range("A51").Value = "xlDIF"

-Range("B51").Value = 9

-Range("C51").Value = num

-B51 = Range("B51").Value

-C51 = Range("C51").Value

-If B51 = C51 Then

-Range("D51").Value = "OK"

-Else

-Range("D51").Value = "NG"

-End If

-End Function

-

-Function test_xlExcel2(ByRef num)

-Range("A52").Clear

-Range("B52").Clear

-Range("C52").Clear

-Range("D52").Clear

-Range("A52").Value = "xlExcel2"

-Range("B52").Value = 16

-Range("C52").Value = num

-B52 = Range("B52").Value

-C52 = Range("C52").Value

-If B52 = C52 Then

-Range("D52").Value = "OK"

-Else

-Range("D52").Value = "NG"

-End If

-End Function

-

-Function test_xlExcel2FarEast(ByRef num)

-Range("A53").Clear

-Range("B53").Clear

-Range("C53").Clear

-Range("D53").Clear

-Range("A53").Value = "xlExcel2FarEast"

-Range("B53").Value = 27

-Range("C53").Value = num

-B53 = Range("B53").Value

-C53 = Range("C53").Value

-If B53 = C53 Then

-Range("D53").Value = "OK"

-Else

-Range("D53").Value = "NG"

-End If

-End Function

-

-Function test_xlExcel3(ByRef num)

-Range("A54").Clear

-Range("B54").Clear

-Range("C54").Clear

-Range("D54").Clear

-Range("A54").Value = "xlExcel3"

-Range("B54").Value = 29

-Range("C54").Value = num

-B54 = Range("B54").Value

-C54 = Range("C54").Value

-If B54 = C54 Then

-Range("D54").Value = "OK"

-Else

-Range("D54").Value = "NG"

-End If

-End Function

-

-Function test_xlExcel4(ByRef num)

-Range("A55").Clear

-Range("B55").Clear

-Range("C55").Clear

-Range("D55").Clear

-Range("A55").Value = "xlExcel4"

-Range("B55").Value = 33

-Range("C55").Value = num

-B55 = Range("B55").Value

-C55 = Range("C55").Value

-If B55 = C55 Then

-Range("D55").Value = "OK"

-Else

-Range("D55").Value = "NG"

-End If

-End Function

-

-Function test_xlExcel4Wordbook(ByRef num)

-Range("A56").Clear

-Range("B56").Clear

-Range("C56").Clear

-Range("D56").Clear

-Range("A56").Value = "xlExcel4Wordbook"

-Range("B56").Value = 35

-Range("C56").Value = num

-B56 = Range("B56").Value

-C56 = Range("C56").Value

-If B56 = C56 Then

-Range("D56").Value = "OK"

-Else

-Range("D56").Value = "NG"

-End If

-End Function

-

-Function test_xlExcel5(ByRef num)

-Range("A57").Clear

-Range("B57").Clear

-Range("C57").Clear

-Range("D57").Clear

-Range("A57").Value = "xlExcel5"

-Range("B57").Value = 39

-Range("C57").Value = num

-B57 = Range("B57").Value

-C57 = Range("C57").Value

-If B57 = C57 Then

-Range("D57").Value = "OK"

-Else

-Range("D57").Value = "NG"

-End If

-End Function

-

-Function test_xlExcel7(ByRef num)

-Range("A58").Clear

-Range("B58").Clear

-Range("C58").Clear

-Range("D58").Clear

-Range("A58").Value = "xlExcel7"

-Range("B58").Value = 39

-Range("C58").Value = num

-B58 = Range("B58").Value

-C58 = Range("C58").Value

-If B58 = C58 Then

-Range("D58").Value = "OK"

-Else

-Range("D58").Value = "NG"

-End If

-End Function

-

-Function test_xlExcel9795(ByRef num)

-Range("A59").Clear

-Range("B59").Clear

-Range("C59").Clear

-Range("D59").Clear

-Range("A59").Value = "xlExcel9795"

-Range("B59").Value = 43

-Range("C59").Value = num

-B59 = Range("B59").Value

-C59 = Range("C59").Value

-If B59 = C59 Then

-Range("D59").Value = "OK"

-Else

-Range("D59").Value = "NG"

-End If

-End Function

-

-Function test_xlHtml(ByRef num)

-Range("A60").Clear

-Range("B60").Clear

-Range("C60").Clear

-Range("D60").Clear

-Range("A60").Value = "xlHtml"

-Range("B60").Value = 44

-Range("C60").Value = num

-B60 = Range("B60").Value

-C60 = Range("C60").Value

-If B60 = C60 Then

-Range("D60").Value = "OK"

-Else

-Range("D60").Value = "NG"

-End If

-End Function

-

-Function test_xlIntlAddIn(ByRef num)

-Range("A61").Clear

-Range("B61").Clear

-Range("C61").Clear

-Range("D61").Clear

-Range("A61").Value = "xlIntlAddIn"

-Range("B61").Value = 26

-Range("C61").Value = num

-B61 = Range("B61").Value

-C61 = Range("C61").Value

-If B61 = C61 Then

-Range("D61").Value = "OK"

-Else

-Range("D61").Value = "NG"

-End If

-End Function

-

-Function test_xlIntlMacro(ByRef num)

-Range("A62").Clear

-Range("B62").Clear

-Range("C62").Clear

-Range("D62").Clear

-Range("A62").Value = "xlIntlMacro"

-Range("B62").Value = 25

-Range("C62").Value = num

-B62 = Range("B62").Value

-C62 = Range("C62").Value

-If B62 = C62 Then

-Range("D62").Value = "OK"

-Else

-Range("D62").Value = "NG"

-End If

-End Function

-

-Function test_xlSYLK(ByRef num)

-Range("A63").Clear

-Range("B63").Clear

-Range("C63").Clear

-Range("D63").Clear

-Range("A63").Value = "xlSYLK"

-Range("B63").Value = 2

-Range("C63").Value = num

-B63 = Range("B63").Value

-C63 = Range("C63").Value

-If B63 = C63 Then

-Range("D63").Value = "OK"

-Else

-Range("D63").Value = "NG"

-End If

-End Function

-

-Function test_xlTemplate(ByRef num)

-Range("A64").Clear

-Range("B64").Clear

-Range("C64").Clear

-Range("D64").Clear

-Range("A64").Value = "xlTemplate"

-Range("B64").Value = 17

-Range("C64").Value = num

-B64 = Range("B64").Value

-C64 = Range("C64").Value

-If B64 = C64 Then

-Range("D64").Value = "OK"

-Else

-Range("D64").Value = "NG"

-End If

-End Function

-

-Function test_xlTextMac(ByRef num)

-Range("A65").Clear

-Range("B65").Clear

-Range("C65").Clear

-Range("D65").Clear

-Range("A65").Value = "xlTextMac"

-Range("B65").Value = 19

-Range("C65").Value = num

-B65 = Range("B65").Value

-C65 = Range("C65").Value

-If B65 = C65 Then

-Range("D65").Value = "OK"

-Else

-Range("D65").Value = "NG"

-End If

-End Function

-

-Function test_xlTextMSDOS(ByRef num)

-Range("A66").Clear

-Range("B66").Clear

-Range("C66").Clear

-Range("D66").Clear

-Range("A66").Value = "xlTextMSDOS"

-Range("B66").Value = 21

-Range("C66").Value = num

-B66 = Range("B66").Value

-C66 = Range("C66").Value

-If B66 = C66 Then

-Range("D66").Value = "OK"

-Else

-Range("D66").Value = "NG"

-End If

-End Function

-

-Function test_xlTextPrinter(ByRef num)

-Range("A67").Clear

-Range("B67").Clear

-Range("C67").Clear

-Range("D67").Clear

-Range("A67").Value = "xlTextPrinter"

-Range("B67").Value = 36

-Range("C67").Value = num

-B67 = Range("B67").Value

-C67 = Range("C67").Value

-If B67 = C67 Then

-Range("D67").Value = "OK"

-Else

-Range("D67").Value = "NG"

-End If

-End Function

-

-Function test_xlTextWindows(ByRef num)

-Range("A68").Clear

-Range("B68").Clear

-Range("C68").Clear

-Range("D68").Clear

-Range("A68").Value = "xlTextWindows"

-Range("B68").Value = 20

-Range("C68").Value = num

-B68 = Range("B68").Value

-C68 = Range("C68").Value

-If B68 = C68 Then

-Range("D68").Value = "OK"

-Else

-Range("D68").Value = "NG"

-End If

-End Function

-

-Function test_xlUnicodeText(ByRef num)

-Range("A69").Clear

-Range("B69").Clear

-Range("C69").Clear

-Range("D69").Clear

-Range("A69").Value = "xlUnicodeText"

-Range("B69").Value = 42

-Range("C69").Value = num

-B69 = Range("B69").Value

-C69 = Range("C69").Value

-If B69 = C69 Then

-Range("D69").Value = "OK"

-Else

-Range("D69").Value = "NG"

-End If

-End Function

-

-Function test_xlWebArchive(ByRef num)

-Range("A70").Clear

-Range("B70").Clear

-Range("C70").Clear

-Range("D70").Clear

-Range("A70").Value = "xlWebArchive"

-Range("B70").Value = 45

-Range("C70").Value = num

-B70 = Range("B70").Value

-C70 = Range("C70").Value

-If B70 = C70 Then

-Range("D70").Value = "OK"

-Else

-Range("D70").Value = "NG"

-End If

-End Function

-

-Function test_xlWJ2WD1(ByRef num)

-Range("A71").Clear

-Range("B71").Clear

-Range("C71").Clear

-Range("D71").Clear

-Range("A71").Value = "xlWJ2WD1"

-Range("B71").Value = 14

-Range("C71").Value = num

-B71 = Range("B71").Value

-C71 = Range("C71").Value

-If B71 = C71 Then

-Range("D71").Value = "OK"

-Else

-Range("D71").Value = "NG"

-End If

-End Function

-

-Function test_xlWJ3(ByRef num)

-Range("A72").Clear

-Range("B72").Clear

-Range("C72").Clear

-Range("D72").Clear

-Range("A72").Value = "xlWJ3"

-Range("B72").Value = 40

-Range("C72").Value = num

-B72 = Range("B72").Value

-C72 = Range("C72").Value

-If B72 = C72 Then

-Range("D72").Value = "OK"

-Else

-Range("D72").Value = "NG"

-End If

-End Function

-

-Function test_xlWJ3FJ3(ByRef num)

-Range("A73").Clear

-Range("B73").Clear

-Range("C73").Clear

-Range("D73").Clear

-Range("A73").Value = "xlWJ3FJ3"

-Range("B73").Value = 41

-Range("C73").Value = num

-B73 = Range("B73").Value

-C73 = Range("C73").Value

-If B73 = C73 Then

-Range("D73").Value = "OK"

-Else

-Range("D73").Value = "NG"

-End If

-End Function

-

-Function test_xlWK1(ByRef num)

-Range("A74").Clear

-Range("B74").Clear

-Range("C74").Clear

-Range("D74").Clear

-Range("A74").Value = "xlWK1"

-Range("B74").Value = 5

-Range("C74").Value = num

-B74 = Range("B74").Value

-C74 = Range("C74").Value

-If B74 = C74 Then

-Range("D74").Value = "OK"

-Else

-Range("D74").Value = "NG"

-End If

-End Function

-

-Function test_xlWK1ALL(ByRef num)

-Range("A75").Clear

-Range("B75").Clear

-Range("C75").Clear

-Range("D75").Clear

-Range("A75").Value = "xlWK1ALL"

-Range("B75").Value = 31

-Range("C75").Value = num

-B75 = Range("B75").Value

-C75 = Range("C75").Value

-If B75 = C75 Then

-Range("D75").Value = "OK"

-Else

-Range("D75").Value = "NG"

-End If

-End Function

-

-Function test_xlWK1FMT(ByRef num)

-Range("A76").Clear

-Range("B76").Clear

-Range("C76").Clear

-Range("D76").Clear

-Range("A76").Value = "xlWK1FMT"

-Range("B76").Value = 30

-Range("C76").Value = num

-B76 = Range("B76").Value

-C76 = Range("C76").Value

-If B76 = C76 Then

-Range("D76").Value = "OK"

-Else

-Range("D76").Value = "NG"

-End If

-End Function

-

-Function test_xlWK3(ByRef num)

-Range("A77").Clear

-Range("B77").Clear

-Range("C77").Clear

-Range("D77").Clear

-Range("A77").Value = "xlWK3"

-Range("B77").Value = 15

-Range("C77").Value = num

-B77 = Range("B77").Value

-C77 = Range("C77").Value

-If B77 = C77 Then

-Range("D77").Value = "OK"

-Else

-Range("D77").Value = "NG"

-End If

-End Function

-

-Function test_xlWK3FM3(ByRef num)

-Range("A78").Clear

-Range("B78").Clear

-Range("C78").Clear

-Range("D78").Clear

-Range("A78").Value = "xlWK3FM3"

-Range("B78").Value = 32

-Range("C78").Value = num

-B78 = Range("B78").Value

-C78 = Range("C78").Value

-If B78 = C78 Then

-Range("D78").Value = "OK"

-Else

-Range("D78").Value = "NG"

-End If

-End Function

-

-Function test_xlWK4(ByRef num)

-Range("A79").Clear

-Range("B79").Clear

-Range("C79").Clear

-Range("D79").Clear

-Range("A79").Value = "xlWK4"

-Range("B79").Value = 38

-Range("C79").Value = num

-B79 = Range("B79").Value

-C79 = Range("C79").Value

-If B79 = C79 Then

-Range("D79").Value = "OK"

-Else

-Range("D79").Value = "NG"

-End If

-End Function

-

-Function test_xlWKS(ByRef num)

-Range("A80").Clear

-Range("B80").Clear

-Range("C80").Clear

-Range("D80").Clear

-Range("A80").Value = "xlWKS"

-Range("B80").Value = 4

-Range("C80").Value = num

-B80 = Range("B80").Value

-C80 = Range("C80").Value

-If B80 = C80 Then

-Range("D80").Value = "OK"

-Else

-Range("D80").Value = "NG"

-End If

-End Function

-

-Function test_xlWordbookNormal(ByRef num)

-Range("A81").Clear

-Range("B81").Clear

-Range("C81").Clear

-Range("D81").Clear

-Range("A81").Value = "xlWordbookNormal"

-Range("B81").Value = -4143

-Range("C81").Value = num

-B81 = Range("B81").Value

-C81 = Range("C81").Value

-If B81 = C81 Then

-Range("D81").Value = "OK"

-Else

-Range("D81").Value = "NG"

-End If

-End Function

-

-Function test_xlWords2FarEast(ByRef num)

-Range("A82").Clear

-Range("B82").Clear

-Range("C82").Clear

-Range("D82").Clear

-Range("A82").Value = "xlWords2FarEast"

-Range("B82").Value = 28

-Range("C82").Value = num

-B82 = Range("B82").Value

-C82 = Range("C82").Value

-If B82 = C82 Then

-Range("D82").Value = "OK"

-Else

-Range("D82").Value = "NG"

-End If

-End Function

-

-Function test_xlWQ1(ByRef num)

-Range("A83").Clear

-Range("B83").Clear

-Range("C83").Clear

-Range("D83").Clear

-Range("A83").Value = "xlWQ1"

-Range("B83").Value = 34

-Range("C83").Value = num

-B83 = Range("B83").Value

-C83 = Range("C83").Value

-If B83 = C83 Then

-Range("D83").Value = "OK"

-Else

-Range("D83").Value = "NG"

-End If

-End Function

-

-Function test_xlXMLSpredsheet(ByRef num)

-Range("A84").Clear

-Range("B84").Clear

-Range("C84").Clear

-Range("D84").Clear

-Range("A84").Value = "xlXMLSpredsheet"

-Range("B84").Value = 46

-Range("C84").Value = num

-B84 = Range("B84").Value

-C84 = Range("C84").Value

-If B84 = C84 Then

-Range("D84").Value = "OK"

-Else

-Range("D84").Value = "NG"

-End If

-End Function

-

-Function test_xlFillWithAll(ByRef num)

-Range("A85").Clear

-Range("B85").Clear

-Range("C85").Clear

-Range("D85").Clear

-Range("A85").Value = "xlFillWithAll"

-Range("B85").Value = -4104

-Range("C85").Value = num

-B85 = Range("B85").Value

-C85 = Range("C85").Value

-If B85 = C85 Then

-Range("D85").Value = "OK"

-Else

-Range("D85").Value = "NG"

-End If

-End Function

-

-Function test_xlFillWithContents(ByRef num)

-Range("A86").Clear

-Range("B86").Clear

-Range("C86").Clear

-Range("D86").Clear

-Range("A86").Value = "xlFillWithContents"

-Range("B86").Value = 2

-Range("C86").Value = num

-B86 = Range("B86").Value

-C86 = Range("C86").Value

-If B86 = C86 Then

-Range("D86").Value = "OK"

-Else

-Range("D86").Value = "NG"

-End If

-End Function

-

-Function test_xlFillWithFormats(ByRef num)

-Range("A87").Clear

-Range("B87").Clear

-Range("C87").Clear

-Range("D87").Clear

-Range("A87").Value = "xlFillWithFormats"

-Range("B87").Value = -4122

-Range("C87").Value = num

-B87 = Range("B87").Value

-C87 = Range("C87").Value

-If B87 = C87 Then

-Range("D87").Value = "OK"

-Else

-Range("D87").Value = "NG"

-End If

-End Function

-

-Function test_xlFilterCopy(ByRef num)

-Range("A88").Clear

-Range("B88").Clear

-Range("C88").Clear

-Range("D88").Clear

-Range("A88").Value = "xlFilterCopy"

-Range("B88").Value = 2

-Range("C88").Value = num

-B88 = Range("B88").Value

-C88 = Range("C88").Value

-If B88 = C88 Then

-Range("D88").Value = "OK"

-Else

-Range("D88").Value = "NG"

-End If

-End Function

-

-Function test_xlFilterInPlace(ByRef num)

-Range("A89").Clear

-Range("B89").Clear

-Range("C89").Clear

-Range("D89").Clear

-Range("A89").Value = "xlFilterInPlace"

-Range("B89").Value = 1

-Range("C89").Value = num

-B89 = Range("B89").Value

-C89 = Range("C89").Value

-If B89 = C89 Then

-Range("D89").Value = "OK"

-Else

-Range("D89").Value = "NG"

-End If

-End Function

-

-Function test_xlComments(ByRef num)

-Range("A90").Clear

-Range("B90").Clear

-Range("C90").Clear

-Range("D90").Clear

-Range("A90").Value = "xlComments"

-Range("B90").Value = -4144

-Range("C90").Value = num

-B90 = Range("B90").Value

-C90 = Range("C90").Value

-If B90 = C90 Then

-Range("D90").Value = "OK"

-Else

-Range("D90").Value = "NG"

-End If

-End Function

-

-Function test_xlFormulas(ByRef num)

-Range("A91").Clear

-Range("B91").Clear

-Range("C91").Clear

-Range("D91").Clear

-Range("A91").Value = "xlFormulas"

-Range("B91").Value = -4123

-Range("C91").Value = num

-B91 = Range("B91").Value

-C91 = Range("C91").Value

-If B91 = C91 Then

-Range("D91").Value = "OK"

-Else

-Range("D91").Value = "NG"

-End If

-End Function

-

-Function test_xlValues(ByRef num)

-Range("A92").Clear

-Range("B92").Clear

-Range("C92").Clear

-Range("D92").Clear

-Range("A92").Value = "xlValues"

-Range("B92").Value = -4163

-Range("C92").Value = num

-B92 = Range("B92").Value

-C92 = Range("C92").Value

-If B92 = C92 Then

-Range("D92").Value = "OK"

-Else

-Range("D92").Value = "NG"

-End If

-End Function

-

-Function test_xlButtonControl(ByRef num)

-Range("A93").Clear

-Range("B93").Clear

-Range("C93").Clear

-Range("D93").Clear

-Range("A93").Value = "xlButtonControl"

-Range("B93").Value = 0

-Range("C93").Value = num

-B93 = Range("B93").Value

-C93 = Range("C93").Value

-If B93 = C93 Then

-Range("D93").Value = "OK"

-Else

-Range("D93").Value = "NG"

-End If

-End Function

-

-Function test_xlCheckBox(ByRef num)

-Range("A94").Clear

-Range("B94").Clear

-Range("C94").Clear

-Range("D94").Clear

-Range("A94").Value = "xlCheckBox"

-Range("B94").Value = 1

-Range("C94").Value = num

-B94 = Range("B94").Value

-C94 = Range("C94").Value

-If B94 = C94 Then

-Range("D94").Value = "OK"

-Else

-Range("D94").Value = "NG"

-End If

-End Function

-

-Function test_xlDropDown(ByRef num)

-Range("A95").Clear

-Range("B95").Clear

-Range("C95").Clear

-Range("D95").Clear

-Range("A95").Value = "xlDropDown"

-Range("B95").Value = 2

-Range("C95").Value = num

-B95 = Range("B95").Value

-C95 = Range("C95").Value

-If B95 = C95 Then

-Range("D95").Value = "OK"

-Else

-Range("D95").Value = "NG"

-End If

-End Function

-

-Function test_xlEditBox(ByRef num)

-Range("A96").Clear

-Range("B96").Clear

-Range("C96").Clear

-Range("D96").Clear

-Range("A96").Value = "xlEditBox"

-Range("B96").Value = 3

-Range("C96").Value = num

-B96 = Range("B96").Value

-C96 = Range("C96").Value

-If B96 = C96 Then

-Range("D96").Value = "OK"

-Else

-Range("D96").Value = "NG"

-End If

-End Function

-

-Function test_xlGroupBox(ByRef num)

-Range("A97").Clear

-Range("B97").Clear

-Range("C97").Clear

-Range("D97").Clear

-Range("A97").Value = "xlGroupBox"

-Range("B97").Value = 4

-Range("C97").Value = num

-B97 = Range("B97").Value

-C97 = Range("C97").Value

-If B97 = C97 Then

-Range("D97").Value = "OK"

-Else

-Range("D97").Value = "NG"

-End If

-End Function

-

-Function test_xlLabel(ByRef num)

-Range("A98").Clear

-Range("B98").Clear

-Range("C98").Clear

-Range("D98").Clear

-Range("A98").Value = "xlLabel"

-Range("B98").Value = 5

-Range("C98").Value = num

-B98 = Range("B98").Value

-C98 = Range("C98").Value

-If B98 = C98 Then

-Range("D98").Value = "OK"

-Else

-Range("D98").Value = "NG"

-End If

-End Function

-

-Function test_xlListBox(ByRef num)

-Range("A99").Clear

-Range("B99").Clear

-Range("C99").Clear

-Range("D99").Clear

-Range("A99").Value = "xlListBox"

-Range("B99").Value = 6

-Range("C99").Value = num

-B99 = Range("B99").Value

-C99 = Range("C99").Value

-If B99 = C99 Then

-Range("D99").Value = "OK"

-Else

-Range("D99").Value = "NG"

-End If

-End Function

-

-Function test_xlOptionButton(ByRef num)

-Range("A100").Clear

-Range("B100").Clear

-Range("C100").Clear

-Range("D100").Clear

-Range("A100").Value = "xlOptionButton"

-Range("B100").Value = 7

-Range("C100").Value = num

-B100 = Range("B100").Value

-C100 = Range("C100").Value

-If B100 = C100 Then

-Range("D100").Value = "OK"

-Else

-Range("D100").Value = "NG"

-End If

-End Function

-

-Function test_xlSchollBar(ByRef num)

-Range("A101").Clear

-Range("B101").Clear

-Range("C101").Clear

-Range("D101").Clear

-Range("A101").Value = "xlSchollBar"

-Range("B101").Value = 8

-Range("C101").Value = num

-B101 = Range("B101").Value

-C101 = Range("C101").Value

-If B101 = C101 Then

-Range("D101").Value = "OK"

-Else

-Range("D101").Value = "NG"

-End If

-End Function

-

-Function test_xlSpinner(ByRef num)

-Range("A102").Clear

-Range("B102").Clear

-Range("C102").Clear

-Range("D102").Clear

-Range("A102").Value = "xlSpinner"

-Range("B102").Value = 9

-Range("C102").Value = num

-B102 = Range("B102").Value

-C102 = Range("C102").Value

-If B102 = C102 Then

-Range("D102").Value = "OK"

-Else

-Range("D102").Value = "NG"

-End If

-End Function

-

-Function test_xlBetween(ByRef num)

-Range("A103").Clear

-Range("B103").Clear

-Range("C103").Clear

-Range("D103").Clear

-Range("A103").Value = "xlBetween"

-Range("B103").Value = 1

-Range("C103").Value = num

-B103 = Range("B103").Value

-C103 = Range("C103").Value

-If B103 = C103 Then

-Range("D103").Value = "OK"

-Else

-Range("D103").Value = "NG"

-End If

-End Function

-

-Function test_xlEqual(ByRef num)

-Range("A104").Clear

-Range("B104").Clear

-Range("C104").Clear

-Range("D104").Clear

-Range("A104").Value = "xlEqual"

-Range("B104").Value = 3

-Range("C104").Value = num

-B104 = Range("B104").Value

-C104 = Range("C104").Value

-If B104 = C104 Then

-Range("D104").Value = "OK"

-Else

-Range("D104").Value = "NG"

-End If

-End Function

-

-Function test_xlGreater(ByRef num)

-Range("A105").Clear

-Range("B105").Clear

-Range("C105").Clear

-Range("D105").Clear

-Range("A105").Value = "xlGreater"

-Range("B105").Value = 5

-Range("C105").Value = num

-B105 = Range("B105").Value

-C105 = Range("C105").Value

-If B105 = C105 Then

-Range("D105").Value = "OK"

-Else

-Range("D105").Value = "NG"

-End If

-End Function

-

-Function test_xlGreaterEqual(ByRef num)

-Range("A106").Clear

-Range("B106").Clear

-Range("C106").Clear

-Range("D106").Clear

-Range("A106").Value = "xlGreaterEqual"

-Range("B106").Value = 7

-Range("C106").Value = num

-B106 = Range("B106").Value

-C106 = Range("C106").Value

-If B106 = C106 Then

-Range("D106").Value = "OK"

-Else

-Range("D106").Value = "NG"

-End If

-End Function

-

-Function test_xlLess(ByRef num)

-Range("A107").Clear

-Range("B107").Clear

-Range("C107").Clear

-Range("D107").Clear

-Range("A107").Value = "xlLess"

-Range("B107").Value = 6

-Range("C107").Value = num

-B107 = Range("B107").Value

-C107 = Range("C107").Value

-If B107 = C107 Then

-Range("D107").Value = "OK"

-Else

-Range("D107").Value = "NG"

-End If

-End Function

-

-Function test_xlLessEqual(ByRef num)

-Range("A108").Clear

-Range("B108").Clear

-Range("C108").Clear

-Range("D108").Clear

-Range("A108").Value = "xlLessEqual"

-Range("B108").Value = 8

-Range("C108").Value = num

-B108 = Range("B108").Value

-C108 = Range("C108").Value

-If B108 = C108 Then

-Range("D108").Value = "OK"

-Else

-Range("D108").Value = "NG"

-End If

-End Function

-

-Function test_xlNotBetween(ByRef num)

-Range("A109").Clear

-Range("B109").Clear

-Range("C109").Clear

-Range("D109").Clear

-Range("A109").Value = "xlNotBetween"

-Range("B109").Value = 2

-Range("C109").Value = num

-B109 = Range("B109").Value

-C109 = Range("C109").Value

-If B109 = C109 Then

-Range("D109").Value = "OK"

-Else

-Range("D109").Value = "NG"

-End If

-End Function

-

-Function test_xlNotEqual(ByRef num)

-Range("A110").Clear

-Range("B110").Clear

-Range("C110").Clear

-Range("D110").Clear

-Range("A110").Value = "xlNotEqual"

-Range("B110").Value = 4

-Range("C110").Value = num

-B110 = Range("B110").Value

-C110 = Range("C110").Value

-If B110 = C110 Then

-Range("D110").Value = "OK"

-Else

-Range("D110").Value = "NG"

-End If

-End Function

-

-Function test_xlCellValue(ByRef num)

-Range("A111").Clear

-Range("B111").Clear

-Range("C111").Clear

-Range("D111").Clear

-Range("A111").Value = "xlCellValue"

-Range("B111").Value = 1

-Range("C111").Value = num

-B111 = Range("B111").Value

-C111 = Range("C111").Value

-If B111 = C111 Then

-Range("D111").Value = "OK"

-Else

-Range("D111").Value = "NG"

-End If

-End Function

-

-Function test_xlExpression(ByRef num)

-Range("A112").Clear

-Range("B112").Clear

-Range("C112").Clear

-Range("D112").Clear

-Range("A112").Value = "xlExpression"

-Range("B112").Value = 2

-Range("C112").Value = num

-B112 = Range("B112").Value

-C112 = Range("C112").Value

-If B112 = C112 Then

-Range("D112").Value = "OK"

-Else

-Range("D112").Value = "NG"

-End If

-End Function

-

-Function test_xlColumnLabels(ByRef num)

-Range("A113").Clear

-Range("B113").Clear

-Range("C113").Clear

-Range("D113").Clear

-Range("A113").Value = "xlColumnLabels"

-Range("B113").Value = 2

-Range("C113").Value = num

-B113 = Range("B113").Value

-C113 = Range("C113").Value

-If B113 = C113 Then

-Range("D113").Value = "OK"

-Else

-Range("D113").Value = "NG"

-End If

-End Function

-

-Function test_xlMixedLabels(ByRef num)

-Range("A114").Clear

-Range("B114").Clear

-Range("C114").Clear

-Range("D114").Clear

-Range("A114").Value = "xlMixedLabels"

-Range("B114").Value = 3

-Range("C114").Value = num

-B114 = Range("B114").Value

-C114 = Range("C114").Value

-If B114 = C114 Then

-Range("D114").Value = "OK"

-Else

-Range("D114").Value = "NG"

-End If

-End Function

-

-Function test_xlNoLabels(ByRef num)

-Range("A115").Clear

-Range("B115").Clear

-Range("C115").Clear

-Range("D115").Clear

-Range("A115").Value = "xlNoLabels"

-Range("B115").Value = -4142

-Range("C115").Value = num

-B115 = Range("B115").Value

-C115 = Range("C115").Value

-If B115 = C115 Then

-Range("D115").Value = "OK"

-Else

-Range("D115").Value = "NG"

-End If

-End Function

-

-Function test_xlRowLabels(ByRef num)

-Range("A116").Clear

-Range("B116").Clear

-Range("C116").Clear

-Range("D116").Clear

-Range("A116").Value = "xlRowLabels"

-Range("B116").Value = 1

-Range("C116").Value = num

-B116 = Range("B116").Value

-C116 = Range("C116").Value

-If B116 = C116 Then

-Range("D116").Value = "OK"

-Else

-Range("D116").Value = "NG"

-End If

-End Function

-

-Function test_xlHAlignCenter(ByRef num)

-Range("A117").Clear

-Range("B117").Clear

-Range("C117").Clear

-Range("D117").Clear

-Range("A117").Value = "xlHAlignCenter"

-Range("B117").Value = -4108

-Range("C117").Value = num

-B117 = Range("B117").Value

-C117 = Range("C117").Value

-If B117 = C117 Then

-Range("D117").Value = "OK"

-Else

-Range("D117").Value = "NG"

-End If

-End Function

-

-Function test_xlHAlignCenterAcrossSelection(ByRef num)

-Range("A118").Clear

-Range("B118").Clear

-Range("C118").Clear

-Range("D118").Clear

-Range("A118").Value = "xlHAlignCenterAcrossSelection"

-Range("B118").Value = 7

-Range("C118").Value = num

-B118 = Range("B118").Value

-C118 = Range("C118").Value

-If B118 = C118 Then

-Range("D118").Value = "OK"

-Else

-Range("D118").Value = "NG"

-End If

-End Function

-

-Function test_xlHAlignDistributed(ByRef num)

-Range("A119").Clear

-Range("B119").Clear

-Range("C119").Clear

-Range("D119").Clear

-Range("A119").Value = "xlHAlignDistributed"

-Range("B119").Value = -4117

-Range("C119").Value = num

-B119 = Range("B119").Value

-C119 = Range("C119").Value

-If B119 = C119 Then

-Range("D119").Value = "OK"

-Else

-Range("D119").Value = "NG"

-End If

-End Function

-

-Function test_xlHAlignFull(ByRef num)

-Range("A120").Clear

-Range("B120").Clear

-Range("C120").Clear

-Range("D120").Clear

-Range("A120").Value = "xlHAlignFull"

-Range("B120").Value = 5

-Range("C120").Value = num

-B120 = Range("B120").Value

-C120 = Range("C120").Value

-If B120 = C120 Then

-Range("D120").Value = "OK"

-Else

-Range("D120").Value = "NG"

-End If

-End Function

-

-Function test_xlHAlignGeneral(ByRef num)

-Range("A121").Clear

-Range("B121").Clear

-Range("C121").Clear

-Range("D121").Clear

-Range("A121").Value = "xlHAlignGeneral"

-Range("B121").Value = 1

-Range("C121").Value = num

-B121 = Range("B121").Value

-C121 = Range("C121").Value

-If B121 = C121 Then

-Range("D121").Value = "OK"

-Else

-Range("D121").Value = "NG"

-End If

-End Function

-

-Function test_xlHAlignJustify(ByRef num)

-Range("A122").Clear

-Range("B122").Clear

-Range("C122").Clear

-Range("D122").Clear

-Range("A122").Value = "xlHAlignJustify"

-Range("B122").Value = -4130

-Range("C122").Value = num

-B122 = Range("B122").Value

-C122 = Range("C122").Value

-If B122 = C122 Then

-Range("D122").Value = "OK"

-Else

-Range("D122").Value = "NG"

-End If

-End Function

-

-Function test_xlHAlignLeft(ByRef num)

-Range("A123").Clear

-Range("B123").Clear

-Range("C123").Clear

-Range("D123").Clear

-Range("A123").Value = "xlHAlignLeft"

-Range("B123").Value = -4131

-Range("C123").Value = num

-B123 = Range("B123").Value

-C123 = Range("C123").Value

-If B123 = C123 Then

-Range("D123").Value = "OK"

-Else

-Range("D123").Value = "NG"

-End If

-End Function

-

-Function test_xlHAlignRight(ByRef num)

-Range("A124").Clear

-Range("B124").Clear

-Range("C124").Clear

-Range("D124").Clear

-Range("A124").Value = "xlHAlignRight"

-Range("B124").Value = -4152

-Range("C124").Value = num

-B124 = Range("B124").Value

-C124 = Range("C124").Value

-If B124 = C124 Then

-Range("D124").Value = "OK"

-Else

-Range("D124").Value = "NG"

-End If

-End Function

-

-Function test_xlHebrewFullScript(ByRef num)

-Range("A125").Clear

-Range("B125").Clear

-Range("C125").Clear

-Range("D125").Clear

-Range("A125").Value = "xlHebrewFullScript"

-Range("B125").Value = 0

-Range("C125").Value = num

-B125 = Range("B125").Value

-C125 = Range("C125").Value

-If B125 = C125 Then

-Range("D125").Value = "OK"

-Else

-Range("D125").Value = "NG"

-End If

-End Function

-

-Function test_xlHebrewMixedAuthorizedScript(ByRef num)

-Range("A126").Clear

-Range("B126").Clear

-Range("C126").Clear

-Range("D126").Clear

-Range("A126").Value = "xlHebrewMixedAuthorizedScript"

-Range("B126").Value = 3

-Range("C126").Value = num

-B126 = Range("B126").Value

-C126 = Range("C126").Value

-If B126 = C126 Then

-Range("D126").Value = "OK"

-Else

-Range("D126").Value = "NG"

-End If

-End Function

-

-Function test_xlHebrewMixedScript(ByRef num)

-Range("A127").Clear

-Range("B127").Clear

-Range("C127").Clear

-Range("D127").Clear

-Range("A127").Value = "xlHebrewMixedScript"

-Range("B127").Value = 2

-Range("C127").Value = num

-B127 = Range("B127").Value

-C127 = Range("C127").Value

-If B127 = C127 Then

-Range("D127").Value = "OK"

-Else

-Range("D127").Value = "NG"

-End If

-End Function

-

-Function test_xlHebrewPartialScript(ByRef num)

-Range("A128").Clear

-Range("B128").Clear

-Range("C128").Clear

-Range("D128").Clear

-Range("A128").Value = "xlHebrewPartialScript"

-Range("B128").Value = 1

-Range("C128").Value = num

-B128 = Range("B128").Value

-C128 = Range("C128").Value

-If B128 = C128 Then

-Range("D128").Value = "OK"

-Else

-Range("D128").Value = "NG"

-End If

-End Function

-

-Function test_xlAllChanges(ByRef num)

-Range("A129").Clear

-Range("B129").Clear

-Range("C129").Clear

-Range("D129").Clear

-Range("A129").Value = "xlAllChanges"

-Range("B129").Value = 2

-Range("C129").Value = num

-B129 = Range("B129").Value

-C129 = Range("C129").Value

-If B129 = C129 Then

-Range("D129").Value = "OK"

-Else

-Range("D129").Value = "NG"

-End If

-End Function

-

-Function test_xlNotYetReviewed(ByRef num)

-Range("A130").Clear

-Range("B130").Clear

-Range("C130").Clear

-Range("D130").Clear

-Range("A130").Value = "xlNotYetReviewed"

-Range("B130").Value = 3

-Range("C130").Value = num

-B130 = Range("B130").Value

-C130 = Range("C130").Value

-If B130 = C130 Then

-Range("D130").Value = "OK"

-Else

-Range("D130").Value = "NG"

-End If

-End Function

-

-Function test_xlSinceMyLastSave(ByRef num)

-Range("A131").Clear

-Range("B131").Clear

-Range("C131").Clear

-Range("D131").Clear

-Range("A131").Value = "xlSinceMyLastSave"

-Range("B131").Value = 1

-Range("C131").Value = num

-B131 = Range("B131").Value

-C131 = Range("C131").Value

-If B131 = C131 Then

-Range("D131").Value = "OK"

-Else

-Range("D131").Value = "NG"

-End If

-End Function

-

-Function test_xlHtmlCalc(ByRef num)

-Range("A132").Clear

-Range("B132").Clear

-Range("C132").Clear

-Range("D132").Clear

-Range("A132").Value = "xlHtmlCalc"

-Range("B132").Value = 1

-Range("C132").Value = num

-B132 = Range("B132").Value

-C132 = Range("C132").Value

-If B132 = C132 Then

-Range("D132").Value = "OK"

-Else

-Range("D132").Value = "NG"

-End If

-End Function

-

-Function test_xlHtmlChart(ByRef num)

-Range("A133").Clear

-Range("B133").Clear

-Range("C133").Clear

-Range("D133").Clear

-Range("A133").Value = "xlHtmlChart"

-Range("B133").Value = 3

-Range("C133").Value = num

-B133 = Range("B133").Value

-C133 = Range("C133").Value

-If B133 = C133 Then

-Range("D133").Value = "OK"

-Else

-Range("D133").Value = "NG"

-End If

-End Function

-

-Function test_xlHtmlList(ByRef num)

-Range("A134").Clear

-Range("B134").Clear

-Range("C134").Clear

-Range("D134").Clear

-Range("A134").Value = "xlHtmlList"

-Range("B134").Value = 2

-Range("C134").Value = num

-B134 = Range("B134").Value

-C134 = Range("C134").Value

-If B134 = C134 Then

-Range("D134").Value = "OK"

-Else

-Range("D134").Value = "NG"

-End If

-End Function

-

-Function test_xlHtmlStatic(ByRef num)

-Range("A135").Clear

-Range("B135").Clear

-Range("C135").Clear

-Range("D135").Clear

-Range("A135").Value = "xlHtmlStatic"

-Range("B135").Value = 0

-Range("C135").Value = num

-B135 = Range("B135").Value

-C135 = Range("C135").Value

-If B135 = C135 Then

-Range("D135").Value = "OK"

-Else

-Range("D135").Value = "NG"

-End If

-End Function

-

-Function test_xlIMEModeAlpha(ByRef num)

-Range("A136").Clear

-Range("B136").Clear

-Range("C136").Clear

-Range("D136").Clear

-Range("A136").Value = "xlIMEModeAlpha"

-Range("B136").Value = 8

-Range("C136").Value = num

-B136 = Range("B136").Value

-C136 = Range("C136").Value

-If B136 = C136 Then

-Range("D136").Value = "OK"

-Else

-Range("D136").Value = "NG"

-End If

-End Function

-

-Function test_xlIMEModeAlphaFull(ByRef num)

-Range("A137").Clear

-Range("B137").Clear

-Range("C137").Clear

-Range("D137").Clear

-Range("A137").Value = "xlIMEModeAlphaFull"

-Range("B137").Value = 7

-Range("C137").Value = num

-B137 = Range("B137").Value

-C137 = Range("C137").Value

-If B137 = C137 Then

-Range("D137").Value = "OK"

-Else

-Range("D137").Value = "NG"

-End If

-End Function

-

-Function test_xlIMEModeDisable(ByRef num)

-Range("A138").Clear

-Range("B138").Clear

-Range("C138").Clear

-Range("D138").Clear

-Range("A138").Value = "xlIMEModeDisable"

-Range("B138").Value = 3

-Range("C138").Value = num

-B138 = Range("B138").Value

-C138 = Range("C138").Value

-If B138 = C138 Then

-Range("D138").Value = "OK"

-Else

-Range("D138").Value = "NG"

-End If

-End Function

-

-Function test_xlIMEModeHangul(ByRef num)

-Range("A139").Clear

-Range("B139").Clear

-Range("C139").Clear

-Range("D139").Clear

-Range("A139").Value = "xlIMEModeHangul"

-Range("B139").Value = 10

-Range("C139").Value = num

-B139 = Range("B139").Value

-C139 = Range("C139").Value

-If B139 = C139 Then

-Range("D139").Value = "OK"

-Else

-Range("D139").Value = "NG"

-End If

-End Function

-

-Function test_xlIMEModeHangulFull(ByRef num)

-Range("A140").Clear

-Range("B140").Clear

-Range("C140").Clear

-Range("D140").Clear

-Range("A140").Value = "xlIMEModeHangulFull"

-Range("B140").Value = 9

-Range("C140").Value = num

-B140 = Range("B140").Value

-C140 = Range("C140").Value

-If B140 = C140 Then

-Range("D140").Value = "OK"

-Else

-Range("D140").Value = "NG"

-End If

-End Function

-

-Function test_xlIMEModeHiragana(ByRef num)

-Range("A141").Clear

-Range("B141").Clear

-Range("C141").Clear

-Range("D141").Clear

-Range("A141").Value = "xlIMEModeHiragana"

-Range("B141").Value = 4

-Range("C141").Value = num

-B141 = Range("B141").Value

-C141 = Range("C141").Value

-If B141 = C141 Then

-Range("D141").Value = "OK"

-Else

-Range("D141").Value = "NG"

-End If

-End Function

-

-Function test_xlIMEModeKatakana(ByRef num)

-Range("A142").Clear

-Range("B142").Clear

-Range("C142").Clear

-Range("D142").Clear

-Range("A142").Value = "xlIMEModeKatakana"

-Range("B142").Value = 5

-Range("C142").Value = num

-B142 = Range("B142").Value

-C142 = Range("C142").Value

-If B142 = C142 Then

-Range("D142").Value = "OK"

-Else

-Range("D142").Value = "NG"

-End If

-End Function

-

-Function test_xlIMEModeKatakanaHalf(ByRef num)

-Range("A143").Clear

-Range("B143").Clear

-Range("C143").Clear

-Range("D143").Clear

-Range("A143").Value = "xlIMEModeKatakanaHalf"

-Range("B143").Value = 6

-Range("C143").Value = num

-B143 = Range("B143").Value

-C143 = Range("C143").Value

-If B143 = C143 Then

-Range("D143").Value = "OK"

-Else

-Range("D143").Value = "NG"

-End If

-End Function

-

-Function test_xlIMEModeNoControl(ByRef num)

-Range("A144").Clear

-Range("B144").Clear

-Range("C144").Clear

-Range("D144").Clear

-Range("A144").Value = "xlIMEModeNoControl"

-Range("B144").Value = 0

-Range("C144").Value = num

-B144 = Range("B144").Value

-C144 = Range("C144").Value

-If B144 = C144 Then

-Range("D144").Value = "OK"

-Else

-Range("D144").Value = "NG"

-End If

-End Function

-

-Function test_xlIMEModeOff(ByRef num)

-Range("A145").Clear

-Range("B145").Clear

-Range("C145").Clear

-Range("D145").Clear

-Range("A145").Value = "xlIMEModeOff"

-Range("B145").Value = 2

-Range("C145").Value = num

-B145 = Range("B145").Value

-C145 = Range("C145").Value

-If B145 = C145 Then

-Range("D145").Value = "OK"

-Else

-Range("D145").Value = "NG"

-End If

-End Function

-

-Function test_xlIMEModeOn(ByRef num)

-Range("A146").Clear

-Range("B146").Clear

-Range("C146").Clear

-Range("D146").Clear

-Range("A146").Value = "xlIMEModeOn"

-Range("B146").Value = 1

-Range("C146").Value = num

-B146 = Range("B146").Value

-C146 = Range("C146").Value

-If B146 = C146 Then

-Range("D146").Value = "OK"

-Else

-Range("D146").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotTableReport(ByRef num)

-Range("A147").Clear

-Range("B147").Clear

-Range("C147").Clear

-Range("D147").Clear

-Range("A147").Value = "xlPivotTableReport"

-Range("B147").Value = 1

-Range("C147").Value = num

-B147 = Range("B147").Value

-C147 = Range("C147").Value

-If B147 = C147 Then

-Range("D147").Value = "OK"

-Else

-Range("D147").Value = "NG"

-End If

-End Function

-

-Function test_xlQueryTable(ByRef num)

-Range("A148").Clear

-Range("B148").Clear

-Range("C148").Clear

-Range("D148").Clear

-Range("A148").Value = "xlQueryTable"

-Range("B148").Value = 0

-Range("C148").Value = num

-B148 = Range("B148").Value

-C148 = Range("C148").Value

-If B148 = C148 Then

-Range("D148").Value = "OK"

-Else

-Range("D148").Value = "NG"

-End If

-End Function

-

-Function test_xlFormatFromLeftOrAbove(ByRef num)

-Range("A149").Clear

-Range("B149").Clear

-Range("C149").Clear

-Range("D149").Clear

-Range("A149").Value = "xlFormatFromLeftOrAbove"

-Range("B149").Value = 0

-Range("C149").Value = num

-B149 = Range("B149").Value

-C149 = Range("C149").Value

-If B149 = C149 Then

-Range("D149").Value = "OK"

-Else

-Range("D149").Value = "NG"

-End If

-End Function

-

-Function test_xlFormatFromRightOrAbove(ByRef num)

-Range("A150").Clear

-Range("B150").Clear

-Range("C150").Clear

-Range("D150").Clear

-Range("A150").Value = "xlFormatFromRightOrAbove"

-Range("B150").Value = 1

-Range("C150").Value = num

-B150 = Range("B150").Value

-C150 = Range("C150").Value

-If B150 = C150 Then

-Range("D150").Value = "OK"

-Else

-Range("D150").Value = "NG"

-End If

-End Function

-

-Function test_xlShiftDown(ByRef num)

-Range("A151").Clear

-Range("B151").Clear

-Range("C151").Clear

-Range("D151").Clear

-Range("A151").Value = "xlShiftDown"

-Range("B151").Value = -4121

-Range("C151").Value = num

-B151 = Range("B151").Value

-C151 = Range("C151").Value

-If B151 = C151 Then

-Range("D151").Value = "OK"

-Else

-Range("D151").Value = "NG"

-End If

-End Function

-

-Function test_xlShiftToRight(ByRef num)

-Range("A152").Clear

-Range("B152").Clear

-Range("C152").Clear

-Range("D152").Clear

-Range("A152").Value = "xlShiftToRight"

-Range("B152").Value = -4161

-Range("C152").Value = num

-B152 = Range("B152").Value

-C152 = Range("C152").Value

-If B152 = C152 Then

-Range("D152").Value = "OK"

-Else

-Range("D152").Value = "NG"

-End If

-End Function

-

-Function test_xlOutline(ByRef num)

-Range("A153").Clear

-Range("B153").Clear

-Range("C153").Clear

-Range("D153").Clear

-Range("A153").Value = "xlOutline"

-Range("B153").Value = 1

-Range("C153").Value = num

-B153 = Range("B153").Value

-C153 = Range("C153").Value

-If B153 = C153 Then

-Range("D153").Value = "OK"

-Else

-Range("D153").Value = "NG"

-End If

-End Function

-

-Function test_xlTabular(ByRef num)

-Range("A154").Clear

-Range("B154").Clear

-Range("C154").Clear

-Range("D154").Clear

-Range("A154").Value = "xlTabular"

-Range("B154").Value = 0

-Range("C154").Value = num

-B154 = Range("B154").Value

-C154 = Range("C154").Value

-If B154 = C154 Then

-Range("D154").Value = "OK"

-Else

-Range("D154").Value = "NG"

-End If

-End Function

-

-Function test_xlLegendPositionBottom(ByRef num)

-Range("A155").Clear

-Range("B155").Clear

-Range("C155").Clear

-Range("D155").Clear

-Range("A155").Value = "xlLegendPositionBottom"

-Range("B155").Value = -4107

-Range("C155").Value = num

-B155 = Range("B155").Value

-C155 = Range("C155").Value

-If B155 = C155 Then

-Range("D155").Value = "OK"

-Else

-Range("D155").Value = "NG"

-End If

-End Function

-

-Function test_xlLegendPositionCorner(ByRef num)

-Range("A156").Clear

-Range("B156").Clear

-Range("C156").Clear

-Range("D156").Clear

-Range("A156").Value = "xlLegendPositionCorner"

-Range("B156").Value = 2

-Range("C156").Value = num

-B156 = Range("B156").Value

-C156 = Range("C156").Value

-If B156 = C156 Then

-Range("D156").Value = "OK"

-Else

-Range("D156").Value = "NG"

-End If

-End Function

-

-Function test_xlLegendPositionLeft(ByRef num)

-Range("A157").Clear

-Range("B157").Clear

-Range("C157").Clear

-Range("D157").Clear

-Range("A157").Value = "xlLegendPositionLeft"

-Range("B157").Value = -4131

-Range("C157").Value = num

-B157 = Range("B157").Value

-C157 = Range("C157").Value

-If B157 = C157 Then

-Range("D157").Value = "OK"

-Else

-Range("D157").Value = "NG"

-End If

-End Function

-

-Function test_xlLegendPositionRight(ByRef num)

-Range("A158").Clear

-Range("B158").Clear

-Range("C158").Clear

-Range("D158").Clear

-Range("A158").Value = "xlLegendPositionRight"

-Range("B158").Value = -4152

-Range("C158").Value = num

-B158 = Range("B158").Value

-C158 = Range("C158").Value

-If B158 = C158 Then

-Range("D158").Value = "OK"

-Else

-Range("D158").Value = "NG"

-End If

-End Function

-

-Function test_xlLegendPositionTop(ByRef num)

-Range("A159").Clear

-Range("B159").Clear

-Range("C159").Clear

-Range("D159").Clear

-Range("A159").Value = "xlLegendPositionTop"

-Range("B159").Value = -4160

-Range("C159").Value = num

-B159 = Range("B159").Value

-C159 = Range("C159").Value

-If B159 = C159 Then

-Range("D159").Value = "OK"

-Else

-Range("D159").Value = "NG"

-End If

-End Function

-

-Function test_xlContinuous(ByRef num)

-Range("A160").Clear

-Range("B160").Clear

-Range("C160").Clear

-Range("D160").Clear

-Range("A160").Value = "xlContinuous"

-Range("B160").Value = 1

-Range("C160").Value = num

-B160 = Range("B160").Value

-C160 = Range("C160").Value

-If B160 = C160 Then

-Range("D160").Value = "OK"

-Else

-Range("D160").Value = "NG"

-End If

-End Function

-

-Function test_xlDash(ByRef num)

-Range("A161").Clear

-Range("B161").Clear

-Range("C161").Clear

-Range("D161").Clear

-Range("A161").Value = "xlDash"

-Range("B161").Value = -4115

-Range("C161").Value = num

-B161 = Range("B161").Value

-C161 = Range("C161").Value

-If B161 = C161 Then

-Range("D161").Value = "OK"

-Else

-Range("D161").Value = "NG"

-End If

-End Function

-

-Function test_xlDashDot(ByRef num)

-Range("A162").Clear

-Range("B162").Clear

-Range("C162").Clear

-Range("D162").Clear

-Range("A162").Value = "xlDashDot"

-Range("B162").Value = 4

-Range("C162").Value = num

-B162 = Range("B162").Value

-C162 = Range("C162").Value

-If B162 = C162 Then

-Range("D162").Value = "OK"

-Else

-Range("D162").Value = "NG"

-End If

-End Function

-

-Function test_xlDashDotDot(ByRef num)

-Range("A163").Clear

-Range("B163").Clear

-Range("C163").Clear

-Range("D163").Clear

-Range("A163").Value = "xlDashDotDot"

-Range("B163").Value = 5

-Range("C163").Value = num

-B163 = Range("B163").Value

-C163 = Range("C163").Value

-If B163 = C163 Then

-Range("D163").Value = "OK"

-Else

-Range("D163").Value = "NG"

-End If

-End Function

-

-Function test_xlDot(ByRef num)

-Range("A164").Clear

-Range("B164").Clear

-Range("C164").Clear

-Range("D164").Clear

-Range("A164").Value = "xlDot"

-Range("B164").Value = -4118

-Range("C164").Value = num

-B164 = Range("B164").Value

-C164 = Range("C164").Value

-If B164 = C164 Then

-Range("D164").Value = "OK"

-Else

-Range("D164").Value = "NG"

-End If

-End Function

-

-Function test_xlDouble(ByRef num)

-Range("A165").Clear

-Range("B165").Clear

-Range("C165").Clear

-Range("D165").Clear

-Range("A165").Value = "xlDouble"

-Range("B165").Value = -4119

-Range("C165").Value = num

-B165 = Range("B165").Value

-C165 = Range("C165").Value

-If B165 = C165 Then

-Range("D165").Value = "OK"

-Else

-Range("D165").Value = "NG"

-End If

-End Function

-

-Function test_xlLineStyleNone(ByRef num)

-Range("A166").Clear

-Range("B166").Clear

-Range("C166").Clear

-Range("D166").Clear

-Range("A166").Value = "xlLineStyleNone"

-Range("B166").Value = -4142

-Range("C166").Value = num

-B166 = Range("B166").Value

-C166 = Range("C166").Value

-If B166 = C166 Then

-Range("D166").Value = "OK"

-Else

-Range("D166").Value = "NG"

-End If

-End Function

-

-Function test_xlSlantDashDot(ByRef num)

-Range("A167").Clear

-Range("B167").Clear

-Range("C167").Clear

-Range("D167").Clear

-Range("A167").Value = "xlSlantDashDot"

-Range("B167").Value = 13

-Range("C167").Value = num

-B167 = Range("B167").Value

-C167 = Range("C167").Value

-If B167 = C167 Then

-Range("D167").Value = "OK"

-Else

-Range("D167").Value = "NG"

-End If

-End Function

-

-Function test_xlExcelLink(ByRef num)

-Range("A168").Clear

-Range("B168").Clear

-Range("C168").Clear

-Range("D168").Clear

-Range("A168").Value = "xlExcelLink"

-Range("B168").Value = 1

-Range("C168").Value = num

-B168 = Range("B168").Value

-C168 = Range("C168").Value

-If B168 = C168 Then

-Range("D168").Value = "OK"

-Else

-Range("D168").Value = "NG"

-End If

-End Function

-

-Function test_XlOLELink(ByRef num)

-Range("A169").Clear

-Range("B169").Clear

-Range("C169").Clear

-Range("D169").Clear

-Range("A169").Value = "xlOLELink"

-Range("B169").Value = 2

-Range("C169").Value = num

-B169 = Range("B169").Value

-C169 = Range("C169").Value

-If B169 = C169 Then

-Range("D169").Value = "OK"

-Else

-Range("D169").Value = "NG"

-End If

-End Function

-

-Function test_xlPublishers(ByRef num)

-Range("A170").Clear

-Range("B170").Clear

-Range("C170").Clear

-Range("D170").Clear

-Range("A170").Value = "xlPublishers"

-Range("B170").Value = 5

-Range("C170").Value = num

-B170 = Range("B170").Value

-C170 = Range("C170").Value

-If B170 = C170 Then

-Range("D170").Value = "OK"

-Else

-Range("D170").Value = "NG"

-End If

-End Function

-

-Function test_xlSubscribers(ByRef num)

-Range("A171").Clear

-Range("B171").Clear

-Range("C171").Clear

-Range("D171").Clear

-Range("A171").Value = "xlSubscribers"

-Range("B171").Value = 6

-Range("C171").Value = num

-B171 = Range("B171").Value

-C171 = Range("C171").Value

-If B171 = C171 Then

-Range("D171").Value = "OK"

-Else

-Range("D171").Value = "NG"

-End If

-End Function

-

-Function test_xlEditionDate(ByRef num)

-Range("A172").Clear

-Range("B172").Clear

-Range("C172").Clear

-Range("D172").Clear

-Range("A172").Value = "xlEditionDate"

-Range("B172").Value = 2

-Range("C172").Value = num

-B172 = Range("B172").Value

-C172 = Range("C172").Value

-If B172 = C172 Then

-Range("D172").Value = "OK"

-Else

-Range("D172").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkInfoStatus(ByRef num)

-Range("A173").Clear

-Range("B173").Clear

-Range("C173").Clear

-Range("D173").Clear

-Range("A173").Value = "xlLinkInfoStatus"

-Range("B173").Value = 3

-Range("C173").Value = num

-B173 = Range("B173").Value

-C173 = Range("C173").Value

-If B173 = C173 Then

-Range("D173").Value = "OK"

-Else

-Range("D173").Value = "NG"

-End If

-End Function

-

-Function test_xlUpdateState(ByRef num)

-Range("A174").Clear

-Range("B174").Clear

-Range("C174").Clear

-Range("D174").Clear

-Range("A174").Value = "xlUpdateState"

-Range("B174").Value = 1

-Range("C174").Value = num

-B174 = Range("B174").Value

-C174 = Range("C174").Value

-If B174 = C174 Then

-Range("D174").Value = "OK"

-Else

-Range("D174").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkInfoOLELinks(ByRef num)

-Range("A175").Clear

-Range("B175").Clear

-Range("C175").Clear

-Range("D175").Clear

-Range("A175").Value = "xlLinkInfoOLELinks"

-Range("B175").Value = 2

-Range("C175").Value = num

-B175 = Range("B175").Value

-C175 = Range("C175").Value

-If B175 = C175 Then

-Range("D175").Value = "OK"

-Else

-Range("D175").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkInfoPublishers(ByRef num)

-Range("A176").Clear

-Range("B176").Clear

-Range("C176").Clear

-Range("D176").Clear

-Range("A176").Value = "xlLinkInfoPublishers"

-Range("B176").Value = 5

-Range("C176").Value = num

-B176 = Range("B176").Value

-C176 = Range("C176").Value

-If B176 = C176 Then

-Range("D176").Value = "OK"

-Else

-Range("D176").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkInfoSubscribers(ByRef num)

-Range("A177").Clear

-Range("B177").Clear

-Range("C177").Clear

-Range("D177").Clear

-Range("A177").Value = "xlLinkInfoSubscribers"

-Range("B177").Value = 6

-Range("C177").Value = num

-B177 = Range("B177").Value

-C177 = Range("C177").Value

-If B177 = C177 Then

-Range("D177").Value = "OK"

-Else

-Range("D177").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkStatusCopiedValues(ByRef num)

-Range("A178").Clear

-Range("B178").Clear

-Range("C178").Clear

-Range("D178").Clear

-Range("A178").Value = "xlLinkStatusCopiedValues"

-Range("B178").Value = 10

-Range("C178").Value = num

-B178 = Range("B178").Value

-C178 = Range("C178").Value

-If B178 = C178 Then

-Range("D178").Value = "OK"

-Else

-Range("D178").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkStatusIndeterminate(ByRef num)

-Range("A179").Clear

-Range("B179").Clear

-Range("C179").Clear

-Range("D179").Clear

-Range("A179").Value = "xlLinkStatusIndeterminate"

-Range("B179").Value = 5

-Range("C179").Value = num

-B179 = Range("B179").Value

-C179 = Range("C179").Value

-If B179 = C179 Then

-Range("D179").Value = "OK"

-Else

-Range("D179").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkStatusInvalidName(ByRef num)

-Range("A180").Clear

-Range("B180").Clear

-Range("C180").Clear

-Range("D180").Clear

-Range("A180").Value = "xlLinkStatusInvalidName"

-Range("B180").Value = 7

-Range("C180").Value = num

-B180 = Range("B180").Value

-C180 = Range("C180").Value

-If B180 = C180 Then

-Range("D180").Value = "OK"

-Else

-Range("D180").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkStatusMissingFile(ByRef num)

-Range("A181").Clear

-Range("B181").Clear

-Range("C181").Clear

-Range("D181").Clear

-Range("A181").Value = "xlLinkStatusMissingFile"

-Range("B181").Value = 1

-Range("C181").Value = num

-B181 = Range("B181").Value

-C181 = Range("C181").Value

-If B181 = C181 Then

-Range("D181").Value = "OK"

-Else

-Range("D181").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkStatusMissingSheet(ByRef num)

-Range("A182").Clear

-Range("B182").Clear

-Range("C182").Clear

-Range("D182").Clear

-Range("A182").Value = "xlLinkStatusMissingSheet"

-Range("B182").Value = 2

-Range("C182").Value = num

-B182 = Range("B182").Value

-C182 = Range("C182").Value

-If B182 = C182 Then

-Range("D182").Value = "OK"

-Else

-Range("D182").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkStatusNotStarted(ByRef num)

-Range("A183").Clear

-Range("B183").Clear

-Range("C183").Clear

-Range("D183").Clear

-Range("A183").Value = "xlLinkStatusNotStarted"

-Range("B183").Value = 6

-Range("C183").Value = num

-B183 = Range("B183").Value

-C183 = Range("C183").Value

-If B183 = C183 Then

-Range("D183").Value = "OK"

-Else

-Range("D183").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkStatusOK(ByRef num)

-Range("A184").Clear

-Range("B184").Clear

-Range("C184").Clear

-Range("D184").Clear

-Range("A184").Value = "xlLinkStatusOK"

-Range("B184").Value = 0

-Range("C184").Value = num

-B184 = Range("B184").Value

-C184 = Range("C184").Value

-If B184 = C184 Then

-Range("D184").Value = "OK"

-Else

-Range("D184").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkStatusOld(ByRef num)

-Range("A185").Clear

-Range("B185").Clear

-Range("C185").Clear

-Range("D185").Clear

-Range("A185").Value = "xlLinkStatusOld"

-Range("B185").Value = 3

-Range("C185").Value = num

-B185 = Range("B185").Value

-C185 = Range("C185").Value

-If B185 = C185 Then

-Range("D185").Value = "OK"

-Else

-Range("D185").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkStatusSourceNotCalculated(ByRef num)

-Range("A186").Clear

-Range("B186").Clear

-Range("C186").Clear

-Range("D186").Clear

-Range("A186").Value = "xlLinkStatusSourceNotCalculated"

-Range("B186").Value = 4

-Range("C186").Value = num

-B186 = Range("B186").Value

-C186 = Range("C186").Value

-If B186 = C186 Then

-Range("D186").Value = "OK"

-Else

-Range("D186").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkStatusSourceNotOpen(ByRef num)

-Range("A187").Clear

-Range("B187").Clear

-Range("C187").Clear

-Range("D187").Clear

-Range("A187").Value = "xlLinkStatusSourceNotOpen"

-Range("B187").Value = 8

-Range("C187").Value = num

-B187 = Range("B187").Value

-C187 = Range("C187").Value

-If B187 = C187 Then

-Range("D187").Value = "OK"

-Else

-Range("D187").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkStatusSourceOpen(ByRef num)

-Range("A188").Clear

-Range("B188").Clear

-Range("C188").Clear

-Range("D188").Clear

-Range("A188").Value = "xlLinkStatusSourceOpen"

-Range("B188").Value = 9

-Range("C188").Value = num

-B188 = Range("B188").Value

-C188 = Range("C188").Value

-If B188 = C188 Then

-Range("D188").Value = "OK"

-Else

-Range("D188").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkTypeExcelLinks(ByRef num)

-Range("A189").Clear

-Range("B189").Clear

-Range("C189").Clear

-Range("D189").Clear

-Range("A189").Value = "xlLinkTypeExcelLinks"

-Range("B189").Value = 1

-Range("C189").Value = num

-B189 = Range("B189").Value

-C189 = Range("C189").Value

-If B189 = C189 Then

-Range("D189").Value = "OK"

-Else

-Range("D189").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkTypeOLELinks(ByRef num)

-Range("A190").Clear

-Range("B190").Clear

-Range("C190").Clear

-Range("D190").Clear

-Range("A190").Value = "xlLinkTypeOLELinks"

-Range("B190").Value = 2

-Range("C190").Value = num

-B190 = Range("B190").Value

-C190 = Range("C190").Value

-If B190 = C190 Then

-Range("D190").Value = "OK"

-Else

-Range("D190").Value = "NG"

-End If

-End Function

-

-Function test_xlListConflictDialog(ByRef num)

-Range("A191").Clear

-Range("B191").Clear

-Range("C191").Clear

-Range("D191").Clear

-Range("A191").Value = "xlListConflictDialog"

-Range("B191").Value = 0

-Range("C191").Value = num

-B191 = Range("B191").Value

-C191 = Range("C191").Value

-If B191 = C191 Then

-Range("D191").Value = "OK"

-Else

-Range("D191").Value = "NG"

-End If

-End Function

-

-Function test_xlListConflictDiscardAllConflicts(ByRef num)

-Range("A192").Clear

-Range("B192").Clear

-Range("C192").Clear

-Range("D192").Clear

-Range("A192").Value = "xlListConflictDiscardAllConflicts"

-Range("B192").Value = 2

-Range("C192").Value = num

-B192 = Range("B192").Value

-C192 = Range("C192").Value

-If B192 = C192 Then

-Range("D192").Value = "OK"

-Else

-Range("D192").Value = "NG"

-End If

-End Function

-

-Function test_xlListConflictError(ByRef num)

-Range("A193").Clear

-Range("B193").Clear

-Range("C193").Clear

-Range("D193").Clear

-Range("A193").Value = "xlListConflictError"

-Range("B193").Value = 3

-Range("C193").Value = num

-B193 = Range("B193").Value

-C193 = Range("C193").Value

-If B193 = C193 Then

-Range("D193").Value = "OK"

-Else

-Range("D193").Value = "NG"

-End If

-End Function

-

-Function test_xlListConflictRetryAllConflicts(ByRef num)

-Range("A194").Clear

-Range("B194").Clear

-Range("C194").Clear

-Range("D194").Clear

-Range("A194").Value = "xlListConflictRetryAllConflicts"

-Range("B194").Value = 1

-Range("C194").Value = num

-B194 = Range("B194").Value

-C194 = Range("C194").Value

-If B194 = C194 Then

-Range("D194").Value = "OK"

-Else

-Range("D194").Value = "NG"

-End If

-End Function

-

-Function test_xlListDataTypeCheckbox(ByRef num)

-Range("A195").Clear

-Range("B195").Clear

-Range("C195").Clear

-Range("D195").Clear

-Range("A195").Value = "xlListDataTypeCheckbox"

-Range("B195").Value = 9

-Range("C195").Value = num

-B195 = Range("B195").Value

-C195 = Range("C195").Value

-If B195 = C195 Then

-Range("D195").Value = "OK"

-Else

-Range("D195").Value = "NG"

-End If

-End Function

-

-Function test_xlListDataTypeChoice(ByRef num)

-Range("A196").Clear

-Range("B196").Clear

-Range("C196").Clear

-Range("D196").Clear

-Range("A196").Value = "xlListDataTypeChoice"

-Range("B196").Value = 6

-Range("C196").Value = num

-B196 = Range("B196").Value

-C196 = Range("C196").Value

-If B196 = C196 Then

-Range("D196").Value = "OK"

-Else

-Range("D196").Value = "NG"

-End If

-End Function

-

-Function test_xlListDataTypeChoiceMulti(ByRef num)

-Range("A197").Clear

-Range("B197").Clear

-Range("C197").Clear

-Range("D197").Clear

-Range("A197").Value = "xlListDataTypeChoiceMulti"

-Range("B197").Value = 7

-Range("C197").Value = num

-B197 = Range("B197").Value

-C197 = Range("C197").Value

-If B197 = C197 Then

-Range("D197").Value = "OK"

-Else

-Range("D197").Value = "NG"

-End If

-End Function

-

-Function test_xlListDataTypeCounter(ByRef num)

-Range("A198").Clear

-Range("B198").Clear

-Range("C198").Clear

-Range("D198").Clear

-Range("A198").Value = "xlListDataTypeCounter"

-Range("B198").Value = 11

-Range("C198").Value = num

-B198 = Range("B198").Value

-C198 = Range("C198").Value

-If B198 = C198 Then

-Range("D198").Value = "OK"

-Else

-Range("D198").Value = "NG"

-End If

-End Function

-

-Function test_xlListDataTypeCurrency(ByRef num)

-Range("A199").Clear

-Range("B199").Clear

-Range("C199").Clear

-Range("D199").Clear

-Range("A199").Value = "xlListDataTypeCurrency"

-Range("B199").Value = 4

-Range("C199").Value = num

-B199 = Range("B199").Value

-C199 = Range("C199").Value

-If B199 = C199 Then

-Range("D199").Value = "OK"

-Else

-Range("D199").Value = "NG"

-End If

-End Function

-

-Function test_xlListDataTypeDateTime(ByRef num)

-Range("A200").Clear

-Range("B200").Clear

-Range("C200").Clear

-Range("D200").Clear

-Range("A200").Value = "xlListDataTypeDateTime"

-Range("B200").Value = 5

-Range("C200").Value = num

-B200 = Range("B200").Value

-C200 = Range("C200").Value

-If B200 = C200 Then

-Range("D200").Value = "OK"

-Else

-Range("D200").Value = "NG"

-End If

-End Function

-

-Function test_xlListDataTypeHyperLink(ByRef num)

-Range("A201").Clear

-Range("B201").Clear

-Range("C201").Clear

-Range("D201").Clear

-Range("A201").Value = "xlListDataTypeHyperLink"

-Range("B201").Value = 10

-Range("C201").Value = num

-B201 = Range("B201").Value

-C201 = Range("C201").Value

-If B201 = C201 Then

-Range("D201").Value = "OK"

-Else

-Range("D201").Value = "NG"

-End If

-End Function

-

-Function test_xlListDataTypeListLookup(ByRef num)

-Range("A202").Clear

-Range("B202").Clear

-Range("C202").Clear

-Range("D202").Clear

-Range("A202").Value = "xlListDataTypeListLookup"

-Range("B202").Value = 8

-Range("C202").Value = num

-B202 = Range("B202").Value

-C202 = Range("C202").Value

-If B202 = C202 Then

-Range("D202").Value = "OK"

-Else

-Range("D202").Value = "NG"

-End If

-End Function

-

-Function test_xlListDataTypeMultiLineRichText(ByRef num)

-Range("A203").Clear

-Range("B203").Clear

-Range("C203").Clear

-Range("D203").Clear

-Range("A203").Value = "xlListDataTypeMultiLineRichText"

-Range("B203").Value = 12

-Range("C203").Value = num

-B203 = Range("B203").Value

-C203 = Range("C203").Value

-If B203 = C203 Then

-Range("D203").Value = "OK"

-Else

-Range("D203").Value = "NG"

-End If

-End Function

-

-Function test_xlListDataTypeMultiLineText(ByRef num)

-Range("A204").Clear

-Range("B204").Clear

-Range("C204").Clear

-Range("D204").Clear

-Range("A204").Value = "xlListDataTypeMultiLineText"

-Range("B204").Value = 2

-Range("C204").Value = num

-B204 = Range("B204").Value

-C204 = Range("C204").Value

-If B204 = C204 Then

-Range("D204").Value = "OK"

-Else

-Range("D204").Value = "NG"

-End If

-End Function

-

-Function test_xlListDataTypeNone(ByRef num)

-Range("A205").Clear

-Range("B205").Clear

-Range("C205").Clear

-Range("D205").Clear

-Range("A205").Value = "xlListDataTypeNone"

-Range("B205").Value = 0

-Range("C205").Value = num

-B205 = Range("B205").Value

-C205 = Range("C205").Value

-If B205 = C205 Then

-Range("D205").Value = "OK"

-Else

-Range("D205").Value = "NG"

-End If

-End Function

-

-Function test_xlListDataTypeNumber(ByRef num)

-Range("A206").Clear

-Range("B206").Clear

-Range("C206").Clear

-Range("D206").Clear

-Range("A206").Value = "xlListDataTypeNumber"

-Range("B206").Value = 3

-Range("C206").Value = num

-B206 = Range("B206").Value

-C206 = Range("C206").Value

-If B206 = C206 Then

-Range("D206").Value = "OK"

-Else

-Range("D206").Value = "NG"

-End If

-End Function

-

-Function test_xlListDataTypeText(ByRef num)

-Range("A207").Clear

-Range("B207").Clear

-Range("C207").Clear

-Range("D207").Clear

-Range("A207").Value = "xlListDataTypeText"

-Range("B207").Value = 1

-Range("C207").Value = num

-B207 = Range("B207").Value

-C207 = Range("C207").Value

-If B207 = C207 Then

-Range("D207").Value = "OK"

-Else

-Range("D207").Value = "NG"

-End If

-End Function

-

-Function test_xlSrcExternal(ByRef num)

-Range("A208").Clear

-Range("B208").Clear

-Range("C208").Clear

-Range("D208").Clear

-Range("A208").Value = "xlSrcExternal"

-Range("B208").Value = 0

-Range("C208").Value = num

-B208 = Range("B208").Value

-C208 = Range("C208").Value

-If B208 = C208 Then

-Range("D208").Value = "OK"

-Else

-Range("D208").Value = "NG"

-End If

-End Function

-

-Function test_xlSrcRange(ByRef num)

-Range("A209").Clear

-Range("B209").Clear

-Range("C209").Clear

-Range("D209").Clear

-Range("A209").Value = "xlSrcRange"

-Range("B209").Value = 1

-Range("C209").Value = num

-B209 = Range("B209").Value

-C209 = Range("C209").Value

-If B209 = C209 Then

-Range("D209").Value = "OK"

-Else

-Range("D209").Value = "NG"

-End If

-End Function

-

-Function test_xlSrcXml(ByRef num)

-Range("A210").Clear

-Range("B210").Clear

-Range("C210").Clear

-Range("D210").Clear

-Range("A210").Value = "xlSrcXml"

-Range("B210").Value = 2

-Range("C210").Value = num

-B210 = Range("B210").Value

-C210 = Range("C210").Value

-If B210 = C210 Then

-Range("D210").Value = "OK"

-Else

-Range("D210").Value = "NG"

-End If

-End Function

-

-Function test_xlColumnHeader(ByRef num)

-Range("A211").Clear

-Range("B211").Clear

-Range("C211").Clear

-Range("D211").Clear

-Range("A211").Value = "xlColumnHeader"

-Range("B211").Value = -4110

-Range("C211").Value = num

-B211 = Range("B211").Value

-C211 = Range("C211").Value

-If B211 = C211 Then

-Range("D211").Value = "OK"

-Else

-Range("D211").Value = "NG"

-End If

-End Function

-

-Function test_xlColumnItem(ByRef num)

-Range("A212").Clear

-Range("B212").Clear

-Range("C212").Clear

-Range("D212").Clear

-Range("A212").Value = "xlColumnItem"

-Range("B212").Value = 5

-Range("C212").Value = num

-B212 = Range("B212").Value

-C212 = Range("C212").Value

-If B212 = C212 Then

-Range("D212").Value = "OK"

-Else

-Range("D212").Value = "NG"

-End If

-End Function

-

-Function test_xlDataHeader(ByRef num)

-Range("A213").Clear

-Range("B213").Clear

-Range("C213").Clear

-Range("D213").Clear

-Range("A213").Value = "xlDataHeader"

-Range("B213").Value = 3

-Range("C213").Value = num

-B213 = Range("B213").Value

-C213 = Range("C213").Value

-If B213 = C213 Then

-Range("D213").Value = "OK"

-Else

-Range("D213").Value = "NG"

-End If

-End Function

-

-Function test_xlDataItem(ByRef num)

-Range("A214").Clear

-Range("B214").Clear

-Range("C214").Clear

-Range("D214").Clear

-Range("A214").Value = "xlDataItem"

-Range("B214").Value = 7

-Range("C214").Value = num

-B214 = Range("B214").Value

-C214 = Range("C214").Value

-If B214 = C214 Then

-Range("D214").Value = "OK"

-Else

-Range("D214").Value = "NG"

-End If

-End Function

-

-Function test_xlPageHeader(ByRef num)

-Range("A215").Clear

-Range("B215").Clear

-Range("C215").Clear

-Range("D215").Clear

-Range("A215").Value = "xlPageHeader"

-Range("B215").Value = 2

-Range("C215").Value = num

-B215 = Range("B215").Value

-C215 = Range("C215").Value

-If B215 = C215 Then

-Range("D215").Value = "OK"

-Else

-Range("D215").Value = "NG"

-End If

-End Function

-

-Function test_xlPageItem(ByRef num)

-Range("A216").Clear

-Range("B216").Clear

-Range("C216").Clear

-Range("D216").Clear

-Range("A216").Value = "xlPageItem"

-Range("B216").Value = 6

-Range("C216").Value = num

-B216 = Range("B216").Value

-C216 = Range("C216").Value

-If B216 = C216 Then

-Range("D216").Value = "OK"

-Else

-Range("D216").Value = "NG"

-End If

-End Function

-

-Function test_xlRowHeader(ByRef num)

-Range("A217").Clear

-Range("B217").Clear

-Range("C217").Clear

-Range("D217").Clear

-Range("A217").Value = "xlRowHeader"

-Range("B217").Value = -4153

-Range("C217").Value = num

-B217 = Range("B217").Value

-C217 = Range("C217").Value

-If B217 = C217 Then

-Range("D217").Value = "OK"

-Else

-Range("D217").Value = "NG"

-End If

-End Function

-

-Function test_xlRowItem(ByRef num)

-Range("A218").Clear

-Range("B218").Clear

-Range("C218").Clear

-Range("D218").Clear

-Range("A218").Value = "xlRowItem"

-Range("B218").Value = 4

-Range("C218").Value = num

-B218 = Range("B218").Value

-C218 = Range("C218").Value

-If B218 = C218 Then

-Range("D218").Value = "OK"

-Else

-Range("D218").Value = "NG"

-End If

-End Function

-

-Function test_xlTableBody(ByRef num)

-Range("A219").Clear

-Range("B219").Clear

-Range("C219").Clear

-Range("D219").Clear

-Range("A219").Value = "xlTableBody"

-Range("B219").Value = 8

-Range("C219").Value = num

-B219 = Range("B219").Value

-C219 = Range("C219").Value

-If B219 = C219 Then

-Range("D219").Value = "OK"

-Else

-Range("D219").Value = "NG"

-End If

-End Function

-

-Function test_xlPart(ByRef num)

-Range("A220").Clear

-Range("B220").Clear

-Range("C220").Clear

-Range("D220").Clear

-Range("A220").Value = "xlPart"

-Range("B220").Value = 2

-Range("C220").Value = num

-B220 = Range("B220").Value

-C220 = Range("C220").Value

-If B220 = C220 Then

-Range("D220").Value = "OK"

-Else

-Range("D220").Value = "NG"

-End If

-End Function

-

-Function test_xlWhole(ByRef num)

-Range("A221").Clear

-Range("B221").Clear

-Range("C221").Clear

-Range("D221").Clear

-Range("A221").Value = "xlWhole"

-Range("B221").Value = 1

-Range("C221").Value = num

-B221 = Range("B221").Value

-C221 = Range("C221").Value

-If B221 = C221 Then

-Range("D221").Value = "OK"

-Else

-Range("D221").Value = "NG"

-End If

-End Function

-

-Function test_xlMicrosoftAccess(ByRef num)

-Range("A222").Clear

-Range("B222").Clear

-Range("C222").Clear

-Range("D222").Clear

-Range("A222").Value = "xlMicrosoftAccess"

-Range("B222").Value = 4

-Range("C222").Value = num

-B222 = Range("B222").Value

-C222 = Range("C222").Value

-If B222 = C222 Then

-Range("D222").Value = "OK"

-Else

-Range("D222").Value = "NG"

-End If

-End Function

-

-Function test_xlMicrosoftFoxPro(ByRef num)

-Range("A223").Clear

-Range("B223").Clear

-Range("C223").Clear

-Range("D223").Clear

-Range("A223").Value = "xlMicrosoftFoxPro"

-Range("B223").Value = 5

-Range("C223").Value = num

-B223 = Range("B223").Value

-C223 = Range("C223").Value

-If B223 = C223 Then

-Range("D223").Value = "OK"

-Else

-Range("D223").Value = "NG"

-End If

-End Function

-

-Function test_xlMicrosoftMail(ByRef num)

-Range("A224").Clear

-Range("B224").Clear

-Range("C224").Clear

-Range("D224").Clear

-Range("A224").Value = "xlMicrosoftMail"

-Range("B224").Value = 3

-Range("C224").Value = num

-B224 = Range("B224").Value

-C224 = Range("C224").Value

-If B224 = C224 Then

-Range("D224").Value = "OK"

-Else

-Range("D224").Value = "NG"

-End If

-End Function

-

-Function test_xlMicrosoftPowerPoint(ByRef num)

-Range("A225").Clear

-Range("B225").Clear

-Range("C225").Clear

-Range("D225").Clear

-Range("A225").Value = "xlMicrosoftPowerPoint"

-Range("B225").Value = 2

-Range("C225").Value = num

-B225 = Range("B225").Value

-C225 = Range("C225").Value

-If B225 = C225 Then

-Range("D225").Value = "OK"

-Else

-Range("D225").Value = "NG"

-End If

-End Function

-

-Function test_xlMicrosoftProject(ByRef num)

-Range("A226").Clear

-Range("B226").Clear

-Range("C226").Clear

-Range("D226").Clear

-Range("A226").Value = "xlMicrosoftProject"

-Range("B226").Value = 6

-Range("C226").Value = num

-B226 = Range("B226").Value

-C226 = Range("C226").Value

-If B226 = C226 Then

-Range("D226").Value = "OK"

-Else

-Range("D226").Value = "NG"

-End If

-End Function

-

-Function test_xlMicrosoftSchedulePlus(ByRef num)

-Range("A227").Clear

-Range("B227").Clear

-Range("C227").Clear

-Range("D227").Clear

-Range("A227").Value = "xlMicrosoftSchedulePlus"

-Range("B227").Value = 7

-Range("C227").Value = num

-B227 = Range("B227").Value

-C227 = Range("C227").Value

-If B227 = C227 Then

-Range("D227").Value = "OK"

-Else

-Range("D227").Value = "NG"

-End If

-End Function

-

-Function test_xlMicrosoftWord(ByRef num)

-Range("A228").Clear

-Range("B228").Clear

-Range("C228").Clear

-Range("D228").Clear

-Range("A228").Value = "xlMicrosoftWord"

-Range("B228").Value = 1

-Range("C228").Value = num

-B228 = Range("B228").Value

-C228 = Range("C228").Value

-If B228 = C228 Then

-Range("D228").Value = "OK"

-Else

-Range("D228").Value = "NG"

-End If

-End Function

-

-Function test_xlMAPI(ByRef num)

-Range("A229").Clear

-Range("B229").Clear

-Range("C229").Clear

-Range("D229").Clear

-Range("A229").Value = "xlMAPI"

-Range("B229").Value = 1

-Range("C229").Value = num

-B229 = Range("B229").Value

-C229 = Range("C229").Value

-If B229 = C229 Then

-Range("D229").Value = "OK"

-Else

-Range("D229").Value = "NG"

-End If

-End Function

-

-Function test_xlNoMailSystem(ByRef num)

-Range("A230").Clear

-Range("B230").Clear

-Range("C230").Clear

-Range("D230").Clear

-Range("A230").Value = "xlNoMailSystem"

-Range("B230").Value = 0

-Range("C230").Value = num

-B230 = Range("B230").Value

-C230 = Range("C230").Value

-If B230 = C230 Then

-Range("D230").Value = "OK"

-Else

-Range("D230").Value = "NG"

-End If

-End Function

-

-Function test_xlPowerTalk(ByRef num)

-Range("A231").Clear

-Range("B231").Clear

-Range("C231").Clear

-Range("D231").Clear

-Range("A231").Value = "xlPowerTalk"

-Range("B231").Value = 2

-Range("C231").Value = num

-B231 = Range("B231").Value

-C231 = Range("C231").Value

-If B231 = C231 Then

-Range("D231").Value = "OK"

-Else

-Range("D231").Value = "NG"

-End If

-End Function

-

-Function test_xlMarkerStyleAutomatic(ByRef num)

-Range("A232").Clear

-Range("B232").Clear

-Range("C232").Clear

-Range("D232").Clear

-Range("A232").Value = "xlMarkerStyleAutomatic"

-Range("B232").Value = -4105

-Range("C232").Value = num

-B232 = Range("B232").Value

-C232 = Range("C232").Value

-If B232 = C232 Then

-Range("D232").Value = "OK"

-Else

-Range("D232").Value = "NG"

-End If

-End Function

-

-Function test_xlMarkerStyleCircle(ByRef num)

-Range("A233").Clear

-Range("B233").Clear

-Range("C233").Clear

-Range("D233").Clear

-Range("A233").Value = "xlMarkerStyleCircle"

-Range("B233").Value = 8

-Range("C233").Value = num

-B233 = Range("B233").Value

-C233 = Range("C233").Value

-If B233 = C233 Then

-Range("D233").Value = "OK"

-Else

-Range("D233").Value = "NG"

-End If

-End Function

-

-Function test_xlMarkerStyleDash(ByRef num)

-Range("A234").Clear

-Range("B234").Clear

-Range("C234").Clear

-Range("D234").Clear

-Range("A234").Value = "xlMarkerStyleDash"

-Range("B234").Value = -4115

-Range("C234").Value = num

-B234 = Range("B234").Value

-C234 = Range("C234").Value

-If B234 = C234 Then

-Range("D234").Value = "OK"

-Else

-Range("D234").Value = "NG"

-End If

-End Function

-

-Function test_xlMarkerStyleDiamond(ByRef num)

-Range("A235").Clear

-Range("B235").Clear

-Range("C235").Clear

-Range("D235").Clear

-Range("A235").Value = "xlMarkerStyleDiamond"

-Range("B235").Value = 2

-Range("C235").Value = num

-B235 = Range("B235").Value

-C235 = Range("C235").Value

-If B235 = C235 Then

-Range("D235").Value = "OK"

-Else

-Range("D235").Value = "NG"

-End If

-End Function

-

-Function test_xlMarkerStyleDot(ByRef num)

-Range("A236").Clear

-Range("B236").Clear

-Range("C236").Clear

-Range("D236").Clear

-Range("A236").Value = "xlMarkerStyleDot"

-Range("B236").Value = -4118

-Range("C236").Value = num

-B236 = Range("B236").Value

-C236 = Range("C236").Value

-If B236 = C236 Then

-Range("D236").Value = "OK"

-Else

-Range("D236").Value = "NG"

-End If

-End Function

-

-Function test_xlMarkerStyleNone(ByRef num)

-Range("A237").Clear

-Range("B237").Clear

-Range("C237").Clear

-Range("D237").Clear

-Range("A237").Value = "xlMarkerStyleNone"

-Range("B237").Value = -4142

-Range("C237").Value = num

-B237 = Range("B237").Value

-C237 = Range("C237").Value

-If B237 = C237 Then

-Range("D237").Value = "OK"

-Else

-Range("D237").Value = "NG"

-End If

-End Function

-

-Function test_xlMarkerStylePicture(ByRef num)

-Range("A238").Clear

-Range("B238").Clear

-Range("C238").Clear

-Range("D238").Clear

-Range("A238").Value = "xlMarkerStylePicture"

-Range("B238").Value = -4147

-Range("C238").Value = num

-B238 = Range("B238").Value

-C238 = Range("C238").Value

-If B238 = C238 Then

-Range("D238").Value = "OK"

-Else

-Range("D238").Value = "NG"

-End If

-End Function

-

-Function test_xlMarkerStylePlus(ByRef num)

-Range("A239").Clear

-Range("B239").Clear

-Range("C239").Clear

-Range("D239").Clear

-Range("A239").Value = "xlMarkerStylePlus"

-Range("B239").Value = 9

-Range("C239").Value = num

-B239 = Range("B239").Value

-C239 = Range("C239").Value

-If B239 = C239 Then

-Range("D239").Value = "OK"

-Else

-Range("D239").Value = "NG"

-End If

-End Function

-

-Function test_xlMarkerStyleSquare(ByRef num)

-Range("A240").Clear

-Range("B240").Clear

-Range("C240").Clear

-Range("D240").Clear

-Range("A240").Value = "xlMarkerStyleSquare"

-Range("B240").Value = 1

-Range("C240").Value = num

-B240 = Range("B240").Value

-C240 = Range("C240").Value

-If B240 = C240 Then

-Range("D240").Value = "OK"

-Else

-Range("D240").Value = "NG"

-End If

-End Function

-

-Function test_xlMarkerStyleStar(ByRef num)

-Range("A241").Clear

-Range("B241").Clear

-Range("C241").Clear

-Range("D241").Clear

-Range("A241").Value = "xlMarkerStyleStar"

-Range("B241").Value = 5

-Range("C241").Value = num

-B241 = Range("B241").Value

-C241 = Range("C241").Value

-If B241 = C241 Then

-Range("D241").Value = "OK"

-Else

-Range("D241").Value = "NG"

-End If

-End Function

-

-Function test_xlMarkerStyleTiangle(ByRef num)

-Range("A242").Clear

-Range("B242").Clear

-Range("C242").Clear

-Range("D242").Clear

-Range("A242").Value = "xlMarkerStyleTiangle"

-Range("B242").Value = 3

-Range("C242").Value = num

-B242 = Range("B242").Value

-C242 = Range("C242").Value

-If B242 = C242 Then

-Range("D242").Value = "OK"

-Else

-Range("D242").Value = "NG"

-End If

-End Function

-

-Function test_xlMarkerStyleX(ByRef num)

-Range("A243").Clear

-Range("B243").Clear

-Range("C243").Clear

-Range("D243").Clear

-Range("A243").Value = "xlMarkerStyleX"

-Range("B243").Value = -4168

-Range("C243").Value = num

-B243 = Range("B243").Value

-C243 = Range("C243").Value

-If B243 = C243 Then

-Range("D243").Value = "OK"

-Else

-Range("D243").Value = "NG"

-End If

-End Function

-

-Function test_xlNoButton(ByRef num)

-Range("A244").Clear

-Range("B244").Clear

-Range("C244").Clear

-Range("D244").Clear

-Range("A244").Value = "xlNoButton"

-Range("B244").Value = 0

-Range("C244").Value = num

-B244 = Range("B244").Value

-C244 = Range("C244").Value

-If B244 = C244 Then

-Range("D244").Value = "OK"

-Else

-Range("D244").Value = "NG"

-End If

-End Function

-

-Function test_xlPrimaryButton(ByRef num)

-Range("A245").Clear

-Range("B245").Clear

-Range("C245").Clear

-Range("D245").Clear

-Range("A245").Value = "xlPrimaryButton"

-Range("B245").Value = 1

-Range("C245").Value = num

-B245 = Range("B245").Value

-C245 = Range("C245").Value

-If B245 = C245 Then

-Range("D245").Value = "OK"

-Else

-Range("D245").Value = "NG"

-End If

-End Function

-

-Function test_xlSecondaryButton(ByRef num)

-Range("A246").Clear

-Range("B246").Clear

-Range("C246").Clear

-Range("D246").Clear

-Range("A246").Value = "xlSecondaryButton"

-Range("B246").Value = 2

-Range("C246").Value = num

-B246 = Range("B246").Value

-C246 = Range("C246").Value

-If B246 = C246 Then

-Range("D246").Value = "OK"

-Else

-Range("D246").Value = "NG"

-End If

-End Function

-

-Function test_xlDefault(ByRef num)

-Range("A247").Clear

-Range("B247").Clear

-Range("C247").Clear

-Range("D247").Clear

-Range("A247").Value = "xlDefault"

-Range("B247").Value = -4143

-Range("C247").Value = num

-B247 = Range("B247").Value

-C247 = Range("C247").Value

-If B247 = C247 Then

-Range("D247").Value = "OK"

-Else

-Range("D247").Value = "NG"

-End If

-End Function

-

-Function test_xlIBeam(ByRef num)

-Range("A248").Clear

-Range("B248").Clear

-Range("C248").Clear

-Range("D248").Clear

-Range("A248").Value = "xlIBeam"

-Range("B248").Value = 3

-Range("C248").Value = num

-B248 = Range("B248").Value

-C248 = Range("C248").Value

-If B248 = C248 Then

-Range("D248").Value = "OK"

-Else

-Range("D248").Value = "NG"

-End If

-End Function

-

-Function test_xlNorthwestArrow(ByRef num)

-Range("A249").Clear

-Range("B249").Clear

-Range("C249").Clear

-Range("D249").Clear

-Range("A249").Value = "xlNorthwestArrow"

-Range("B249").Value = 1

-Range("C249").Value = num

-B249 = Range("B249").Value

-C249 = Range("C249").Value

-If B249 = C249 Then

-Range("D249").Value = "OK"

-Else

-Range("D249").Value = "NG"

-End If

-End Function

-

-Function test_xlWait(ByRef num)

-Range("A250").Clear

-Range("B250").Clear

-Range("C250").Clear

-Range("D250").Clear

-Range("A250").Value = "xlWait"

-Range("B250").Value = 2

-Range("C250").Value = num

-B250 = Range("B250").Value

-C250 = Range("C250").Value

-If B250 = C250 Then

-Range("D250").Value = "OK"

-Else

-Range("D250").Value = "NG"

-End If

-End Function

-

-Function test_XlOLEControl(ByRef num)

-Range("A251").Clear

-Range("B251").Clear

-Range("C251").Clear

-Range("D251").Clear

-Range("A251").Value = "XlOLEControl"

-Range("B251").Value = 2

-Range("C251").Value = num

-B251 = Range("B251").Value

-C251 = Range("C251").Value

-If B251 = C251 Then

-Range("D251").Value = "OK"

-Else

-Range("D251").Value = "NG"

-End If

-End Function

-

-Function test_XlOLEEmbed(ByRef num)

-Range("A252").Clear

-Range("B252").Clear

-Range("C252").Clear

-Range("D252").Clear

-Range("A252").Value = "XlOLEEmbed"

-Range("B252").Value = 1

-Range("C252").Value = num

-B252 = Range("B252").Value

-C252 = Range("C252").Value

-If B252 = C252 Then

-Range("D252").Value = "OK"

-Else

-Range("D252").Value = "NG"

-End If

-End Function

-

-

-

-Function test_XlVerbOpen(ByRef num)

-Range("A254").Clear

-Range("B254").Clear

-Range("C254").Clear

-Range("D254").Clear

-Range("A254").Value = "XlVerbOpen"

-Range("B254").Value = 2

-Range("C254").Value = num

-B254 = Range("B254").Value

-C254 = Range("C254").Value

-If B254 = C254 Then

-Range("D254").Value = "OK"

-Else

-Range("D254").Value = "NG"

-End If

-End Function

-

-Function test_XlVerbPrimary(ByRef num)

-Range("A255").Clear

-Range("B255").Clear

-Range("C255").Clear

-Range("D255").Clear

-Range("A255").Value = "XlVerbPrimary"

-Range("B255").Value = 1

-Range("C255").Value = num

-B255 = Range("B255").Value

-C255 = Range("C255").Value

-If B255 = C255 Then

-Range("D255").Value = "OK"

-Else

-Range("D255").Value = "NG"

-End If

-End Function

-

-Function test_xlFitToPage(ByRef num)

-Range("A256").Clear

-Range("B256").Clear

-Range("C256").Clear

-Range("D256").Clear

-Range("A256").Value = "xlFitToPage"

-Range("B256").Value = 2

-Range("C256").Value = num

-B256 = Range("B256").Value

-C256 = Range("C256").Value

-If B256 = C256 Then

-Range("D256").Value = "OK"

-Else

-Range("D256").Value = "NG"

-End If

-End Function

-

-Function test_xlFullPage(ByRef num)

-Range("A257").Clear

-Range("B257").Clear

-Range("C257").Clear

-Range("D257").Clear

-Range("A257").Value = "xlFullPage"

-Range("B257").Value = 3

-Range("C257").Value = num

-B257 = Range("B257").Value

-C257 = Range("C257").Value

-If B257 = C257 Then

-Range("D257").Value = "OK"

-Else

-Range("D257").Value = "NG"

-End If

-End Function

-

-Function test_xlScreenSize(ByRef num)

-Range("A258").Clear

-Range("B258").Clear

-Range("C258").Clear

-Range("D258").Clear

-Range("A258").Value = "xlScreenSize"

-Range("B258").Value = 1

-Range("C258").Value = num

-B258 = Range("B258").Value

-C258 = Range("C258").Value

-If B258 = C258 Then

-Range("D258").Value = "OK"

-Else

-Range("D258").Value = "NG"

-End If

-End Function

-

-Function test_xlDownThenOver(ByRef num)

-Range("A259").Clear

-Range("B259").Clear

-Range("C259").Clear

-Range("D259").Clear

-Range("A259").Value = "xlDownThenOver"

-Range("B259").Value = 1

-Range("C259").Value = num

-B259 = Range("B259").Value

-C259 = Range("C259").Value

-If B259 = C259 Then

-Range("D259").Value = "OK"

-Else

-Range("D259").Value = "NG"

-End If

-End Function

-

-Function test_xlOverThenDown(ByRef num)

-Range("A260").Clear

-Range("B260").Clear

-Range("C260").Clear

-Range("D260").Clear

-Range("A260").Value = "xlOverThenDown"

-Range("B260").Value = 2

-Range("C260").Value = num

-B260 = Range("B260").Value

-C260 = Range("C260").Value

-If B260 = C260 Then

-Range("D260").Value = "OK"

-Else

-Range("D260").Value = "NG"

-End If

-End Function

-

-Function test_xlDownward(ByRef num)

-Range("A261").Clear

-Range("B261").Clear

-Range("C261").Clear

-Range("D261").Clear

-Range("A261").Value = "xlDownward"

-Range("B261").Value = -4170

-Range("C261").Value = num

-B261 = Range("B261").Value

-C261 = Range("C261").Value

-If B261 = C261 Then

-Range("D261").Value = "OK"

-Else

-Range("D261").Value = "NG"

-End If

-End Function

-

-Function test_xlHorizontal(ByRef num)

-Range("A262").Clear

-Range("B262").Clear

-Range("C262").Clear

-Range("D262").Clear

-Range("A262").Value = "xlHorizontal"

-Range("B262").Value = -4128

-Range("C262").Value = num

-B262 = Range("B262").Value

-C262 = Range("C262").Value

-If B262 = C262 Then

-Range("D262").Value = "OK"

-Else

-Range("D262").Value = "NG"

-End If

-End Function

-

-Function test_xlUpward(ByRef num)

-Range("A263").Clear

-Range("B263").Clear

-Range("C263").Clear

-Range("D263").Clear

-Range("A263").Value = "xlUpward"

-Range("B263").Value = -4171

-Range("C263").Value = num

-B263 = Range("B263").Value

-C263 = Range("C263").Value

-If B263 = C263 Then

-Range("D263").Value = "OK"

-Else

-Range("D263").Value = "NG"

-End If

-End Function

-

-Function test_xlVertical(ByRef num)

-Range("A264").Clear

-Range("B264").Clear

-Range("C264").Clear

-Range("D264").Clear

-Range("A264").Value = "xlVertical"

-Range("B264").Value = -4166

-Range("C264").Value = num

-B264 = Range("B264").Value

-C264 = Range("C264").Value

-If B264 = C264 Then

-Range("D264").Value = "OK"

-Else

-Range("D264").Value = "NG"

-End If

-End Function

-

-Function test_xlBlanks(ByRef num)

-Range("A265").Clear

-Range("B265").Clear

-Range("C265").Clear

-Range("D265").Clear

-Range("A265").Value = "xlBlanks"

-Range("B265").Value = 4

-Range("C265").Value = num

-B265 = Range("B265").Value

-C265 = Range("C265").Value

-If B265 = C265 Then

-Range("D265").Value = "OK"

-Else

-Range("D265").Value = "NG"

-End If

-End Function

-

-Function test_xlButton(ByRef num)

-Range("A266").Clear

-Range("B266").Clear

-Range("C266").Clear

-Range("D266").Clear

-Range("A266").Value = "xlButton"

-Range("B266").Value = 15

-Range("C266").Value = num

-B266 = Range("B266").Value

-C266 = Range("C266").Value

-If B266 = C266 Then

-Range("D266").Value = "OK"

-Else

-Range("D266").Value = "NG"

-End If

-End Function

-

-Function test_xlDataAndLabel(ByRef num)

-Range("A267").Clear

-Range("B267").Clear

-Range("C267").Clear

-Range("D267").Clear

-Range("A267").Value = "xlDataAndLabel"

-Range("B267").Value = 0

-Range("C267").Value = num

-B267 = Range("B267").Value

-C267 = Range("C267").Value

-If B267 = C267 Then

-Range("D267").Value = "OK"

-Else

-Range("D267").Value = "NG"

-End If

-End Function

-

-Function test_xlDataOnly(ByRef num)

-Range("A268").Clear

-Range("B268").Clear

-Range("C268").Clear

-Range("D268").Clear

-Range("A268").Value = "xlDataOnly"

-Range("B268").Value = 2

-Range("C268").Value = num

-B268 = Range("B268").Value

-C268 = Range("C268").Value

-If B268 = C268 Then

-Range("D268").Value = "OK"

-Else

-Range("D268").Value = "NG"

-End If

-End Function

-

-Function test_xlFirstRow(ByRef num)

-Range("A269").Clear

-Range("B269").Clear

-Range("C269").Clear

-Range("D269").Clear

-Range("A269").Value = "xlFirstRow"

-Range("B269").Value = 256

-Range("C269").Value = num

-B269 = Range("B269").Value

-C269 = Range("C269").Value

-If B269 = C269 Then

-Range("D269").Value = "OK"

-Else

-Range("D269").Value = "NG"

-End If

-End Function

-

-Function test_xlLabelOnly(ByRef num)

-Range("A270").Clear

-Range("B270").Clear

-Range("C270").Clear

-Range("D270").Clear

-Range("A270").Value = "xlLabelOnly"

-Range("B270").Value = 1

-Range("C270").Value = num

-B270 = Range("B270").Value

-C270 = Range("C270").Value

-If B270 = C270 Then

-Range("D270").Value = "OK"

-Else

-Range("D270").Value = "NG"

-End If

-End Function

-

-Function test_xlOrigin(ByRef num)

-Range("A271").Clear

-Range("B271").Clear

-Range("C271").Clear

-Range("D271").Clear

-Range("A271").Value = "xlOrigin"

-Range("B271").Value = 3

-Range("C271").Value = num

-B271 = Range("B271").Value

-C271 = Range("C271").Value

-If B271 = C271 Then

-Range("D271").Value = "OK"

-Else

-Range("D271").Value = "NG"

-End If

-End Function

-

-Function test_XlPageBreakAutomatic(ByRef num)

-Range("A272").Clear

-Range("B272").Clear

-Range("C272").Clear

-Range("D272").Clear

-Range("A272").Value = "XlPageBreakAutomatic"

-Range("B272").Value = -4105

-Range("C272").Value = num

-B272 = Range("B272").Value

-C272 = Range("C272").Value

-If B272 = C272 Then

-Range("D272").Value = "OK"

-Else

-Range("D272").Value = "NG"

-End If

-End Function

-

-Function test_XlPageBreakManual(ByRef num)

-Range("A273").Clear

-Range("B273").Clear

-Range("C273").Clear

-Range("D273").Clear

-Range("A273").Value = "XlPageBreakManual"

-Range("B273").Value = -4135

-Range("C273").Value = num

-B273 = Range("B273").Value

-C273 = Range("C273").Value

-If B273 = C273 Then

-Range("D273").Value = "OK"

-Else

-Range("D273").Value = "NG"

-End If

-End Function

-

-Function test_XlPageBreakNone(ByRef num)

-Range("A274").Clear

-Range("B274").Clear

-Range("C274").Clear

-Range("D274").Clear

-Range("A274").Value = "XlPageBreakNone"

-Range("B274").Value = -4142

-Range("C274").Value = num

-B274 = Range("B274").Value

-C274 = Range("C274").Value

-If B274 = C274 Then

-Range("D274").Value = "OK"

-Else

-Range("D274").Value = "NG"

-End If

-End Function

-

-Function test_xlPageBreakFull(ByRef num)

-Range("A275").Clear

-Range("B275").Clear

-Range("C275").Clear

-Range("D275").Clear

-Range("A275").Value = "xlPageBreakFull"

-Range("B275").Value = 1

-Range("C275").Value = num

-B275 = Range("B275").Value

-C275 = Range("C275").Value

-If B275 = C275 Then

-Range("D275").Value = "OK"

-Else

-Range("D275").Value = "NG"

-End If

-End Function

-

-Function test_xlPageBreakPartial(ByRef num)

-Range("A276").Clear

-Range("B276").Clear

-Range("C276").Clear

-Range("D276").Clear

-Range("A276").Value = "xlPageBreakPartial"

-Range("B276").Value = 2

-Range("C276").Value = num

-B276 = Range("B276").Value

-C276 = Range("C276").Value

-If B276 = C276 Then

-Range("D276").Value = "OK"

-Else

-Range("D276").Value = "NG"

-End If

-End Function

-

-Function test_xlLandscape(ByRef num)

-Range("A277").Clear

-Range("B277").Clear

-Range("C277").Clear

-Range("D277").Clear

-Range("A277").Value = "xlLandscape"

-Range("B277").Value = 2

-Range("C277").Value = num

-B277 = Range("B277").Value

-C277 = Range("C277").Value

-If B277 = C277 Then

-Range("D277").Value = "OK"

-Else

-Range("D277").Value = "NG"

-End If

-End Function

-

-Function test_xlPortrait(ByRef num)

-Range("A278").Clear

-Range("B278").Clear

-Range("C278").Clear

-Range("D278").Clear

-Range("A278").Value = "xlPortrait"

-Range("B278").Value = 1

-Range("C278").Value = num

-B278 = Range("B278").Value

-C278 = Range("C278").Value

-If B278 = C278 Then

-Range("D278").Value = "OK"

-Else

-Range("D278").Value = "NG"

-End If

-End Function

-

-Function test_xlPaper10x14(ByRef num)

-Range("A279").Clear

-Range("B279").Clear

-Range("C279").Clear

-Range("D279").Clear

-Range("A279").Value = "xlPaper10x14"

-Range("B279").Value = 16

-Range("C279").Value = num

-B279 = Range("B279").Value

-C279 = Range("C279").Value

-If B279 = C279 Then

-Range("D279").Value = "OK"

-Else

-Range("D279").Value = "NG"

-End If

-End Function

-

-Function test_xlPaper11x17(ByRef num)

-Range("A280").Clear

-Range("B280").Clear

-Range("C280").Clear

-Range("D280").Clear

-Range("A280").Value = "xlPaper11x17"

-Range("B280").Value = 17

-Range("C280").Value = num

-B280 = Range("B280").Value

-C280 = Range("C280").Value

-If B280 = C280 Then

-Range("D280").Value = "OK"

-Else

-Range("D280").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperA3(ByRef num)

-Range("A281").Clear

-Range("B281").Clear

-Range("C281").Clear

-Range("D281").Clear

-Range("A281").Value = "xlPaperA3"

-Range("B281").Value = 8

-Range("C281").Value = num

-B281 = Range("B281").Value

-C281 = Range("C281").Value

-If B281 = C281 Then

-Range("D281").Value = "OK"

-Else

-Range("D281").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperA4Small(ByRef num)

-Range("A282").Clear

-Range("B282").Clear

-Range("C282").Clear

-Range("D282").Clear

-Range("A282").Value = "xlPaperA4Small"

-Range("B282").Value = 9

-Range("C282").Value = num

-B282 = Range("B282").Value

-C282 = Range("C282").Value

-If B282 = C282 Then

-Range("D282").Value = "OK"

-Else

-Range("D282").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperA5(ByRef num)

-Range("A283").Clear

-Range("B283").Clear

-Range("C283").Clear

-Range("D283").Clear

-Range("A283").Value = "xlPaperA5"

-Range("B283").Value = 10

-Range("C283").Value = num

-B283 = Range("B283").Value

-C283 = Range("C283").Value

-If B283 = C283 Then

-Range("D283").Value = "OK"

-Else

-Range("D283").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperB4(ByRef num)

-Range("A284").Clear

-Range("B284").Clear

-Range("C284").Clear

-Range("D284").Clear

-Range("A284").Value = "xlPaperB4"

-Range("B284").Value = 12

-Range("C284").Value = num

-B284 = Range("B284").Value

-C284 = Range("C284").Value

-If B284 = C284 Then

-Range("D284").Value = "OK"

-Else

-Range("D284").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperB5(ByRef num)

-Range("A285").Clear

-Range("B285").Clear

-Range("C285").Clear

-Range("D285").Clear

-Range("A285").Value = "xlPaperB5"

-Range("B285").Value = 13

-Range("C285").Value = num

-B285 = Range("B285").Value

-C285 = Range("C285").Value

-If B285 = C285 Then

-Range("D285").Value = "OK"

-Else

-Range("D285").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperCsheet(ByRef num)

-Range("A286").Clear

-Range("B286").Clear

-Range("C286").Clear

-Range("D286").Clear

-Range("A286").Value = "xlPaperCsheet"

-Range("B286").Value = 24

-Range("C286").Value = num

-B286 = Range("B286").Value

-C286 = Range("C286").Value

-If B286 = C286 Then

-Range("D286").Value = "OK"

-Else

-Range("D286").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperDsheet(ByRef num)

-Range("A287").Clear

-Range("B287").Clear

-Range("C287").Clear

-Range("D287").Clear

-Range("A287").Value = "xlPaperDsheet"

-Range("B287").Value = 25

-Range("C287").Value = num

-B287 = Range("B287").Value

-C287 = Range("C287").Value

-If B287 = C287 Then

-Range("D287").Value = "OK"

-Else

-Range("D287").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelope10(ByRef num)

-Range("A288").Clear

-Range("B288").Clear

-Range("C288").Clear

-Range("D288").Clear

-Range("A288").Value = "xlPaperEnvelope10"

-Range("B288").Value = 20

-Range("C288").Value = num

-B288 = Range("B288").Value

-C288 = Range("C288").Value

-If B288 = C288 Then

-Range("D288").Value = "OK"

-Else

-Range("D288").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelope11(ByRef num)

-Range("A289").Clear

-Range("B289").Clear

-Range("C289").Clear

-Range("D289").Clear

-Range("A289").Value = "xlPaperEnvelope11"

-Range("B289").Value = 21

-Range("C289").Value = num

-B289 = Range("B289").Value

-C289 = Range("C289").Value

-If B289 = C289 Then

-Range("D289").Value = "OK"

-Else

-Range("D289").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelope12(ByRef num)

-Range("A290").Clear

-Range("B290").Clear

-Range("C290").Clear

-Range("D290").Clear

-Range("A290").Value = "xlPaperEnvelope12"

-Range("B290").Value = 22

-Range("C290").Value = num

-B290 = Range("B290").Value

-C290 = Range("C290").Value

-If B290 = C290 Then

-Range("D290").Value = "OK"

-Else

-Range("D290").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelope14(ByRef num)

-Range("A291").Clear

-Range("B291").Clear

-Range("C291").Clear

-Range("D291").Clear

-Range("A291").Value = "xlPaperEnvelope14"

-Range("B291").Value = 23

-Range("C291").Value = num

-B291 = Range("B291").Value

-C291 = Range("C291").Value

-If B291 = C291 Then

-Range("D291").Value = "OK"

-Else

-Range("D291").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelope9(ByRef num)

-Range("A292").Clear

-Range("B292").Clear

-Range("C292").Clear

-Range("D292").Clear

-Range("A292").Value = "xlPaperEnvelope9"

-Range("B292").Value = 19

-Range("C292").Value = num

-B292 = Range("B292").Value

-C292 = Range("C292").Value

-If B292 = C292 Then

-Range("D292").Value = "OK"

-Else

-Range("D292").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelopeB4(ByRef num)

-Range("A293").Clear

-Range("B293").Clear

-Range("C293").Clear

-Range("D293").Clear

-Range("A293").Value = "xlPaperEnvelopeB4"

-Range("B293").Value = 33

-Range("C293").Value = num

-B293 = Range("B293").Value

-C293 = Range("C293").Value

-If B293 = C293 Then

-Range("D293").Value = "OK"

-Else

-Range("D293").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelopeB5(ByRef num)

-Range("A294").Clear

-Range("B294").Clear

-Range("C294").Clear

-Range("D294").Clear

-Range("A294").Value = "xlPaperEnvelopeB5"

-Range("B294").Value = 34

-Range("C294").Value = num

-B294 = Range("B294").Value

-C294 = Range("C294").Value

-If B294 = C294 Then

-Range("D294").Value = "OK"

-Else

-Range("D294").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelopeB6(ByRef num)

-Range("A295").Clear

-Range("B295").Clear

-Range("C295").Clear

-Range("D295").Clear

-Range("A295").Value = "xlPaperEnvelopeB6"

-Range("B295").Value = 35

-Range("C295").Value = num

-B295 = Range("B295").Value

-C295 = Range("C295").Value

-If B295 = C295 Then

-Range("D295").Value = "OK"

-Else

-Range("D295").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelopeC3(ByRef num)

-Range("A296").Clear

-Range("B296").Clear

-Range("C296").Clear

-Range("D296").Clear

-Range("A296").Value = "xlPaperEnvelopeC3"

-Range("B296").Value = 29

-Range("C296").Value = num

-B296 = Range("B296").Value

-C296 = Range("C296").Value

-If B296 = C296 Then

-Range("D296").Value = "OK"

-Else

-Range("D296").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelopeC4(ByRef num)

-Range("A297").Clear

-Range("B297").Clear

-Range("C297").Clear

-Range("D297").Clear

-Range("A297").Value = "xlPaperEnvelopeC4"

-Range("B297").Value = 30

-Range("C297").Value = num

-B297 = Range("B297").Value

-C297 = Range("C297").Value

-If B297 = C297 Then

-Range("D297").Value = "OK"

-Else

-Range("D297").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelopeC5(ByRef num)

-Range("A298").Clear

-Range("B298").Clear

-Range("C298").Clear

-Range("D298").Clear

-Range("A298").Value = "xlPaperEnvelopeC5"

-Range("B298").Value = 28

-Range("C298").Value = num

-B298 = Range("B298").Value

-C298 = Range("C298").Value

-If B298 = C298 Then

-Range("D298").Value = "OK"

-Else

-Range("D298").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelopeC6(ByRef num)

-Range("A299").Clear

-Range("B299").Clear

-Range("C299").Clear

-Range("D299").Clear

-Range("A299").Value = "xlPaperEnvelopeC6"

-Range("B299").Value = 31

-Range("C299").Value = num

-B299 = Range("B299").Value

-C299 = Range("C299").Value

-If B299 = C299 Then

-Range("D299").Value = "OK"

-Else

-Range("D299").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelopeC65(ByRef num)

-Range("A300").Clear

-Range("B300").Clear

-Range("C300").Clear

-Range("D300").Clear

-Range("A300").Value = "xlPaperEnvelopeC65"

-Range("B300").Value = 32

-Range("C300").Value = num

-B300 = Range("B300").Value

-C300 = Range("C300").Value

-If B300 = C300 Then

-Range("D300").Value = "OK"

-Else

-Range("D300").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelopeDL(ByRef num)

-Range("A301").Clear

-Range("B301").Clear

-Range("C301").Clear

-Range("D301").Clear

-Range("A301").Value = "xlPaperEnvelopeDL"

-Range("B301").Value = 27

-Range("C301").Value = num

-B301 = Range("B301").Value

-C301 = Range("C301").Value

-If B301 = C301 Then

-Range("D301").Value = "OK"

-Else

-Range("D301").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelopeItaly(ByRef num)

-Range("A302").Clear

-Range("B302").Clear

-Range("C302").Clear

-Range("D302").Clear

-Range("A302").Value = "xlPaperEnvelopeItaly"

-Range("B302").Value = 36

-Range("C302").Value = num

-B302 = Range("B302").Value

-C302 = Range("C302").Value

-If B302 = C302 Then

-Range("D302").Value = "OK"

-Else

-Range("D302").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelopeMonarch(ByRef num)

-Range("A303").Clear

-Range("B303").Clear

-Range("C303").Clear

-Range("D303").Clear

-Range("A303").Value = "xlPaperEnvelopeMonarch"

-Range("B303").Value = 37

-Range("C303").Value = num

-B303 = Range("B303").Value

-C303 = Range("C303").Value

-If B303 = C303 Then

-Range("D303").Value = "OK"

-Else

-Range("D303").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelopePersonal(ByRef num)

-Range("A304").Clear

-Range("B304").Clear

-Range("C304").Clear

-Range("D304").Clear

-Range("A304").Value = "xlPaperEnvelopePersonal"

-Range("B304").Value = 38

-Range("C304").Value = num

-B304 = Range("B304").Value

-C304 = Range("C304").Value

-If B304 = C304 Then

-Range("D304").Value = "OK"

-Else

-Range("D304").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEsheet(ByRef num)

-Range("A305").Clear

-Range("B305").Clear

-Range("C305").Clear

-Range("D305").Clear

-Range("A305").Value = "xlPaperEsheet"

-Range("B305").Value = 26

-Range("C305").Value = num

-B305 = Range("B305").Value

-C305 = Range("C305").Value

-If B305 = C305 Then

-Range("D305").Value = "OK"

-Else

-Range("D305").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperExective(ByRef num)

-Range("A306").Clear

-Range("B306").Clear

-Range("C306").Clear

-Range("D306").Clear

-Range("A306").Value = "xlPaperExective"

-Range("B306").Value = 7

-Range("C306").Value = num

-B306 = Range("B306").Value

-C306 = Range("C306").Value

-If B306 = C306 Then

-Range("D306").Value = "OK"

-Else

-Range("D306").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperFanfoldLegalGerman(ByRef num)

-Range("A307").Clear

-Range("B307").Clear

-Range("C307").Clear

-Range("D307").Clear

-Range("A307").Value = "xlPaperFanfoldLegalGerman"

-Range("B307").Value = 41

-Range("C307").Value = num

-B307 = Range("B307").Value

-C307 = Range("C307").Value

-If B307 = C307 Then

-Range("D307").Value = "OK"

-Else

-Range("D307").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperFanfoldStdGerman(ByRef num)

-Range("A308").Clear

-Range("B308").Clear

-Range("C308").Clear

-Range("D308").Clear

-Range("A308").Value = "xlPaperFanfoldStdGerman"

-Range("B308").Value = 40

-Range("C308").Value = num

-B308 = Range("B308").Value

-C308 = Range("C308").Value

-If B308 = C308 Then

-Range("D308").Value = "OK"

-Else

-Range("D308").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperFanfoldUS(ByRef num)

-Range("A309").Clear

-Range("B309").Clear

-Range("C309").Clear

-Range("D309").Clear

-Range("A309").Value = "xlPaperFanfoldUS"

-Range("B309").Value = 39

-Range("C309").Value = num

-B309 = Range("B309").Value

-C309 = Range("C309").Value

-If B309 = C309 Then

-Range("D309").Value = "OK"

-Else

-Range("D309").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperFolio(ByRef num)

-Range("A310").Clear

-Range("B310").Clear

-Range("C310").Clear

-Range("D310").Clear

-Range("A310").Value = "xlPaperFolio"

-Range("B310").Value = 14

-Range("C310").Value = num

-B310 = Range("B310").Value

-C310 = Range("C310").Value

-If B310 = C310 Then

-Range("D310").Value = "OK"

-Else

-Range("D310").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperLedger(ByRef num)

-Range("A311").Clear

-Range("B311").Clear

-Range("C311").Clear

-Range("D311").Clear

-Range("A311").Value = "xlPaperLedger"

-Range("B311").Value = 4

-Range("C311").Value = num

-B311 = Range("B311").Value

-C311 = Range("C311").Value

-If B311 = C311 Then

-Range("D311").Value = "OK"

-Else

-Range("D311").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperLegal(ByRef num)

-Range("A312").Clear

-Range("B312").Clear

-Range("C312").Clear

-Range("D312").Clear

-Range("A312").Value = "xlPaperLegal"

-Range("B312").Value = 5

-Range("C312").Value = num

-B312 = Range("B312").Value

-C312 = Range("C312").Value

-If B312 = C312 Then

-Range("D312").Value = "OK"

-Else

-Range("D312").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperLetter(ByRef num)

-Range("A313").Clear

-Range("B313").Clear

-Range("C313").Clear

-Range("D313").Clear

-Range("A313").Value = "xlPaperLetter"

-Range("B313").Value = 1

-Range("C313").Value = num

-B313 = Range("B313").Value

-C313 = Range("C313").Value

-If B313 = C313 Then

-Range("D313").Value = "OK"

-Else

-Range("D313").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperLetterSmall(ByRef num)

-Range("A314").Clear

-Range("B314").Clear

-Range("C314").Clear

-Range("D314").Clear

-Range("A314").Value = "xlPaperLetterSmall"

-Range("B314").Value = 2

-Range("C314").Value = num

-B314 = Range("B314").Value

-C314 = Range("C314").Value

-If B314 = C314 Then

-Range("D314").Value = "OK"

-Else

-Range("D314").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperNote(ByRef num)

-Range("A315").Clear

-Range("B315").Clear

-Range("C315").Clear

-Range("D315").Clear

-Range("A315").Value = "xlPaperNote"

-Range("B315").Value = 18

-Range("C315").Value = num

-B315 = Range("B315").Value

-C315 = Range("C315").Value

-If B315 = C315 Then

-Range("D315").Value = "OK"

-Else

-Range("D315").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperQuarto(ByRef num)

-Range("A316").Clear

-Range("B316").Clear

-Range("C316").Clear

-Range("D316").Clear

-Range("A316").Value = "xlPaperQuarto"

-Range("B316").Value = 15

-Range("C316").Value = num

-B316 = Range("B316").Value

-C316 = Range("C316").Value

-If B316 = C316 Then

-Range("D316").Value = "OK"

-Else

-Range("D316").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperStatement(ByRef num)

-Range("A317").Clear

-Range("B317").Clear

-Range("C317").Clear

-Range("D317").Clear

-Range("A317").Value = "xlPaperStatement"

-Range("B317").Value = 6

-Range("C317").Value = num

-B317 = Range("B317").Value

-C317 = Range("C317").Value

-If B317 = C317 Then

-Range("D317").Value = "OK"

-Else

-Range("D317").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperTabloid(ByRef num)

-Range("A318").Clear

-Range("B318").Clear

-Range("C318").Clear

-Range("D318").Clear

-Range("A318").Value = "xlPaperTabloid"

-Range("B318").Value = 3

-Range("C318").Value = num

-B318 = Range("B318").Value

-C318 = Range("C318").Value

-If B318 = C318 Then

-Range("D318").Value = "OK"

-Else

-Range("D318").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperUser(ByRef num)

-Range("A319").Clear

-Range("B319").Clear

-Range("C319").Clear

-Range("D319").Clear

-Range("A319").Value = "xlPaperUser"

-Range("B319").Value = 256

-Range("C319").Value = num

-B319 = Range("B319").Value

-C319 = Range("C319").Value

-If B319 = C319 Then

-Range("D319").Value = "OK"

-Else

-Range("D319").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeBigInt(ByRef num)

-Range("A320").Clear

-Range("B320").Clear

-Range("C320").Clear

-Range("D320").Clear

-Range("A320").Value = "xlParameterTypeBigInt"

-Range("B320").Value = -5

-Range("C320").Value = num

-B320 = Range("B320").Value

-C320 = Range("C320").Value

-If B320 = C320 Then

-Range("D320").Value = "OK"

-Else

-Range("D320").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeBinary(ByRef num)

-Range("A321").Clear

-Range("B321").Clear

-Range("C321").Clear

-Range("D321").Clear

-Range("A321").Value = "xlParameterTypeBinary"

-Range("B321").Value = -2

-Range("C321").Value = num

-B321 = Range("B321").Value

-C321 = Range("C321").Value

-If B321 = C321 Then

-Range("D321").Value = "OK"

-Else

-Range("D321").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeBit(ByRef num)

-Range("A322").Clear

-Range("B322").Clear

-Range("C322").Clear

-Range("D322").Clear

-Range("A322").Value = "xlParameterTypeBit"

-Range("B322").Value = -7

-Range("C322").Value = num

-B322 = Range("B322").Value

-C322 = Range("C322").Value

-If B322 = C322 Then

-Range("D322").Value = "OK"

-Else

-Range("D322").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeChar(ByRef num)

-Range("A323").Clear

-Range("B323").Clear

-Range("C323").Clear

-Range("D323").Clear

-Range("A323").Value = "xlParameterTypeChar"

-Range("B323").Value = 1

-Range("C323").Value = num

-B323 = Range("B323").Value

-C323 = Range("C323").Value

-If B323 = C323 Then

-Range("D323").Value = "OK"

-Else

-Range("D323").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeData(ByRef num)

-Range("A324").Clear

-Range("B324").Clear

-Range("C324").Clear

-Range("D324").Clear

-Range("A324").Value = "xlParameterTypeData"

-Range("B324").Value = 9

-Range("C324").Value = num

-B324 = Range("B324").Value

-C324 = Range("C324").Value

-If B324 = C324 Then

-Range("D324").Value = "OK"

-Else

-Range("D324").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeDecimal(ByRef num)

-Range("A325").Clear

-Range("B325").Clear

-Range("C325").Clear

-Range("D325").Clear

-Range("A325").Value = "xlParameterTypeDecimal"

-Range("B325").Value = 3

-Range("C325").Value = num

-B325 = Range("B325").Value

-C325 = Range("C325").Value

-If B325 = C325 Then

-Range("D325").Value = "OK"

-Else

-Range("D325").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeDouble(ByRef num)

-Range("A326").Clear

-Range("B326").Clear

-Range("C326").Clear

-Range("D326").Clear

-Range("A326").Value = "xlParameterTypeDouble"

-Range("B326").Value = 8

-Range("C326").Value = num

-B326 = Range("B326").Value

-C326 = Range("C326").Value

-If B326 = C326 Then

-Range("D326").Value = "OK"

-Else

-Range("D326").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeFloat(ByRef num)

-Range("A327").Clear

-Range("B327").Clear

-Range("C327").Clear

-Range("D327").Clear

-Range("A327").Value = "xlParameterTypeFloat"

-Range("B327").Value = 6

-Range("C327").Value = num

-B327 = Range("B327").Value

-C327 = Range("C327").Value

-If B327 = C327 Then

-Range("D327").Value = "OK"

-Else

-Range("D327").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeInteger(ByRef num)

-Range("A328").Clear

-Range("B328").Clear

-Range("C328").Clear

-Range("D328").Clear

-Range("A328").Value = "xlParameterTypeInteger"

-Range("B328").Value = 4

-Range("C328").Value = num

-B328 = Range("B328").Value

-C328 = Range("C328").Value

-If B328 = C328 Then

-Range("D328").Value = "OK"

-Else

-Range("D328").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeLongVarBinary(ByRef num)

-Range("A329").Clear

-Range("B329").Clear

-Range("C329").Clear

-Range("D329").Clear

-Range("A329").Value = "xlParameterTypeLongVarBinary"

-Range("B329").Value = -4

-Range("C329").Value = num

-B329 = Range("B329").Value

-C329 = Range("C329").Value

-If B329 = C329 Then

-Range("D329").Value = "OK"

-Else

-Range("D329").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeLongVarChar(ByRef num)

-Range("A330").Clear

-Range("B330").Clear

-Range("C330").Clear

-Range("D330").Clear

-Range("A330").Value = "xlParameterTypeLongVarChar"

-Range("B330").Value = -1

-Range("C330").Value = num

-B330 = Range("B330").Value

-C330 = Range("C330").Value

-If B330 = C330 Then

-Range("D330").Value = "OK"

-Else

-Range("D330").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeNumeric(ByRef num)

-Range("A331").Clear

-Range("B331").Clear

-Range("C331").Clear

-Range("D331").Clear

-Range("A331").Value = "xlParameterTypeNumeric"

-Range("B331").Value = 2

-Range("C331").Value = num

-B331 = Range("B331").Value

-C331 = Range("C331").Value

-If B331 = C331 Then

-Range("D331").Value = "OK"

-Else

-Range("D331").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeReal(ByRef num)

-Range("A332").Clear

-Range("B332").Clear

-Range("C332").Clear

-Range("D332").Clear

-Range("A332").Value = "xlParameterTypeReal"

-Range("B332").Value = 7

-Range("C332").Value = num

-B332 = Range("B332").Value

-C332 = Range("C332").Value

-If B332 = C332 Then

-Range("D332").Value = "OK"

-Else

-Range("D332").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeSmallInt(ByRef num)

-Range("A333").Clear

-Range("B333").Clear

-Range("C333").Clear

-Range("D333").Clear

-Range("A333").Value = "xlParameterTypeSmallInt"

-Range("B333").Value = 5

-Range("C333").Value = num

-B333 = Range("B333").Value

-C333 = Range("C333").Value

-If B333 = C333 Then

-Range("D333").Value = "OK"

-Else

-Range("D333").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeTime(ByRef num)

-Range("A334").Clear

-Range("B334").Clear

-Range("C334").Clear

-Range("D334").Clear

-Range("A334").Value = "xlParameterTypeTime"

-Range("B334").Value = 10

-Range("C334").Value = num

-B334 = Range("B334").Value

-C334 = Range("C334").Value

-If B334 = C334 Then

-Range("D334").Value = "OK"

-Else

-Range("D334").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeTimestamp(ByRef num)

-Range("A335").Clear

-Range("B335").Clear

-Range("C335").Clear

-Range("D335").Clear

-Range("A335").Value = "xlParameterTypeTimestamp"

-Range("B335").Value = 11

-Range("C335").Value = num

-B335 = Range("B335").Value

-C335 = Range("C335").Value

-If B335 = C335 Then

-Range("D335").Value = "OK"

-Else

-Range("D335").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeTinyInt(ByRef num)

-Range("A336").Clear

-Range("B336").Clear

-Range("C336").Clear

-Range("D336").Clear

-Range("A336").Value = "xlParameterTypeTinyInt"

-Range("B336").Value = -6

-Range("C336").Value = num

-B336 = Range("B336").Value

-C336 = Range("C336").Value

-If B336 = C336 Then

-Range("D336").Value = "OK"

-Else

-Range("D336").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeUnknown(ByRef num)

-Range("A337").Clear

-Range("B337").Clear

-Range("C337").Clear

-Range("D337").Clear

-Range("A337").Value = "xlParameterTypeUnknown"

-Range("B337").Value = 0

-Range("C337").Value = num

-B337 = Range("B337").Value

-C337 = Range("C337").Value

-If B337 = C337 Then

-Range("D337").Value = "OK"

-Else

-Range("D337").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeVarBinary(ByRef num)

-Range("A338").Clear

-Range("B338").Clear

-Range("C338").Clear

-Range("D338").Clear

-Range("A338").Value = "xlParameterTypeVarBinary"

-Range("B338").Value = -3

-Range("C338").Value = num

-B338 = Range("B338").Value

-C338 = Range("C338").Value

-If B338 = C338 Then

-Range("D338").Value = "OK"

-Else

-Range("D338").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeVarChar(ByRef num)

-Range("A339").Clear

-Range("B339").Clear

-Range("C339").Clear

-Range("D339").Clear

-Range("A339").Value = "xlParameterTypeVarChar"

-Range("B339").Value = 12

-Range("C339").Value = num

-B339 = Range("B339").Value

-C339 = Range("C339").Value

-If B339 = C339 Then

-Range("D339").Value = "OK"

-Else

-Range("D339").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeWChar(ByRef num)

-Range("A340").Clear

-Range("B340").Clear

-Range("C340").Clear

-Range("D340").Clear

-Range("A340").Value = "xlParameterTypeWChar"

-Range("B340").Value = -8

-Range("C340").Value = num

-B340 = Range("B340").Value

-C340 = Range("C340").Value

-If B340 = C340 Then

-Range("D340").Value = "OK"

-Else

-Range("D340").Value = "NG"

-End If

-End Function

-

-Function test_xlConstant(ByRef num)

-Range("A341").Clear

-Range("B341").Clear

-Range("C341").Clear

-Range("D341").Clear

-Range("A341").Value = "xlConstant"

-Range("B341").Value = 1

-Range("C341").Value = num

-B341 = Range("B341").Value

-C341 = Range("C341").Value

-If B341 = C341 Then

-Range("D341").Value = "OK"

-Else

-Range("D341").Value = "NG"

-End If

-End Function

-

-Function test_xlPrompt(ByRef num)

-Range("A342").Clear

-Range("B342").Clear

-Range("C342").Clear

-Range("D342").Clear

-Range("A342").Value = "xlPrompt"

-Range("B342").Value = 0

-Range("C342").Value = num

-B342 = Range("B342").Value

-C342 = Range("C342").Value

-If B342 = C342 Then

-Range("D342").Value = "OK"

-Else

-Range("D342").Value = "NG"

-End If

-End Function

-

-Function test_xlRange(ByRef num)

-Range("A343").Clear

-Range("B343").Clear

-Range("C343").Clear

-Range("D343").Clear

-Range("A343").Value = "xlRange"

-Range("B343").Value = 2

-Range("C343").Value = num

-B343 = Range("B343").Value

-C343 = Range("C343").Value

-If B343 = C343 Then

-Range("D343").Value = "OK"

-Else

-Range("D343").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteSpecialOperationAdd(ByRef num)

-Range("A344").Clear

-Range("B344").Clear

-Range("C344").Clear

-Range("D344").Clear

-Range("A344").Value = "xlPasteSpecialOperationAdd"

-Range("B344").Value = 2

-Range("C344").Value = num

-B344 = Range("B344").Value

-C344 = Range("C344").Value

-If B344 = C344 Then

-Range("D344").Value = "OK"

-Else

-Range("D344").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteSpecialOperationDivide(ByRef num)

-Range("A345").Clear

-Range("B345").Clear

-Range("C345").Clear

-Range("D345").Clear

-Range("A345").Value = "xlPasteSpecialOperationDivide"

-Range("B345").Value = 5

-Range("C345").Value = num

-B345 = Range("B345").Value

-C345 = Range("C345").Value

-If B345 = C345 Then

-Range("D345").Value = "OK"

-Else

-Range("D345").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteSpecialOperationMultiply(ByRef num)

-Range("A346").Clear

-Range("B346").Clear

-Range("C346").Clear

-Range("D346").Clear

-Range("A346").Value = "xlPasteSpecialOperationMultiply"

-Range("B346").Value = 4

-Range("C346").Value = num

-B346 = Range("B346").Value

-C346 = Range("C346").Value

-If B346 = C346 Then

-Range("D346").Value = "OK"

-Else

-Range("D346").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteSpecialOperationNone(ByRef num)

-Range("A347").Clear

-Range("B347").Clear

-Range("C347").Clear

-Range("D347").Clear

-Range("A347").Value = "xlPasteSpecialOperationNone"

-Range("B347").Value = -4142

-Range("C347").Value = num

-B347 = Range("B347").Value

-C347 = Range("C347").Value

-If B347 = C347 Then

-Range("D347").Value = "OK"

-Else

-Range("D347").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteSpecialOperationSubstract(ByRef num)

-Range("A348").Clear

-Range("B348").Clear

-Range("C348").Clear

-Range("D348").Clear

-Range("A348").Value = "xlPasteSpecialOperationSubstract"

-Range("B348").Value = 3

-Range("C348").Value = num

-B348 = Range("B348").Value

-C348 = Range("C348").Value

-If B348 = C348 Then

-Range("D348").Value = "OK"

-Else

-Range("D348").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteAll(ByRef num)

-Range("A349").Clear

-Range("B349").Clear

-Range("C349").Clear

-Range("D349").Clear

-Range("A349").Value = "xlPasteAll"

-Range("B349").Value = -4104

-Range("C349").Value = num

-B349 = Range("B349").Value

-C349 = Range("C349").Value

-If B349 = C349 Then

-Range("D349").Value = "OK"

-Else

-Range("D349").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteAllExceptBorders(ByRef num)

-Range("A350").Clear

-Range("B350").Clear

-Range("C350").Clear

-Range("D350").Clear

-Range("A350").Value = "xlPasteAllExceptBorders"

-Range("B350").Value = 7

-Range("C350").Value = num

-B350 = Range("B350").Value

-C350 = Range("C350").Value

-If B350 = C350 Then

-Range("D350").Value = "OK"

-Else

-Range("D350").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteAllColumnWidths(ByRef num)

-Range("A351").Clear

-Range("B351").Clear

-Range("C351").Clear

-Range("D351").Clear

-Range("A351").Value = "xlPasteAllColumnWidths"

-Range("B351").Value = 8

-Range("C351").Value = num

-B351 = Range("B351").Value

-C351 = Range("C351").Value

-If B351 = C351 Then

-Range("D351").Value = "OK"

-Else

-Range("D351").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteComments(ByRef num)

-Range("A352").Clear

-Range("B352").Clear

-Range("C352").Clear

-Range("D352").Clear

-Range("A352").Value = "xlPasteComments"

-Range("B352").Value = -4144

-Range("C352").Value = num

-B352 = Range("B352").Value

-C352 = Range("C352").Value

-If B352 = C352 Then

-Range("D352").Value = "OK"

-Else

-Range("D352").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteFormats(ByRef num)

-Range("A353").Clear

-Range("B353").Clear

-Range("C353").Clear

-Range("D353").Clear

-Range("A353").Value = "xlPasteFormats"

-Range("B353").Value = -4122

-Range("C353").Value = num

-B353 = Range("B353").Value

-C353 = Range("C353").Value

-If B353 = C353 Then

-Range("D353").Value = "OK"

-Else

-Range("D353").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteFormulas(ByRef num)

-Range("A354").Clear

-Range("B354").Clear

-Range("C354").Clear

-Range("D354").Clear

-Range("A354").Value = "xlPasteFormulas"

-Range("B354").Value = -4123

-Range("C354").Value = num

-B354 = Range("B354").Value

-C354 = Range("C354").Value

-If B354 = C354 Then

-Range("D354").Value = "OK"

-Else

-Range("D354").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteFormulasAndNumberFormats(ByRef num)

-Range("A355").Clear

-Range("B355").Clear

-Range("C355").Clear

-Range("D355").Clear

-Range("A355").Value = "xlPasteFormulasAndNumberFormats"

-Range("B355").Value = 11

-Range("C355").Value = num

-B355 = Range("B355").Value

-C355 = Range("C355").Value

-If B355 = C355 Then

-Range("D355").Value = "OK"

-Else

-Range("D355").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteValidation(ByRef num)

-Range("A356").Clear

-Range("B356").Clear

-Range("C356").Clear

-Range("D356").Clear

-Range("A356").Value = "xlPasteValidation"

-Range("B356").Value = 6

-Range("C356").Value = num

-B356 = Range("B356").Value

-C356 = Range("C356").Value

-If B356 = C356 Then

-Range("D356").Value = "OK"

-Else

-Range("D356").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteValues(ByRef num)

-Range("A357").Clear

-Range("B357").Clear

-Range("C357").Clear

-Range("D357").Clear

-Range("A357").Value = "xlPasteValues"

-Range("B357").Value = -4163

-Range("C357").Value = num

-B357 = Range("B357").Value

-C357 = Range("C357").Value

-If B357 = C357 Then

-Range("D357").Value = "OK"

-Else

-Range("D357").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteValuesAndNumberFormats(ByRef num)

-Range("A358").Clear

-Range("B358").Clear

-Range("C358").Clear

-Range("D358").Clear

-Range("A358").Value = "xlPasteValuesAndNumberFormats"

-Range("B358").Value = 12

-Range("C358").Value = num

-B358 = Range("B358").Value

-C358 = Range("C358").Value

-If B358 = C358 Then

-Range("D358").Value = "OK"

-Else

-Range("D358").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternAutomatic(ByRef num)

-Range("A359").Clear

-Range("B359").Clear

-Range("C359").Clear

-Range("D359").Clear

-Range("A359").Value = "xlPatternAutomatic"

-Range("B359").Value = -4105

-Range("C359").Value = num

-B359 = Range("B359").Value

-C359 = Range("C359").Value

-If B359 = C359 Then

-Range("D359").Value = "OK"

-Else

-Range("D359").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternChecker(ByRef num)

-Range("A360").Clear

-Range("B360").Clear

-Range("C360").Clear

-Range("D360").Clear

-Range("A360").Value = "xlPatternChecker"

-Range("B360").Value = 9

-Range("C360").Value = num

-B360 = Range("B360").Value

-C360 = Range("C360").Value

-If B360 = C360 Then

-Range("D360").Value = "OK"

-Else

-Range("D360").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternCrissCross(ByRef num)

-Range("A361").Clear

-Range("B361").Clear

-Range("C361").Clear

-Range("D361").Clear

-Range("A361").Value = "xlPatternCrissCross"

-Range("B361").Value = 16

-Range("C361").Value = num

-B361 = Range("B361").Value

-C361 = Range("C361").Value

-If B361 = C361 Then

-Range("D361").Value = "OK"

-Else

-Range("D361").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternDown(ByRef num)

-Range("A362").Clear

-Range("B362").Clear

-Range("C362").Clear

-Range("D362").Clear

-Range("A362").Value = "xlPatternDown"

-Range("B362").Value = -4121

-Range("C362").Value = num

-B362 = Range("B362").Value

-C362 = Range("C362").Value

-If B362 = C362 Then

-Range("D362").Value = "OK"

-Else

-Range("D362").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternGray16(ByRef num)

-Range("A363").Clear

-Range("B363").Clear

-Range("C363").Clear

-Range("D363").Clear

-Range("A363").Value = "xlPatternGray16"

-Range("B363").Value = 17

-Range("C363").Value = num

-B363 = Range("B363").Value

-C363 = Range("C363").Value

-If B363 = C363 Then

-Range("D363").Value = "OK"

-Else

-Range("D363").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternGray25(ByRef num)

-Range("A364").Clear

-Range("B364").Clear

-Range("C364").Clear

-Range("D364").Clear

-Range("A364").Value = "xlPatternGray25"

-Range("B364").Value = -4124

-Range("C364").Value = num

-B364 = Range("B364").Value

-C364 = Range("C364").Value

-If B364 = C364 Then

-Range("D364").Value = "OK"

-Else

-Range("D364").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternGray50(ByRef num)

-Range("A365").Clear

-Range("B365").Clear

-Range("C365").Clear

-Range("D365").Clear

-Range("A365").Value = "xlPatternGray50"

-Range("B365").Value = -4125

-Range("C365").Value = num

-B365 = Range("B365").Value

-C365 = Range("C365").Value

-If B365 = C365 Then

-Range("D365").Value = "OK"

-Else

-Range("D365").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternGray75(ByRef num)

-Range("A366").Clear

-Range("B366").Clear

-Range("C366").Clear

-Range("D366").Clear

-Range("A366").Value = "xlPatternGray75"

-Range("B366").Value = -4126

-Range("C366").Value = num

-B366 = Range("B366").Value

-C366 = Range("C366").Value

-If B366 = C366 Then

-Range("D366").Value = "OK"

-Else

-Range("D366").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternGray8(ByRef num)

-Range("A367").Clear

-Range("B367").Clear

-Range("C367").Clear

-Range("D367").Clear

-Range("A367").Value = "xlPatternGray8"

-Range("B367").Value = 18

-Range("C367").Value = num

-B367 = Range("B367").Value

-C367 = Range("C367").Value

-If B367 = C367 Then

-Range("D367").Value = "OK"

-Else

-Range("D367").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternGrid(ByRef num)

-Range("A368").Clear

-Range("B368").Clear

-Range("C368").Clear

-Range("D368").Clear

-Range("A368").Value = "xlPatternGrid"

-Range("B368").Value = 15

-Range("C368").Value = num

-B368 = Range("B368").Value

-C368 = Range("C368").Value

-If B368 = C368 Then

-Range("D368").Value = "OK"

-Else

-Range("D368").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternHorizontal(ByRef num)

-Range("A369").Clear

-Range("B369").Clear

-Range("C369").Clear

-Range("D369").Clear

-Range("A369").Value = "xlPatternHorizontal"

-Range("B369").Value = -4128

-Range("C369").Value = num

-B369 = Range("B369").Value

-C369 = Range("C369").Value

-If B369 = C369 Then

-Range("D369").Value = "OK"

-Else

-Range("D369").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternLightDown(ByRef num)

-Range("A370").Clear

-Range("B370").Clear

-Range("C370").Clear

-Range("D370").Clear

-Range("A370").Value = "xlPatternLightDown"

-Range("B370").Value = 13

-Range("C370").Value = num

-B370 = Range("B370").Value

-C370 = Range("C370").Value

-If B370 = C370 Then

-Range("D370").Value = "OK"

-Else

-Range("D370").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternLightHorizontal(ByRef num)

-Range("A371").Clear

-Range("B371").Clear

-Range("C371").Clear

-Range("D371").Clear

-Range("A371").Value = "xlPatternLightHorizontal"

-Range("B371").Value = 11

-Range("C371").Value = num

-B371 = Range("B371").Value

-C371 = Range("C371").Value

-If B371 = C371 Then

-Range("D371").Value = "OK"

-Else

-Range("D371").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternLightUp(ByRef num)

-Range("A372").Clear

-Range("B372").Clear

-Range("C372").Clear

-Range("D372").Clear

-Range("A372").Value = "xlPatternLightUp"

-Range("B372").Value = 14

-Range("C372").Value = num

-B372 = Range("B372").Value

-C372 = Range("C372").Value

-If B372 = C372 Then

-Range("D372").Value = "OK"

-Else

-Range("D372").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternLightVertical(ByRef num)

-Range("A373").Clear

-Range("B373").Clear

-Range("C373").Clear

-Range("D373").Clear

-Range("A373").Value = "xlPatternLightVertical"

-Range("B373").Value = 12

-Range("C373").Value = num

-B373 = Range("B373").Value

-C373 = Range("C373").Value

-If B373 = C373 Then

-Range("D373").Value = "OK"

-Else

-Range("D373").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternNone(ByRef num)

-Range("A374").Clear

-Range("B374").Clear

-Range("C374").Clear

-Range("D374").Clear

-Range("A374").Value = "xlPatternNone"

-Range("B374").Value = -4142

-Range("C374").Value = num

-B374 = Range("B374").Value

-C374 = Range("C374").Value

-If B374 = C374 Then

-Range("D374").Value = "OK"

-Else

-Range("D374").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternSemiGray75(ByRef num)

-Range("A375").Clear

-Range("B375").Clear

-Range("C375").Clear

-Range("D375").Clear

-Range("A375").Value = "xlPatternSemiGray75"

-Range("B375").Value = 10

-Range("C375").Value = num

-B375 = Range("B375").Value

-C375 = Range("C375").Value

-If B375 = C375 Then

-Range("D375").Value = "OK"

-Else

-Range("D375").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternSolid(ByRef num)

-Range("A376").Clear

-Range("B376").Clear

-Range("C376").Clear

-Range("D376").Clear

-Range("A376").Value = "xlPatternSolid"

-Range("B376").Value = 1

-Range("C376").Value = num

-B376 = Range("B376").Value

-C376 = Range("C376").Value

-If B376 = C376 Then

-Range("D376").Value = "OK"

-Else

-Range("D376").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternUp(ByRef num)

-Range("A377").Clear

-Range("B377").Clear

-Range("C377").Clear

-Range("D377").Clear

-Range("A377").Value = "xlPatternUp"

-Range("B377").Value = -4162

-Range("C377").Value = num

-B377 = Range("B377").Value

-C377 = Range("C377").Value

-If B377 = C377 Then

-Range("D377").Value = "OK"

-Else

-Range("D377").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternVertical(ByRef num)

-Range("A378").Clear

-Range("B378").Clear

-Range("C378").Clear

-Range("D378").Clear

-Range("A378").Value = "xlPatternVertical"

-Range("B378").Value = -4166

-Range("C378").Value = num

-B378 = Range("B378").Value

-C378 = Range("C378").Value

-If B378 = C378 Then

-Range("D378").Value = "OK"

-Else

-Range("D378").Value = "NG"

-End If

-End Function

-

-Function test_XlPhoneticAlignCenter(ByRef num)

-Range("A379").Clear

-Range("B379").Clear

-Range("C379").Clear

-Range("D379").Clear

-Range("A379").Value = "XlPhoneticAlignCenter"

-Range("B379").Value = 2

-Range("C379").Value = num

-B379 = Range("B379").Value

-C379 = Range("C379").Value

-If B379 = C379 Then

-Range("D379").Value = "OK"

-Else

-Range("D379").Value = "NG"

-End If

-End Function

-

-Function test_XlPhoneticAlignDistributed(ByRef num)

-Range("A380").Clear

-Range("B380").Clear

-Range("C380").Clear

-Range("D380").Clear

-Range("A380").Value = "XlPhoneticAlignDistributed"

-Range("B380").Value = 3

-Range("C380").Value = num

-B380 = Range("B380").Value

-C380 = Range("C380").Value

-If B380 = C380 Then

-Range("D380").Value = "OK"

-Else

-Range("D380").Value = "NG"

-End If

-End Function

-

-Function test_XlPhoneticAlignLeft(ByRef num)

-Range("A381").Clear

-Range("B381").Clear

-Range("C381").Clear

-Range("D381").Clear

-Range("A381").Value = "XlPhoneticAlignLeft"

-Range("B381").Value = 1

-Range("C381").Value = num

-B381 = Range("B381").Value

-C381 = Range("C381").Value

-If B381 = C381 Then

-Range("D381").Value = "OK"

-Else

-Range("D381").Value = "NG"

-End If

-End Function

-

-Function test_XlPhoneticAlignNoControl(ByRef num)

-Range("A382").Clear

-Range("B382").Clear

-Range("C382").Clear

-Range("D382").Clear

-Range("A382").Value = "XlPhoneticAlignNoControl"

-Range("B382").Value = 0

-Range("C382").Value = num

-B382 = Range("B382").Value

-C382 = Range("C382").Value

-If B382 = C382 Then

-Range("D382").Value = "OK"

-Else

-Range("D382").Value = "NG"

-End If

-End Function

-

-Function test_xlPrinter(ByRef num)

-Range("A383").Clear

-Range("B383").Clear

-Range("C383").Clear

-Range("D383").Clear

-Range("A383").Value = "xlPrinter"

-Range("B383").Value = 2

-Range("C383").Value = num

-B383 = Range("B383").Value

-C383 = Range("C383").Value

-If B383 = C383 Then

-Range("D383").Value = "OK"

-Else

-Range("D383").Value = "NG"

-End If

-End Function

-

-Function test_xlScreen(ByRef num)

-Range("A384").Clear

-Range("B384").Clear

-Range("C384").Clear

-Range("D384").Clear

-Range("A384").Value = "xlScreen"

-Range("B384").Value = 1

-Range("C384").Value = num

-B384 = Range("B384").Value

-C384 = Range("C384").Value

-If B384 = C384 Then

-Range("D384").Value = "OK"

-Else

-Range("D384").Value = "NG"

-End If

-End Function

-

-Function test_xlBMP(ByRef num)

-Range("A385").Clear

-Range("B385").Clear

-Range("C385").Clear

-Range("D385").Clear

-Range("A385").Value = "xlBMP"

-Range("B385").Value = 1

-Range("C385").Value = num

-B385 = Range("B385").Value

-C385 = Range("C385").Value

-If B385 = C385 Then

-Range("D385").Value = "OK"

-Else

-Range("D385").Value = "NG"

-End If

-End Function

-

-Function test_xlCGM(ByRef num)

-Range("A386").Clear

-Range("B386").Clear

-Range("C386").Clear

-Range("D386").Clear

-Range("A386").Value = "xlCGM"

-Range("B386").Value = 7

-Range("C386").Value = num

-B386 = Range("B386").Value

-C386 = Range("C386").Value

-If B386 = C386 Then

-Range("D386").Value = "OK"

-Else

-Range("D386").Value = "NG"

-End If

-End Function

-

-Function test_xlDRW(ByRef num)

-Range("A387").Clear

-Range("B387").Clear

-Range("C387").Clear

-Range("D387").Clear

-Range("A387").Value = "xlDRW"

-Range("B387").Value = 4

-Range("C387").Value = num

-B387 = Range("B387").Value

-C387 = Range("C387").Value

-If B387 = C387 Then

-Range("D387").Value = "OK"

-Else

-Range("D387").Value = "NG"

-End If

-End Function

-

-Function test_xlDXF(ByRef num)

-Range("A388").Clear

-Range("B388").Clear

-Range("C388").Clear

-Range("D388").Clear

-Range("A388").Value = "xlDXF"

-Range("B388").Value = 5

-Range("C388").Value = num

-B388 = Range("B388").Value

-C388 = Range("C388").Value

-If B388 = C388 Then

-Range("D388").Value = "OK"

-Else

-Range("D388").Value = "NG"

-End If

-End Function

-

-Function test_xlEPS(ByRef num)

-Range("A389").Clear

-Range("B389").Clear

-Range("C389").Clear

-Range("D389").Clear

-Range("A389").Value = "xlEPS"

-Range("B389").Value = 8

-Range("C389").Value = num

-B389 = Range("B389").Value

-C389 = Range("C389").Value

-If B389 = C389 Then

-Range("D389").Value = "OK"

-Else

-Range("D389").Value = "NG"

-End If

-End Function

-

-Function test_xlHGL(ByRef num)

-Range("A390").Clear

-Range("B390").Clear

-Range("C390").Clear

-Range("D390").Clear

-Range("A390").Value = "xlHGL"

-Range("B390").Value = 6

-Range("C390").Value = num

-B390 = Range("B390").Value

-C390 = Range("C390").Value

-If B390 = C390 Then

-Range("D390").Value = "OK"

-Else

-Range("D390").Value = "NG"

-End If

-End Function

-

-Function test_xlPCT(ByRef num)

-Range("A391").Clear

-Range("B391").Clear

-Range("C391").Clear

-Range("D391").Clear

-Range("A391").Value = "xlPCT"

-Range("B391").Value = 13

-Range("C391").Value = num

-B391 = Range("B391").Value

-C391 = Range("C391").Value

-If B391 = C391 Then

-Range("D391").Value = "OK"

-Else

-Range("D391").Value = "NG"

-End If

-End Function

-

-Function test_xlPCX(ByRef num)

-Range("A392").Clear

-Range("B392").Clear

-Range("C392").Clear

-Range("D392").Clear

-Range("A392").Value = "xlPCX"

-Range("B392").Value = 10

-Range("C392").Value = num

-B392 = Range("B392").Value

-C392 = Range("C392").Value

-If B392 = C392 Then

-Range("D392").Value = "OK"

-Else

-Range("D392").Value = "NG"

-End If

-End Function

-

-Function test_xlPIC(ByRef num)

-Range("A393").Clear

-Range("B393").Clear

-Range("C393").Clear

-Range("D393").Clear

-Range("A393").Value = "xlPIC"

-Range("B393").Value = 11

-Range("C393").Value = num

-B393 = Range("B393").Value

-C393 = Range("C393").Value

-If B393 = C393 Then

-Range("D393").Value = "OK"

-Else

-Range("D393").Value = "NG"

-End If

-End Function

-

-Function test_xlPLT(ByRef num)

-Range("A394").Clear

-Range("B394").Clear

-Range("C394").Clear

-Range("D394").Clear

-Range("A394").Value = "xlPLT"

-Range("B394").Value = 12

-Range("C394").Value = num

-B394 = Range("B394").Value

-C394 = Range("C394").Value

-If B394 = C394 Then

-Range("D394").Value = "OK"

-Else

-Range("D394").Value = "NG"

-End If

-End Function

-

-Function test_xlTIF(ByRef num)

-Range("A395").Clear

-Range("B395").Clear

-Range("C395").Clear

-Range("D395").Clear

-Range("A395").Value = "xlTIF"

-Range("B395").Value = 9

-Range("C395").Value = num

-B395 = Range("B395").Value

-C395 = Range("C395").Value

-If B395 = C395 Then

-Range("D395").Value = "OK"

-Else

-Range("D395").Value = "NG"

-End If

-End Function

-

-Function test_xlWMF(ByRef num)

-Range("A396").Clear

-Range("B396").Clear

-Range("C396").Clear

-Range("D396").Clear

-Range("A396").Value = "xlWMF"

-Range("B396").Value = 2

-Range("C396").Value = num

-B396 = Range("B396").Value

-C396 = Range("C396").Value

-If B396 = C396 Then

-Range("D396").Value = "OK"

-Else

-Range("D396").Value = "NG"

-End If

-End Function

-

-Function test_xlWPG(ByRef num)

-Range("A397").Clear

-Range("B397").Clear

-Range("C397").Clear

-Range("D397").Clear

-Range("A397").Value = "xlWPG"

-Range("B397").Value = 3

-Range("C397").Value = num

-B397 = Range("B397").Value

-C397 = Range("C397").Value

-If B397 = C397 Then

-Range("D397").Value = "OK"

-Else

-Range("D397").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotCellBlankCell(ByRef num)

-Range("A398").Clear

-Range("B398").Clear

-Range("C398").Clear

-Range("D398").Clear

-Range("A398").Value = "xlPivotCellBlankCell"

-Range("B398").Value = 0

-Range("C398").Value = num

-B398 = Range("B398").Value

-C398 = Range("C398").Value

-If B398 = C398 Then

-Range("D398").Value = "OK"

-Else

-Range("D398").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotCellCustomSubtotal(ByRef num)

-Range("A399").Clear

-Range("B399").Clear

-Range("C399").Clear

-Range("D399").Clear

-Range("A399").Value = "xlPivotCellCustomSubtotal"

-Range("B399").Value = 7

-Range("C399").Value = num

-B399 = Range("B399").Value

-C399 = Range("C399").Value

-If B399 = C399 Then

-Range("D399").Value = "OK"

-Else

-Range("D399").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotCellDataField(ByRef num)

-Range("A400").Clear

-Range("B400").Clear

-Range("C400").Clear

-Range("D400").Clear

-Range("A400").Value = "xlPivotCellDataField"

-Range("B400").Value = 4

-Range("C400").Value = num

-B400 = Range("B400").Value

-C400 = Range("C400").Value

-If B400 = C400 Then

-Range("D400").Value = "OK"

-Else

-Range("D400").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotCellDataPivotField(ByRef num)

-Range("A401").Clear

-Range("B401").Clear

-Range("C401").Clear

-Range("D401").Clear

-Range("A401").Value = "xlPivotCellDataPivotField"

-Range("B401").Value = 8

-Range("C401").Value = num

-B401 = Range("B401").Value

-C401 = Range("C401").Value

-If B401 = C401 Then

-Range("D401").Value = "OK"

-Else

-Range("D401").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotCellGrandTotal(ByRef num)

-Range("A402").Clear

-Range("B402").Clear

-Range("C402").Clear

-Range("D402").Clear

-Range("A402").Value = "xlPivotCellGrandTotal"

-Range("B402").Value = 3

-Range("C402").Value = num

-B402 = Range("B402").Value

-C402 = Range("C402").Value

-If B402 = C402 Then

-Range("D402").Value = "OK"

-Else

-Range("D402").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotCellPageFieldItem(ByRef num)

-Range("A403").Clear

-Range("B403").Clear

-Range("C403").Clear

-Range("D403").Clear

-Range("A403").Value = "xlPivotCellPageFieldItem"

-Range("B403").Value = 6

-Range("C403").Value = num

-B403 = Range("B403").Value

-C403 = Range("C403").Value

-If B403 = C403 Then

-Range("D403").Value = "OK"

-Else

-Range("D403").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotCellPivotField(ByRef num)

-Range("A404").Clear

-Range("B404").Clear

-Range("C404").Clear

-Range("D404").Clear

-Range("A404").Value = "xlPivotCellPivotField"

-Range("B404").Value = 5

-Range("C404").Value = num

-B404 = Range("B404").Value

-C404 = Range("C404").Value

-If B404 = C404 Then

-Range("D404").Value = "OK"

-Else

-Range("D404").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotCellPivotItem(ByRef num)

-Range("A405").Clear

-Range("B405").Clear

-Range("C405").Clear

-Range("D405").Clear

-Range("A405").Value = "xlPivotCellPivotItem"

-Range("B405").Value = 1

-Range("C405").Value = num

-B405 = Range("B405").Value

-C405 = Range("C405").Value

-If B405 = C405 Then

-Range("D405").Value = "OK"

-Else

-Range("D405").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotCellSubtotal(ByRef num)

-Range("A406").Clear

-Range("B406").Clear

-Range("C406").Clear

-Range("D406").Clear

-Range("A406").Value = "xlPivotCellSubtotal"

-Range("B406").Value = 2

-Range("C406").Value = num

-B406 = Range("B406").Value

-C406 = Range("C406").Value

-If B406 = C406 Then

-Range("D406").Value = "OK"

-Else

-Range("D406").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotCellValue(ByRef num)

-Range("A407").Clear

-Range("B407").Clear

-Range("C407").Clear

-Range("D407").Clear

-Range("A407").Value = "xlPivotCellValue"

-Range("B407").Value = 0

-Range("C407").Value = num

-B407 = Range("B407").Value

-C407 = Range("C407").Value

-If B407 = C407 Then

-Range("D407").Value = "OK"

-Else

-Range("D407").Value = "NG"

-End If

-End Function

-

-Function test_xlDifferenceFrom(ByRef num)

-Range("A408").Clear

-Range("B408").Clear

-Range("C408").Clear

-Range("D408").Clear

-Range("A408").Value = "xlDifferenceFrom"

-Range("B408").Value = 2

-Range("C408").Value = num

-B408 = Range("B408").Value

-C408 = Range("C408").Value

-If B408 = C408 Then

-Range("D408").Value = "OK"

-Else

-Range("D408").Value = "NG"

-End If

-End Function

-

-Function test_xlIndex(ByRef num)

-Range("A409").Clear

-Range("B409").Clear

-Range("C409").Clear

-Range("D409").Clear

-Range("A409").Value = "xlIndex"

-Range("B409").Value = 9

-Range("C409").Value = num

-B409 = Range("B409").Value

-C409 = Range("C409").Value

-If B409 = C409 Then

-Range("D409").Value = "OK"

-Else

-Range("D409").Value = "NG"

-End If

-End Function

-

-Function test_xlNoAdditionalCalculation(ByRef num)

-Range("A410").Clear

-Range("B410").Clear

-Range("C410").Clear

-Range("D410").Clear

-Range("A410").Value = "xlNoAdditionalCalculation"

-Range("B410").Value = -4143

-Range("C410").Value = num

-B410 = Range("B410").Value

-C410 = Range("C410").Value

-If B410 = C410 Then

-Range("D410").Value = "OK"

-Else

-Range("D410").Value = "NG"

-End If

-End Function

-

-Function test_xlPercentDifferenceFrom(ByRef num)

-Range("A411").Clear

-Range("B411").Clear

-Range("C411").Clear

-Range("D411").Clear

-Range("A411").Value = "xlPercentDifferenceFrom"

-Range("B411").Value = 4

-Range("C411").Value = num

-B411 = Range("B411").Value

-C411 = Range("C411").Value

-If B411 = C411 Then

-Range("D411").Value = "OK"

-Else

-Range("D411").Value = "NG"

-End If

-End Function

-

-Function test_xlPercentOf(ByRef num)

-Range("A412").Clear

-Range("B412").Clear

-Range("C412").Clear

-Range("D412").Clear

-Range("A412").Value = "xlPercentOf"

-Range("B412").Value = 3

-Range("C412").Value = num

-B412 = Range("B412").Value

-C412 = Range("C412").Value

-If B412 = C412 Then

-Range("D412").Value = "OK"

-Else

-Range("D412").Value = "NG"

-End If

-End Function

-

-Function test_xlPercentOfColumn(ByRef num)

-Range("A413").Clear

-Range("B413").Clear

-Range("C413").Clear

-Range("D413").Clear

-Range("A413").Value = "xlPercentOfColumn"

-Range("B413").Value = 7

-Range("C413").Value = num

-B413 = Range("B413").Value

-C413 = Range("C413").Value

-If B413 = C413 Then

-Range("D413").Value = "OK"

-Else

-Range("D413").Value = "NG"

-End If

-End Function

-

-Function test_xlPercentOfRow(ByRef num)

-Range("A414").Clear

-Range("B414").Clear

-Range("C414").Clear

-Range("D414").Clear

-Range("A414").Value = "xlPercentOfRow"

-Range("B414").Value = 6

-Range("C414").Value = num

-B414 = Range("B414").Value

-C414 = Range("C414").Value

-If B414 = C414 Then

-Range("D414").Value = "OK"

-Else

-Range("D414").Value = "NG"

-End If

-End Function

-

-Function test_xlPercentOfTotal(ByRef num)

-Range("A415").Clear

-Range("B415").Clear

-Range("C415").Clear

-Range("D415").Clear

-Range("A415").Value = "xlPercentOfTotal"

-Range("B415").Value = 8

-Range("C415").Value = num

-B415 = Range("B415").Value

-C415 = Range("C415").Value

-If B415 = C415 Then

-Range("D415").Value = "OK"

-Else

-Range("D415").Value = "NG"

-End If

-End Function

-

-Function test_xlRunningTotal(ByRef num)

-Range("A416").Clear

-Range("B416").Clear

-Range("C416").Clear

-Range("D416").Clear

-Range("A416").Value = "xlRunningTotal"

-Range("B416").Value = 5

-Range("C416").Value = num

-B416 = Range("B416").Value

-C416 = Range("C416").Value

-If B416 = C416 Then

-Range("D416").Value = "OK"

-Else

-Range("D416").Value = "NG"

-End If

-End Function

-

-Function test_xlDate(ByRef num)

-Range("A417").Clear

-Range("B417").Clear

-Range("C417").Clear

-Range("D417").Clear

-Range("A417").Value = "xlDate"

-Range("B417").Value = 2

-Range("C417").Value = num

-B417 = Range("B417").Value

-C417 = Range("C417").Value

-If B417 = C417 Then

-Range("D417").Value = "OK"

-Else

-Range("D417").Value = "NG"

-End If

-End Function

-

-Function test_xlNumber(ByRef num)

-Range("A418").Clear

-Range("B418").Clear

-Range("C418").Clear

-Range("D418").Clear

-Range("A418").Value = "xlNumber"

-Range("B418").Value = -4145

-Range("C418").Value = num

-B418 = Range("B418").Value

-C418 = Range("C418").Value

-If B418 = C418 Then

-Range("D418").Value = "OK"

-Else

-Range("D418").Value = "NG"

-End If

-End Function

-

-Function test_xlText(ByRef num)

-Range("A419").Clear

-Range("B419").Clear

-Range("C419").Clear

-Range("D419").Clear

-Range("A419").Value = "xlText"

-Range("B419").Value = -4158

-Range("C419").Value = num

-B419 = Range("B419").Value

-C419 = Range("C419").Value

-If B419 = C419 Then

-Range("D419").Value = "OK"

-Else

-Range("D419").Value = "NG"

-End If

-End Function

-

-Function test_xlColumnField(ByRef num)

-Range("A420").Clear

-Range("B420").Clear

-Range("C420").Clear

-Range("D420").Clear

-Range("A420").Value = "xlColumnField"

-Range("B420").Value = 2

-Range("C420").Value = num

-B420 = Range("B420").Value

-C420 = Range("C420").Value

-If B420 = C420 Then

-Range("D420").Value = "OK"

-Else

-Range("D420").Value = "NG"

-End If

-End Function

-

-Function test_xlDataField(ByRef num)

-Range("A421").Clear

-Range("B421").Clear

-Range("C421").Clear

-Range("D421").Clear

-Range("A421").Value = "xlDataField"

-Range("B421").Value = 4

-Range("C421").Value = num

-B421 = Range("B421").Value

-C421 = Range("C421").Value

-If B421 = C421 Then

-Range("D421").Value = "OK"

-Else

-Range("D421").Value = "NG"

-End If

-End Function

-

-Function test_xlHidden(ByRef num)

-Range("A422").Clear

-Range("B422").Clear

-Range("C422").Clear

-Range("D422").Clear

-Range("A422").Value = "xlHidden"

-Range("B422").Value = 0

-Range("C422").Value = num

-B422 = Range("B422").Value

-C422 = Range("C422").Value

-If B422 = C422 Then

-Range("D422").Value = "OK"

-Else

-Range("D422").Value = "NG"

-End If

-End Function

-

-Function test_xlPageField(ByRef num)

-Range("A423").Clear

-Range("B423").Clear

-Range("C423").Clear

-Range("D423").Clear

-Range("A423").Value = "xlPageField"

-Range("B423").Value = 3

-Range("C423").Value = num

-B423 = Range("B423").Value

-C423 = Range("C423").Value

-If B423 = C423 Then

-Range("D423").Value = "OK"

-Else

-Range("D423").Value = "NG"

-End If

-End Function

-

-Function test_xlRowField(ByRef num)

-Range("A424").Clear

-Range("B424").Clear

-Range("C424").Clear

-Range("D424").Clear

-Range("A424").Value = "xlRowField"

-Range("B424").Value = 1

-Range("C424").Value = num

-B424 = Range("B424").Value

-C424 = Range("C424").Value

-If B424 = C424 Then

-Range("D424").Value = "OK"

-Else

-Range("D424").Value = "NG"

-End If

-End Function

-

-Function test_xlPTClassic(ByRef num)

-Range("A425").Clear

-Range("B425").Clear

-Range("C425").Clear

-Range("D425").Clear

-Range("A425").Value = "xlPTClassic"

-Range("B425").Value = 20

-Range("C425").Value = num

-B425 = Range("B425").Value

-C425 = Range("C425").Value

-If B425 = C425 Then

-Range("D425").Value = "OK"

-Else

-Range("D425").Value = "NG"

-End If

-End Function

-

-Function test_xlPTNone(ByRef num)

-Range("A426").Clear

-Range("B426").Clear

-Range("C426").Clear

-Range("D426").Clear

-Range("A426").Value = "xlPTNone"

-Range("B426").Value = 21

-Range("C426").Value = num

-B426 = Range("B426").Value

-C426 = Range("C426").Value

-If B426 = C426 Then

-Range("D426").Value = "OK"

-Else

-Range("D426").Value = "NG"

-End If

-End Function

-

-Function test_xlReport1(ByRef num)

-Range("A427").Clear

-Range("B427").Clear

-Range("C427").Clear

-Range("D427").Clear

-Range("A427").Value = "xlReport1"

-Range("B427").Value = 0

-Range("C427").Value = num

-B427 = Range("B427").Value

-C427 = Range("C427").Value

-If B427 = C427 Then

-Range("D427").Value = "OK"

-Else

-Range("D427").Value = "NG"

-End If

-End Function

-

-Function test_xlReport10(ByRef num)

-Range("A428").Clear

-Range("B428").Clear

-Range("C428").Clear

-Range("D428").Clear

-Range("A428").Value = "xlReport10"

-Range("B428").Value = 9

-Range("C428").Value = num

-B428 = Range("B428").Value

-C428 = Range("C428").Value

-If B428 = C428 Then

-Range("D428").Value = "OK"

-Else

-Range("D428").Value = "NG"

-End If

-End Function

-

-Function test_xlReport2(ByRef num)

-Range("A429").Clear

-Range("B429").Clear

-Range("C429").Clear

-Range("D429").Clear

-Range("A429").Value = "xlReport2"

-Range("B429").Value = 1

-Range("C429").Value = num

-B429 = Range("B429").Value

-C429 = Range("C429").Value

-If B429 = C429 Then

-Range("D429").Value = "OK"

-Else

-Range("D429").Value = "NG"

-End If

-End Function

-

-Function test_xlReport3(ByRef num)

-Range("A430").Clear

-Range("B430").Clear

-Range("C430").Clear

-Range("D430").Clear

-Range("A430").Value = "xlReport3"

-Range("B430").Value = 2

-Range("C430").Value = num

-B430 = Range("B430").Value

-C430 = Range("C430").Value

-If B430 = C430 Then

-Range("D430").Value = "OK"

-Else

-Range("D430").Value = "NG"

-End If

-End Function

-

-Function test_xlReport4(ByRef num)

-Range("A431").Clear

-Range("B431").Clear

-Range("C431").Clear

-Range("D431").Clear

-Range("A431").Value = "xlReport4"

-Range("B431").Value = 3

-Range("C431").Value = num

-B431 = Range("B431").Value

-C431 = Range("C431").Value

-If B431 = C431 Then

-Range("D431").Value = "OK"

-Else

-Range("D431").Value = "NG"

-End If

-End Function

-

-Function test_xlReport5(ByRef num)

-Range("A432").Clear

-Range("B432").Clear

-Range("C432").Clear

-Range("D432").Clear

-Range("A432").Value = "xlReport5"

-Range("B432").Value = 4

-Range("C432").Value = num

-B432 = Range("B432").Value

-C432 = Range("C432").Value

-If B432 = C432 Then

-Range("D432").Value = "OK"

-Else

-Range("D432").Value = "NG"

-End If

-End Function

-

-Function test_xlReport6(ByRef num)

-Range("A433").Clear

-Range("B433").Clear

-Range("C433").Clear

-Range("D433").Clear

-Range("A433").Value = "xlReport6"

-Range("B433").Value = 5

-Range("C433").Value = num

-B433 = Range("B433").Value

-C433 = Range("C433").Value

-If B433 = C433 Then

-Range("D433").Value = "OK"

-Else

-Range("D433").Value = "NG"

-End If

-End Function

-

-Function test_xlReport7(ByRef num)

-Range("A434").Clear

-Range("B434").Clear

-Range("C434").Clear

-Range("D434").Clear

-Range("A434").Value = "xlReport7"

-Range("B434").Value = 6

-Range("C434").Value = num

-B434 = Range("B434").Value

-C434 = Range("C434").Value

-If B434 = C434 Then

-Range("D434").Value = "OK"

-Else

-Range("D434").Value = "NG"

-End If

-End Function

-

-Function test_xlReport8(ByRef num)

-Range("A435").Clear

-Range("B435").Clear

-Range("C435").Clear

-Range("D435").Clear

-Range("A435").Value = "xlReport8"

-Range("B435").Value = 7

-Range("C435").Value = num

-B435 = Range("B435").Value

-C435 = Range("C435").Value

-If B435 = C435 Then

-Range("D435").Value = "OK"

-Else

-Range("D435").Value = "NG"

-End If

-End Function

-

-Function test_xlReport9(ByRef num)

-Range("A436").Clear

-Range("B436").Clear

-Range("C436").Clear

-Range("D436").Clear

-Range("A436").Value = "xlReport9"

-Range("B436").Value = 8

-Range("C436").Value = num

-B436 = Range("B436").Value

-C436 = Range("C436").Value

-If B436 = C436 Then

-Range("D436").Value = "OK"

-Else

-Range("D436").Value = "NG"

-End If

-End Function

-

-Function test_xlTable1(ByRef num)

-Range("A437").Clear

-Range("B437").Clear

-Range("C437").Clear

-Range("D437").Clear

-Range("A437").Value = "xlTable1"

-Range("B437").Value = 10

-Range("C437").Value = num

-B437 = Range("B437").Value

-C437 = Range("C437").Value

-If B437 = C437 Then

-Range("D437").Value = "OK"

-Else

-Range("D437").Value = "NG"

-End If

-End Function

-

-Function test_xlTable10(ByRef num)

-Range("A438").Clear

-Range("B438").Clear

-Range("C438").Clear

-Range("D438").Clear

-Range("A438").Value = "xlTable10"

-Range("B438").Value = 19

-Range("C438").Value = num

-B438 = Range("B438").Value

-C438 = Range("C438").Value

-If B438 = C438 Then

-Range("D438").Value = "OK"

-Else

-Range("D438").Value = "NG"

-End If

-End Function

-

-Function test_xlTable2(ByRef num)

-Range("A439").Clear

-Range("B439").Clear

-Range("C439").Clear

-Range("D439").Clear

-Range("A439").Value = "xlTable2"

-Range("B439").Value = 11

-Range("C439").Value = num

-B439 = Range("B439").Value

-C439 = Range("C439").Value

-If B439 = C439 Then

-Range("D439").Value = "OK"

-Else

-Range("D439").Value = "NG"

-End If

-End Function

-

-Function test_xlTable3(ByRef num)

-Range("A440").Clear

-Range("B440").Clear

-Range("C440").Clear

-Range("D440").Clear

-Range("A440").Value = "xlTable3"

-Range("B440").Value = 12

-Range("C440").Value = num

-B440 = Range("B440").Value

-C440 = Range("C440").Value

-If B440 = C440 Then

-Range("D440").Value = "OK"

-Else

-Range("D440").Value = "NG"

-End If

-End Function

-

-Function test_xlTable4(ByRef num)

-Range("A441").Clear

-Range("B441").Clear

-Range("C441").Clear

-Range("D441").Clear

-Range("A441").Value = "xlTable4"

-Range("B441").Value = 13

-Range("C441").Value = num

-B441 = Range("B441").Value

-C441 = Range("C441").Value

-If B441 = C441 Then

-Range("D441").Value = "OK"

-Else

-Range("D441").Value = "NG"

-End If

-End Function

-

-Function test_xlTable5(ByRef num)

-Range("A442").Clear

-Range("B442").Clear

-Range("C442").Clear

-Range("D442").Clear

-Range("A442").Value = "xlTable5"

-Range("B442").Value = 14

-Range("C442").Value = num

-B442 = Range("B442").Value

-C442 = Range("C442").Value

-If B442 = C442 Then

-Range("D442").Value = "OK"

-Else

-Range("D442").Value = "NG"

-End If

-End Function

-

-Function test_xlTable6(ByRef num)

-Range("A443").Clear

-Range("B443").Clear

-Range("C443").Clear

-Range("D443").Clear

-Range("A443").Value = "xlTable6"

-Range("B443").Value = 15

-Range("C443").Value = num

-B443 = Range("B443").Value

-C443 = Range("C443").Value

-If B443 = C443 Then

-Range("D443").Value = "OK"

-Else

-Range("D443").Value = "NG"

-End If

-End Function

-

-Function test_xlTable7(ByRef num)

-Range("A444").Clear

-Range("B444").Clear

-Range("C444").Clear

-Range("D444").Clear

-Range("A444").Value = "xlTable7"

-Range("B444").Value = 16

-Range("C444").Value = num

-B444 = Range("B444").Value

-C444 = Range("C444").Value

-If B444 = C444 Then

-Range("D444").Value = "OK"

-Else

-Range("D444").Value = "NG"

-End If

-End Function

-

-Function test_xlTable8(ByRef num)

-Range("A445").Clear

-Range("B445").Clear

-Range("C445").Clear

-Range("D445").Clear

-Range("A445").Value = "xlTable8"

-Range("B445").Value = 17

-Range("C445").Value = num

-B445 = Range("B445").Value

-C445 = Range("C445").Value

-If B445 = C445 Then

-Range("D445").Value = "OK"

-Else

-Range("D445").Value = "NG"

-End If

-End Function

-

-Function test_xlTable9(ByRef num)

-Range("A446").Clear

-Range("B446").Clear

-Range("C446").Clear

-Range("D446").Clear

-Range("A446").Value = "xlTable9"

-Range("B446").Value = 18

-Range("C446").Value = num

-B446 = Range("B446").Value

-C446 = Range("C446").Value

-If B446 = C446 Then

-Range("D446").Value = "OK"

-Else

-Range("D446").Value = "NG"

-End If

-End Function

-

-Function test_xlMissingItemsDefault(ByRef num)

-Range("A447").Clear

-Range("B447").Clear

-Range("C447").Clear

-Range("D447").Clear

-Range("A447").Value = "xlMissingItemsDefault"

-Range("B447").Value = -1

-Range("C447").Value = num

-B447 = Range("B447").Value

-C447 = Range("C447").Value

-If B447 = C447 Then

-Range("D447").Value = "OK"

-Else

-Range("D447").Value = "NG"

-End If

-End Function

-

-Function test_xlMissingItemsMax(ByRef num)

-Range("A448").Clear

-Range("B448").Clear

-Range("C448").Clear

-Range("D448").Clear

-Range("A448").Value = "xlMissingItemsMax"

-Range("B448").Value = 32500

-Range("C448").Value = num

-B448 = Range("B448").Value

-C448 = Range("C448").Value

-If B448 = C448 Then

-Range("D448").Value = "OK"

-Else

-Range("D448").Value = "NG"

-End If

-End Function

-

-Function test_xlMissingItemsNone(ByRef num)

-Range("A449").Clear

-Range("B449").Clear

-Range("C449").Clear

-Range("D449").Clear

-Range("A449").Value = "xlMissingItemsNone"

-Range("B449").Value = 0

-Range("C449").Value = num

-B449 = Range("B449").Value

-C449 = Range("C449").Value

-If B449 = C449 Then

-Range("D449").Value = "OK"

-Else

-Range("D449").Value = "NG"

-End If

-End Function

-

-Function test_xlConsolidation(ByRef num)

-Range("A450").Clear

-Range("B450").Clear

-Range("C450").Clear

-Range("D450").Clear

-Range("A450").Value = "xlConsolidation"

-Range("B450").Value = 3

-Range("C450").Value = num

-B450 = Range("B450").Value

-C450 = Range("C450").Value

-If B450 = C450 Then

-Range("D450").Value = "OK"

-Else

-Range("D450").Value = "NG"

-End If

-End Function

-

-Function test_xlDatabase(ByRef num)

-Range("A451").Clear

-Range("B451").Clear

-Range("C451").Clear

-Range("D451").Clear

-Range("A451").Value = "xlDatabase"

-Range("B451").Value = 1

-Range("C451").Value = num

-B451 = Range("B451").Value

-C451 = Range("C451").Value

-If B451 = C451 Then

-Range("D451").Value = "OK"

-Else

-Range("D451").Value = "NG"

-End If

-End Function

-

-Function test_xlExternal(ByRef num)

-Range("A452").Clear

-Range("B452").Clear

-Range("C452").Clear

-Range("D452").Clear

-Range("A452").Value = "xlExternal"

-Range("B452").Value = 2

-Range("C452").Value = num

-B452 = Range("B452").Value

-C452 = Range("C452").Value

-If B452 = C452 Then

-Range("D452").Value = "OK"

-Else

-Range("D452").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotTable(ByRef num)

-Range("A453").Clear

-Range("B453").Clear

-Range("C453").Clear

-Range("D453").Clear

-Range("A453").Value = "xlPivotTable"

-Range("B453").Value = -4148

-Range("C453").Value = num

-B453 = Range("B453").Value

-C453 = Range("C453").Value

-If B453 = C453 Then

-Range("D453").Value = "OK"

-Else

-Range("D453").Value = "NG"

-End If

-End Function

-

-Function test_xlScenario(ByRef num)

-Range("A454").Clear

-Range("B454").Clear

-Range("C454").Clear

-Range("D454").Clear

-Range("A454").Value = "xlScenario"

-Range("B454").Value = 4

-Range("C454").Value = num

-B454 = Range("B454").Value

-C454 = Range("C454").Value

-If B454 = C454 Then

-Range("D454").Value = "OK"

-Else

-Range("D454").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotTableVersion10(ByRef num)

-Range("A455").Clear

-Range("B455").Clear

-Range("C455").Clear

-Range("D455").Clear

-Range("A455").Value = "xlPivotTableVersion10"

-Range("B455").Value = 1

-Range("C455").Value = num

-B455 = Range("B455").Value

-C455 = Range("C455").Value

-If B455 = C455 Then

-Range("D455").Value = "OK"

-Else

-Range("D455").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotTableVersion2000(ByRef num)

-Range("A456").Clear

-Range("B456").Clear

-Range("C456").Clear

-Range("D456").Clear

-Range("A456").Value = "xlPivotTableVersion2000"

-Range("B456").Value = 0

-Range("C456").Value = num

-B456 = Range("B456").Value

-C456 = Range("C456").Value

-If B456 = C456 Then

-Range("D456").Value = "OK"

-Else

-Range("D456").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotTableCurrent(ByRef num)

-Range("A457").Clear

-Range("B457").Clear

-Range("C457").Clear

-Range("D457").Clear

-Range("A457").Value = "xlPivotTableCurrent"

-Range("B457").Value = -1

-Range("C457").Value = num

-B457 = Range("B457").Value

-C457 = Range("C457").Value

-If B457 = C457 Then

-Range("D457").Value = "OK"

-Else

-Range("D457").Value = "NG"

-End If

-End Function

-

-Function test_xlFreeFloating(ByRef num)

-Range("A458").Clear

-Range("B458").Clear

-Range("C458").Clear

-Range("D458").Clear

-Range("A458").Value = "xlFreeFloating"

-Range("B458").Value = 3

-Range("C458").Value = num

-B458 = Range("B458").Value

-C458 = Range("C458").Value

-If B458 = C458 Then

-Range("D458").Value = "OK"

-Else

-Range("D458").Value = "NG"

-End If

-End Function

-

-Function test_xlMove(ByRef num)

-Range("A459").Clear

-Range("B459").Clear

-Range("C459").Clear

-Range("D459").Clear

-Range("A459").Value = "xlMove"

-Range("B459").Value = 2

-Range("C459").Value = num

-B459 = Range("B459").Value

-C459 = Range("C459").Value

-If B459 = C459 Then

-Range("D459").Value = "OK"

-Else

-Range("D459").Value = "NG"

-End If

-End Function

-

-Function test_xlMoveAndSize(ByRef num)

-Range("A460").Clear

-Range("B460").Clear

-Range("C460").Clear

-Range("D460").Clear

-Range("A460").Value = "xlMoveAndSize"

-Range("B460").Value = 1

-Range("C460").Value = num

-B460 = Range("B460").Value

-C460 = Range("C460").Value

-If B460 = C460 Then

-Range("D460").Value = "OK"

-Else

-Range("D460").Value = "NG"

-End If

-End Function

-

-Function test_xlMacintosh(ByRef num)

-Range("A461").Clear

-Range("B461").Clear

-Range("C461").Clear

-Range("D461").Clear

-Range("A461").Value = "xlMacintosh"

-Range("B461").Value = 1

-Range("C461").Value = num

-B461 = Range("B461").Value

-C461 = Range("C461").Value

-If B461 = C461 Then

-Range("D461").Value = "OK"

-Else

-Range("D461").Value = "NG"

-End If

-End Function

-

-Function test_xlMSDOS(ByRef num)

-Range("A462").Clear

-Range("B462").Clear

-Range("C462").Clear

-Range("D462").Clear

-Range("A462").Value = "xlMSDOS"

-Range("B462").Value = 3

-Range("C462").Value = num

-B462 = Range("B462").Value

-C462 = Range("C462").Value

-If B462 = C462 Then

-Range("D462").Value = "OK"

-Else

-Range("D462").Value = "NG"

-End If

-End Function

-

-Function test_xlWindows(ByRef num)

-Range("A463").Clear

-Range("B463").Clear

-Range("C463").Clear

-Range("D463").Clear

-Range("A463").Value = "xlWindows"

-Range("B463").Value = 2

-Range("C463").Value = num

-B463 = Range("B463").Value

-C463 = Range("C463").Value

-If B463 = C463 Then

-Range("D463").Value = "OK"

-Else

-Range("D463").Value = "NG"

-End If

-End Function

-

-Function test_xlPrintErrorsBlank(ByRef num)

-Range("A464").Clear

-Range("B464").Clear

-Range("C464").Clear

-Range("D464").Clear

-Range("A464").Value = "xlPrintErrorsBlank"

-Range("B464").Value = 1

-Range("C464").Value = num

-B464 = Range("B464").Value

-C464 = Range("C464").Value

-If B464 = C464 Then

-Range("D464").Value = "OK"

-Else

-Range("D464").Value = "NG"

-End If

-End Function

-

-Function test_xlPrintErrorsDash(ByRef num)

-Range("A465").Clear

-Range("B465").Clear

-Range("C465").Clear

-Range("D465").Clear

-Range("A465").Value = "xlPrintErrorsDash"

-Range("B465").Value = 2

-Range("C465").Value = num

-B465 = Range("B465").Value

-C465 = Range("C465").Value

-If B465 = C465 Then

-Range("D465").Value = "OK"

-Else

-Range("D465").Value = "NG"

-End If

-End Function

-

-Function test_xlPrintErrorsDisplayed(ByRef num)

-Range("A466").Clear

-Range("B466").Clear

-Range("C466").Clear

-Range("D466").Clear

-Range("A466").Value = "xlPrintErrorsDisplayed"

-Range("B466").Value = 0

-Range("C466").Value = num

-B466 = Range("B466").Value

-C466 = Range("C466").Value

-If B466 = C466 Then

-Range("D466").Value = "OK"

-Else

-Range("D466").Value = "NG"

-End If

-End Function

-

-Function test_xlPrintErrorsNA(ByRef num)

-Range("A467").Clear

-Range("B467").Clear

-Range("C467").Clear

-Range("D467").Clear

-Range("A467").Value = "xlPrintErrorsNA"

-Range("B467").Value = 3

-Range("C467").Value = num

-B467 = Range("B467").Value

-C467 = Range("C467").Value

-If B467 = C467 Then

-Range("D467").Value = "OK"

-Else

-Range("D467").Value = "NG"

-End If

-End Function

-

-Function test_xlPrintLocation(ByRef num)

-Range("A468").Clear

-Range("B468").Clear

-Range("C468").Clear

-Range("D468").Clear

-Range("A468").Value = "xlPrintLocation"

-Range("B468").Value = 16

-Range("C468").Value = num

-B468 = Range("B468").Value

-C468 = Range("C468").Value

-If B468 = C468 Then

-Range("D468").Value = "OK"

-Else

-Range("D468").Value = "NG"

-End If

-End Function

-

-Function test_xlPrintNoComments(ByRef num)

-Range("A469").Clear

-Range("B469").Clear

-Range("C469").Clear

-Range("D469").Clear

-Range("A469").Value = "xlPrintNoComments"

-Range("B469").Value = -4142

-Range("C469").Value = num

-B469 = Range("B469").Value

-C469 = Range("C469").Value

-If B469 = C469 Then

-Range("D469").Value = "OK"

-Else

-Range("D469").Value = "NG"

-End If

-End Function

-

-Function test_xlPrintSheetEnd(ByRef num)

-Range("A470").Clear

-Range("B470").Clear

-Range("C470").Clear

-Range("D470").Clear

-Range("A470").Value = "xlPrintSheetEnd"

-Range("B470").Value = 1

-Range("C470").Value = num

-B470 = Range("B470").Value

-C470 = Range("C470").Value

-If B470 = C470 Then

-Range("D470").Value = "OK"

-Else

-Range("D470").Value = "NG"

-End If

-End Function

-

-Function test_xlPriorityHigh(ByRef num)

-Range("A471").Clear

-Range("B471").Clear

-Range("C471").Clear

-Range("D471").Clear

-Range("A471").Value = "xlPriorityHigh"

-Range("B471").Value = -4127

-Range("C471").Value = num

-B471 = Range("B471").Value

-C471 = Range("C471").Value

-If B471 = C471 Then

-Range("D471").Value = "OK"

-Else

-Range("D471").Value = "NG"

-End If

-End Function

-

-Function test_xlPriorityLow(ByRef num)

-Range("A472").Clear

-Range("B472").Clear

-Range("C472").Clear

-Range("D472").Clear

-Range("A472").Value = "xlPriorityLow"

-Range("B472").Value = -4134

-Range("C472").Value = num

-B472 = Range("B472").Value

-C472 = Range("C472").Value

-If B472 = C472 Then

-Range("D472").Value = "OK"

-Else

-Range("D472").Value = "NG"

-End If

-End Function

-

-Function test_xlPriorityNormal(ByRef num)

-Range("A473").Clear

-Range("B473").Clear

-Range("C473").Clear

-Range("D473").Clear

-Range("A473").Value = "xlPriorityNormal"

-Range("B473").Value = -4143

-Range("C473").Value = num

-B473 = Range("B473").Value

-C473 = Range("C473").Value

-If B473 = C473 Then

-Range("D473").Value = "OK"

-Else

-Range("D473").Value = "NG"

-End If

-End Function

-

-Function test_xlADORecordset(ByRef num)

-Range("A474").Clear

-Range("B474").Clear

-Range("C474").Clear

-Range("D474").Clear

-Range("A474").Value = "xlADORecordset"

-Range("B474").Value = 7

-Range("C474").Value = num

-B474 = Range("B474").Value

-C474 = Range("C474").Value

-If B474 = C474 Then

-Range("D474").Value = "OK"

-Else

-Range("D474").Value = "NG"

-End If

-End Function

-

-Function test_xlDAORecordset(ByRef num)

-Range("A475").Clear

-Range("B475").Clear

-Range("C475").Clear

-Range("D475").Clear

-Range("A475").Value = "xlDAORecordset"

-Range("B475").Value = 2

-Range("C475").Value = num

-B475 = Range("B475").Value

-C475 = Range("C475").Value

-If B475 = C475 Then

-Range("D475").Value = "OK"

-Else

-Range("D475").Value = "NG"

-End If

-End Function

-

-Function test_xlODBCQuery(ByRef num)

-Range("A476").Clear

-Range("B476").Clear

-Range("C476").Clear

-Range("D476").Clear

-Range("A476").Value = "xlODBCQuery"

-Range("B476").Value = 1

-Range("C476").Value = num

-B476 = Range("B476").Value

-C476 = Range("C476").Value

-If B476 = C476 Then

-Range("D476").Value = "OK"

-Else

-Range("D476").Value = "NG"

-End If

-End Function

-

-Function test_xlOLEDBQuery(ByRef num)

-Range("A477").Clear

-Range("B477").Clear

-Range("C477").Clear

-Range("D477").Clear

-Range("A477").Value = "xlOLEDBQuery"

-Range("B477").Value = 5

-Range("C477").Value = num

-B477 = Range("B477").Value

-C477 = Range("C477").Value

-If B477 = C477 Then

-Range("D477").Value = "OK"

-Else

-Range("D477").Value = "NG"

-End If

-End Function

-

-Function test_xlTextImport(ByRef num)

-Range("A478").Clear

-Range("B478").Clear

-Range("C478").Clear

-Range("D478").Clear

-Range("A478").Value = "xlTextImport"

-Range("B478").Value = 6

-Range("C478").Value = num

-B478 = Range("B478").Value

-C478 = Range("C478").Value

-If B478 = C478 Then

-Range("D478").Value = "OK"

-Else

-Range("D478").Value = "NG"

-End If

-End Function

-

-Function test_xlWebQuery(ByRef num)

-Range("A479").Clear

-Range("B479").Clear

-Range("C479").Clear

-Range("D479").Clear

-Range("A479").Value = "xlWebQuery"

-Range("B479").Value = 4

-Range("C479").Value = num

-B479 = Range("B479").Value

-C479 = Range("C479").Value

-If B479 = C479 Then

-Range("D479").Value = "OK"

-Else

-Range("D479").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormat3DEffects1(ByRef num)

-Range("A480").Clear

-Range("B480").Clear

-Range("C480").Clear

-Range("D480").Clear

-Range("A480").Value = "xlRangeAutoFormat3DEffects1"

-Range("B480").Value = 13

-Range("C480").Value = num

-B480 = Range("B480").Value

-C480 = Range("C480").Value

-If B480 = C480 Then

-Range("D480").Value = "OK"

-Else

-Range("D480").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormat3DEffects2(ByRef num)

-Range("A481").Clear

-Range("B481").Clear

-Range("C481").Clear

-Range("D481").Clear

-Range("A481").Value = "xlRangeAutoFormat3DEffects2"

-Range("B481").Value = 14

-Range("C481").Value = num

-B481 = Range("B481").Value

-C481 = Range("C481").Value

-If B481 = C481 Then

-Range("D481").Value = "OK"

-Else

-Range("D481").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatAccounting1(ByRef num)

-Range("A482").Clear

-Range("B482").Clear

-Range("C482").Clear

-Range("D482").Clear

-Range("A482").Value = "xlRangeAutoFormatAccounting1"

-Range("B482").Value = 4

-Range("C482").Value = num

-B482 = Range("B482").Value

-C482 = Range("C482").Value

-If B482 = C482 Then

-Range("D482").Value = "OK"

-Else

-Range("D482").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatAccounting2(ByRef num)

-Range("A483").Clear

-Range("B483").Clear

-Range("C483").Clear

-Range("D483").Clear

-Range("A483").Value = "xlRangeAutoFormatAccounting2"

-Range("B483").Value = 5

-Range("C483").Value = num

-B483 = Range("B483").Value

-C483 = Range("C483").Value

-If B483 = C483 Then

-Range("D483").Value = "OK"

-Else

-Range("D483").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatAccounting3(ByRef num)

-Range("A484").Clear

-Range("B484").Clear

-Range("C484").Clear

-Range("D484").Clear

-Range("A484").Value = "xlRangeAutoFormatAccounting3"

-Range("B484").Value = 6

-Range("C484").Value = num

-B484 = Range("B484").Value

-C484 = Range("C484").Value

-If B484 = C484 Then

-Range("D484").Value = "OK"

-Else

-Range("D484").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatAccounting4(ByRef num)

-Range("A485").Clear

-Range("B485").Clear

-Range("C485").Clear

-Range("D485").Clear

-Range("A485").Value = "xlRangeAutoFormatAccounting4"

-Range("B485").Value = 17

-Range("C485").Value = num

-B485 = Range("B485").Value

-C485 = Range("C485").Value

-If B485 = C485 Then

-Range("D485").Value = "OK"

-Else

-Range("D485").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatClassic1(ByRef num)

-Range("A486").Clear

-Range("B486").Clear

-Range("C486").Clear

-Range("D486").Clear

-Range("A486").Value = "xlRangeAutoFormatClassic1"

-Range("B486").Value = 1

-Range("C486").Value = num

-B486 = Range("B486").Value

-C486 = Range("C486").Value

-If B486 = C486 Then

-Range("D486").Value = "OK"

-Else

-Range("D486").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatClassic2(ByRef num)

-Range("A487").Clear

-Range("B487").Clear

-Range("C487").Clear

-Range("D487").Clear

-Range("A487").Value = "xlRangeAutoFormatClassic2"

-Range("B487").Value = 2

-Range("C487").Value = num

-B487 = Range("B487").Value

-C487 = Range("C487").Value

-If B487 = C487 Then

-Range("D487").Value = "OK"

-Else

-Range("D487").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatClassic3(ByRef num)

-Range("A488").Clear

-Range("B488").Clear

-Range("C488").Clear

-Range("D488").Clear

-Range("A488").Value = "xlRangeAutoFormatClassic3"

-Range("B488").Value = 3

-Range("C488").Value = num

-B488 = Range("B488").Value

-C488 = Range("C488").Value

-If B488 = C488 Then

-Range("D488").Value = "OK"

-Else

-Range("D488").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatClassicPivotTable(ByRef num)

-Range("A489").Clear

-Range("B489").Clear

-Range("C489").Clear

-Range("D489").Clear

-Range("A489").Value = "xlRangeAutoFormatClassicPivotTable"

-Range("B489").Value = 31

-Range("C489").Value = num

-B489 = Range("B489").Value

-C489 = Range("C489").Value

-If B489 = C489 Then

-Range("D489").Value = "OK"

-Else

-Range("D489").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatColor1(ByRef num)

-Range("A490").Clear

-Range("B490").Clear

-Range("C490").Clear

-Range("D490").Clear

-Range("A490").Value = "xlRangeAutoFormatColor1"

-Range("B490").Value = 7

-Range("C490").Value = num

-B490 = Range("B490").Value

-C490 = Range("C490").Value

-If B490 = C490 Then

-Range("D490").Value = "OK"

-Else

-Range("D490").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatColor2(ByRef num)

-Range("A491").Clear

-Range("B491").Clear

-Range("C491").Clear

-Range("D491").Clear

-Range("A491").Value = "xlRangeAutoFormatColor2"

-Range("B491").Value = 8

-Range("C491").Value = num

-B491 = Range("B491").Value

-C491 = Range("C491").Value

-If B491 = C491 Then

-Range("D491").Value = "OK"

-Else

-Range("D491").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatColor3(ByRef num)

-Range("A492").Clear

-Range("B492").Clear

-Range("C492").Clear

-Range("D492").Clear

-Range("A492").Value = "xlRangeAutoFormatColor3"

-Range("B492").Value = 9

-Range("C492").Value = num

-B492 = Range("B492").Value

-C492 = Range("C492").Value

-If B492 = C492 Then

-Range("D492").Value = "OK"

-Else

-Range("D492").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatList1(ByRef num)

-Range("A493").Clear

-Range("B493").Clear

-Range("C493").Clear

-Range("D493").Clear

-Range("A493").Value = "xlRangeAutoFormatList1"

-Range("B493").Value = 10

-Range("C493").Value = num

-B493 = Range("B493").Value

-C493 = Range("C493").Value

-If B493 = C493 Then

-Range("D493").Value = "OK"

-Else

-Range("D493").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatList2(ByRef num)

-Range("A494").Clear

-Range("B494").Clear

-Range("C494").Clear

-Range("D494").Clear

-Range("A494").Value = "xlRangeAutoFormatList2"

-Range("B494").Value = 11

-Range("C494").Value = num

-B494 = Range("B494").Value

-C494 = Range("C494").Value

-If B494 = C494 Then

-Range("D494").Value = "OK"

-Else

-Range("D494").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatList3(ByRef num)

-Range("A495").Clear

-Range("B495").Clear

-Range("C495").Clear

-Range("D495").Clear

-Range("A495").Value = "xlRangeAutoFormatList3"

-Range("B495").Value = 12

-Range("C495").Value = num

-B495 = Range("B495").Value

-C495 = Range("C495").Value

-If B495 = C495 Then

-Range("D495").Value = "OK"

-Else

-Range("D495").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatLocalFormat1(ByRef num)

-Range("A496").Clear

-Range("B496").Clear

-Range("C496").Clear

-Range("D496").Clear

-Range("A496").Value = "xlRangeAutoFormatLocalFormat1"

-Range("B496").Value = 15

-Range("C496").Value = num

-B496 = Range("B496").Value

-C496 = Range("C496").Value

-If B496 = C496 Then

-Range("D496").Value = "OK"

-Else

-Range("D496").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatLocalFormat2(ByRef num)

-Range("A497").Clear

-Range("B497").Clear

-Range("C497").Clear

-Range("D497").Clear

-Range("A497").Value = "xlRangeAutoFormatLocalFormat2"

-Range("B497").Value = 16

-Range("C497").Value = num

-B497 = Range("B497").Value

-C497 = Range("C497").Value

-If B497 = C497 Then

-Range("D497").Value = "OK"

-Else

-Range("D497").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatLocalFormat3(ByRef num)

-Range("A498").Clear

-Range("B498").Clear

-Range("C498").Clear

-Range("D498").Clear

-Range("A498").Value = "xlRangeAutoFormatLocalFormat3"

-Range("B498").Value = 19

-Range("C498").Value = num

-B498 = Range("B498").Value

-C498 = Range("C498").Value

-If B498 = C498 Then

-Range("D498").Value = "OK"

-Else

-Range("D498").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatLocalFormat4(ByRef num)

-Range("A499").Clear

-Range("B499").Clear

-Range("C499").Clear

-Range("D499").Clear

-Range("A499").Value = "xlRangeAutoFormatLocalFormat4"

-Range("B499").Value = 20

-Range("C499").Value = num

-B499 = Range("B499").Value

-C499 = Range("C499").Value

-If B499 = C499 Then

-Range("D499").Value = "OK"

-Else

-Range("D499").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatNone(ByRef num)

-Range("A500").Clear

-Range("B500").Clear

-Range("C500").Clear

-Range("D500").Clear

-Range("A500").Value = "xlRangeAutoFormatNone"

-Range("B500").Value = -4142

-Range("C500").Value = num

-B500 = Range("B500").Value

-C500 = Range("C500").Value

-If B500 = C500 Then

-Range("D500").Value = "OK"

-Else

-Range("D500").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatPTNone(ByRef num)

-Range("A501").Clear

-Range("B501").Clear

-Range("C501").Clear

-Range("D501").Clear

-Range("A501").Value = "xlRangeAutoFormatPTNone"

-Range("B501").Value = 42

-Range("C501").Value = num

-B501 = Range("B501").Value

-C501 = Range("C501").Value

-If B501 = C501 Then

-Range("D501").Value = "OK"

-Else

-Range("D501").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatReport1(ByRef num)

-Range("A502").Clear

-Range("B502").Clear

-Range("C502").Clear

-Range("D502").Clear

-Range("A502").Value = "xlRangeAutoFormatReport1"

-Range("B502").Value = 21

-Range("C502").Value = num

-B502 = Range("B502").Value

-C502 = Range("C502").Value

-If B502 = C502 Then

-Range("D502").Value = "OK"

-Else

-Range("D502").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatReport10(ByRef num)

-Range("A503").Clear

-Range("B503").Clear

-Range("C503").Clear

-Range("D503").Clear

-Range("A503").Value = "xlRangeAutoFormatReport10"

-Range("B503").Value = 30

-Range("C503").Value = num

-B503 = Range("B503").Value

-C503 = Range("C503").Value

-If B503 = C503 Then

-Range("D503").Value = "OK"

-Else

-Range("D503").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatReport2(ByRef num)

-Range("A504").Clear

-Range("B504").Clear

-Range("C504").Clear

-Range("D504").Clear

-Range("A504").Value = "xlRangeAutoFormatReport2"

-Range("B504").Value = 22

-Range("C504").Value = num

-B504 = Range("B504").Value

-C504 = Range("C504").Value

-If B504 = C504 Then

-Range("D504").Value = "OK"

-Else

-Range("D504").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatReport3(ByRef num)

-Range("A505").Clear

-Range("B505").Clear

-Range("C505").Clear

-Range("D505").Clear

-Range("A505").Value = "xlRangeAutoFormatReport3"

-Range("B505").Value = 23

-Range("C505").Value = num

-B505 = Range("B505").Value

-C505 = Range("C505").Value

-If B505 = C505 Then

-Range("D505").Value = "OK"

-Else

-Range("D505").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatReport4(ByRef num)

-Range("A506").Clear

-Range("B506").Clear

-Range("C506").Clear

-Range("D506").Clear

-Range("A506").Value = "xlRangeAutoFormatReport4"

-Range("B506").Value = 24

-Range("C506").Value = num

-B506 = Range("B506").Value

-C506 = Range("C506").Value

-If B506 = C506 Then

-Range("D506").Value = "OK"

-Else

-Range("D506").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatReport5(ByRef num)

-Range("A507").Clear

-Range("B507").Clear

-Range("C507").Clear

-Range("D507").Clear

-Range("A507").Value = "xlRangeAutoFormatReport5"

-Range("B507").Value = 25

-Range("C507").Value = num

-B507 = Range("B507").Value

-C507 = Range("C507").Value

-If B507 = C507 Then

-Range("D507").Value = "OK"

-Else

-Range("D507").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatReport6(ByRef num)

-Range("A508").Clear

-Range("B508").Clear

-Range("C508").Clear

-Range("D508").Clear

-Range("A508").Value = "xlRangeAutoFormatReport6"

-Range("B508").Value = 26

-Range("C508").Value = num

-B508 = Range("B508").Value

-C508 = Range("C508").Value

-If B508 = C508 Then

-Range("D508").Value = "OK"

-Else

-Range("D508").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatReport7(ByRef num)

-Range("A509").Clear

-Range("B509").Clear

-Range("C509").Clear

-Range("D509").Clear

-Range("A509").Value = "xlRangeAutoFormatReport7"

-Range("B509").Value = 27

-Range("C509").Value = num

-B509 = Range("B509").Value

-C509 = Range("C509").Value

-If B509 = C509 Then

-Range("D509").Value = "OK"

-Else

-Range("D509").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatReport8(ByRef num)

-Range("A510").Clear

-Range("B510").Clear

-Range("C510").Clear

-Range("D510").Clear

-Range("A510").Value = "xlRangeAutoFormatReport8"

-Range("B510").Value = 28

-Range("C510").Value = num

-B510 = Range("B510").Value

-C510 = Range("C510").Value

-If B510 = C510 Then

-Range("D510").Value = "OK"

-Else

-Range("D510").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatReport9(ByRef num)

-Range("A511").Clear

-Range("B511").Clear

-Range("C511").Clear

-Range("D511").Clear

-Range("A511").Value = "xlRangeAutoFormatReport9"

-Range("B511").Value = 29

-Range("C511").Value = num

-B511 = Range("B511").Value

-C511 = Range("C511").Value

-If B511 = C511 Then

-Range("D511").Value = "OK"

-Else

-Range("D511").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatSimple(ByRef num)

-Range("A512").Clear

-Range("B512").Clear

-Range("C512").Clear

-Range("D512").Clear

-Range("A512").Value = "xlRangeAutoFormatSimple"

-Range("B512").Value = -4154

-Range("C512").Value = num

-B512 = Range("B512").Value

-C512 = Range("C512").Value

-If B512 = C512 Then

-Range("D512").Value = "OK"

-Else

-Range("D512").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatTable1(ByRef num)

-Range("A513").Clear

-Range("B513").Clear

-Range("C513").Clear

-Range("D513").Clear

-Range("A513").Value = "xlRangeAutoFormatTable1"

-Range("B513").Value = 32

-Range("C513").Value = num

-B513 = Range("B513").Value

-C513 = Range("C513").Value

-If B513 = C513 Then

-Range("D513").Value = "OK"

-Else

-Range("D513").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatTable10(ByRef num)

-Range("A514").Clear

-Range("B514").Clear

-Range("C514").Clear

-Range("D514").Clear

-Range("A514").Value = "xlRangeAutoFormatTable10"

-Range("B514").Value = 41

-Range("C514").Value = num

-B514 = Range("B514").Value

-C514 = Range("C514").Value

-If B514 = C514 Then

-Range("D514").Value = "OK"

-Else

-Range("D514").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatTable2(ByRef num)

-Range("A515").Clear

-Range("B515").Clear

-Range("C515").Clear

-Range("D515").Clear

-Range("A515").Value = "xlRangeAutoFormatTable2"

-Range("B515").Value = 33

-Range("C515").Value = num

-B515 = Range("B515").Value

-C515 = Range("C515").Value

-If B515 = C515 Then

-Range("D515").Value = "OK"

-Else

-Range("D515").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatTable3(ByRef num)

-Range("A516").Clear

-Range("B516").Clear

-Range("C516").Clear

-Range("D516").Clear

-Range("A516").Value = "xlRangeAutoFormatTable3"

-Range("B516").Value = 34

-Range("C516").Value = num

-B516 = Range("B516").Value

-C516 = Range("C516").Value

-If B516 = C516 Then

-Range("D516").Value = "OK"

-Else

-Range("D516").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatTable4(ByRef num)

-Range("A517").Clear

-Range("B517").Clear

-Range("C517").Clear

-Range("D517").Clear

-Range("A517").Value = "xlRangeAutoFormatTable4"

-Range("B517").Value = 35

-Range("C517").Value = num

-B517 = Range("B517").Value

-C517 = Range("C517").Value

-If B517 = C517 Then

-Range("D517").Value = "OK"

-Else

-Range("D517").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatTable5(ByRef num)

-Range("A518").Clear

-Range("B518").Clear

-Range("C518").Clear

-Range("D518").Clear

-Range("A518").Value = "xlRangeAutoFormatTable5"

-Range("B518").Value = 36

-Range("C518").Value = num

-B518 = Range("B518").Value

-C518 = Range("C518").Value

-If B518 = C518 Then

-Range("D518").Value = "OK"

-Else

-Range("D518").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatTable6(ByRef num)

-Range("A519").Clear

-Range("B519").Clear

-Range("C519").Clear

-Range("D519").Clear

-Range("A519").Value = "xlRangeAutoFormatTable6"

-Range("B519").Value = 37

-Range("C519").Value = num

-B519 = Range("B519").Value

-C519 = Range("C519").Value

-If B519 = C519 Then

-Range("D519").Value = "OK"

-Else

-Range("D519").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatTable7(ByRef num)

-Range("A520").Clear

-Range("B520").Clear

-Range("C520").Clear

-Range("D520").Clear

-Range("A520").Value = "xlRangeAutoFormatTable7"

-Range("B520").Value = 38

-Range("C520").Value = num

-B520 = Range("B520").Value

-C520 = Range("C520").Value

-If B520 = C520 Then

-Range("D520").Value = "OK"

-Else

-Range("D520").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatTable8(ByRef num)

-Range("A521").Clear

-Range("B521").Clear

-Range("C521").Clear

-Range("D521").Clear

-Range("A521").Value = "xlRangeAutoFormatTable8"

-Range("B521").Value = 39

-Range("C521").Value = num

-B521 = Range("B521").Value

-C521 = Range("C521").Value

-If B521 = C521 Then

-Range("D521").Value = "OK"

-Else

-Range("D521").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatTable9(ByRef num)

-Range("A522").Clear

-Range("B522").Clear

-Range("C522").Clear

-Range("D522").Clear

-Range("A522").Value = "xlRangeAutoFormatTable9"

-Range("B522").Value = 40

-Range("C522").Value = num

-B522 = Range("B522").Value

-C522 = Range("C522").Value

-If B522 = C522 Then

-Range("D522").Value = "OK"

-Else

-Range("D522").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeValueDefault(ByRef num)

-Range("A523").Clear

-Range("B523").Clear

-Range("C523").Clear

-Range("D523").Clear

-Range("A523").Value = "xlRangeValueDefault"

-Range("B523").Value = 10

-Range("C523").Value = num

-B523 = Range("B523").Value

-C523 = Range("C523").Value

-If B523 = C523 Then

-Range("D523").Value = "OK"

-Else

-Range("D523").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeValueMSPersistXML(ByRef num)

-Range("A524").Clear

-Range("B524").Clear

-Range("C524").Clear

-Range("D524").Clear

-Range("A524").Value = "xlRangeValueMSPersistXML"

-Range("B524").Value = 12

-Range("C524").Value = num

-B524 = Range("B524").Value

-C524 = Range("C524").Value

-If B524 = C524 Then

-Range("D524").Value = "OK"

-Else

-Range("D524").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeValueXMLSpreadsheet(ByRef num)

-Range("A525").Clear

-Range("B525").Clear

-Range("C525").Clear

-Range("D525").Clear

-Range("A525").Value = "xlRangeValueXMLSpreadsheet"

-Range("B525").Value = 11

-Range("C525").Value = num

-B525 = Range("B525").Value

-C525 = Range("C525").Value

-If B525 = C525 Then

-Range("D525").Value = "OK"

-Else

-Range("D525").Value = "NG"

-End If

-End Function

-

-Function test_xlA1(ByRef num)

-Range("A526").Clear

-Range("B526").Clear

-Range("C526").Clear

-Range("D526").Clear

-Range("A526").Value = "xlA1"

-Range("B526").Value = 1

-Range("C526").Value = num

-B526 = Range("B526").Value

-C526 = Range("C526").Value

-If B526 = C526 Then

-Range("D526").Value = "OK"

-Else

-Range("D526").Value = "NG"

-End If

-End Function

-

-Function test_xlR1C1(ByRef num)

-Range("A527").Clear

-Range("B527").Clear

-Range("C527").Clear

-Range("D527").Clear

-Range("A527").Value = "xlR1C1"

-Range("B527").Value = -4150

-Range("C527").Value = num

-B527 = Range("B527").Value

-C527 = Range("C527").Value

-If B527 = C527 Then

-Range("D527").Value = "OK"

-Else

-Range("D527").Value = "NG"

-End If

-End Function

-

-Function test_xlAbsolute(ByRef num)

-Range("A528").Clear

-Range("B528").Clear

-Range("C528").Clear

-Range("D528").Clear

-Range("A528").Value = "xlAbsolute"

-Range("B528").Value = 1

-Range("C528").Value = num

-B528 = Range("B528").Value

-C528 = Range("C528").Value

-If B528 = C528 Then

-Range("D528").Value = "OK"

-Else

-Range("D528").Value = "NG"

-End If

-End Function

-

-Function test_xlAbsRowRelColumn(ByRef num)

-Range("A529").Clear

-Range("B529").Clear

-Range("C529").Clear

-Range("D529").Clear

-Range("A529").Value = "xlAbsRowRelColumn"

-Range("B529").Value = 2

-Range("C529").Value = num

-B529 = Range("B529").Value

-C529 = Range("C529").Value

-If B529 = C529 Then

-Range("D529").Value = "OK"

-Else

-Range("D529").Value = "NG"

-End If

-End Function

-

-Function test_xlRelative(ByRef num)

-Range("A530").Clear

-Range("B530").Clear

-Range("C530").Clear

-Range("D530").Clear

-Range("A530").Value = "xlRelative"

-Range("B530").Value = 4

-Range("C530").Value = num

-B530 = Range("B530").Value

-C530 = Range("C530").Value

-If B530 = C530 Then

-Range("D530").Value = "OK"

-Else

-Range("D530").Value = "NG"

-End If

-End Function

-

-Function test_xlRelRowAbsColumn(ByRef num)

-Range("A531").Clear

-Range("B531").Clear

-Range("C531").Clear

-Range("D531").Clear

-Range("A531").Value = "xlRelRowAbsColumn"

-Range("B531").Value = 3

-Range("C531").Value = num

-B531 = Range("B531").Value

-C531 = Range("C531").Value

-If B531 = C531 Then

-Range("D531").Value = "OK"

-Else

-Range("D531").Value = "NG"

-End If

-End Function

-

-Function test_xlAlways(ByRef num)

-Range("A532").Clear

-Range("B532").Clear

-Range("C532").Clear

-Range("D532").Clear

-Range("A532").Value = "xlAlways"

-Range("B532").Value = 1

-Range("C532").Value = num

-B532 = Range("B532").Value

-C532 = Range("C532").Value

-If B532 = C532 Then

-Range("D532").Value = "OK"

-Else

-Range("D532").Value = "NG"

-End If

-End Function

-

-Function test_xlAsRequired(ByRef num)

-Range("A533").Clear

-Range("B533").Clear

-Range("C533").Clear

-Range("D533").Clear

-Range("A533").Value = "xlAsRequired"

-Range("B533").Value = 0

-Range("C533").Value = num

-B533 = Range("B533").Value

-C533 = Range("C533").Value

-If B533 = C533 Then

-Range("D533").Value = "OK"

-Else

-Range("D533").Value = "NG"

-End If

-End Function

-

-Function test_xlNever(ByRef num)

-Range("A534").Clear

-Range("B534").Clear

-Range("C534").Clear

-Range("D534").Clear

-Range("A534").Value = "xlNever"

-Range("B534").Value = 2

-Range("C534").Value = num

-B534 = Range("B534").Value

-C534 = Range("C534").Value

-If B534 = C534 Then

-Range("D534").Value = "OK"

-Else

-Range("D534").Value = "NG"

-End If

-End Function

-

-Function test_xlAllAtOnce(ByRef num)

-Range("A535").Clear

-Range("B535").Clear

-Range("C535").Clear

-Range("D535").Clear

-Range("A535").Value = "xlAllAtOnce"

-Range("B535").Value = 2

-Range("C535").Value = num

-B535 = Range("B535").Value

-C535 = Range("C535").Value

-If B535 = C535 Then

-Range("D535").Value = "OK"

-Else

-Range("D535").Value = "NG"

-End If

-End Function

-

-Function test_xlOneAfterAnother(ByRef num)

-Range("A536").Clear

-Range("B536").Clear

-Range("C536").Clear

-Range("D536").Clear

-Range("A536").Value = "xlOneAfterAnother"

-Range("B536").Value = 1

-Range("C536").Value = num

-B536 = Range("B536").Value

-C536 = Range("C536").Value

-If B536 = C536 Then

-Range("D536").Value = "OK"

-Else

-Range("D536").Value = "NG"

-End If

-End Function

-

-Function test_xlNotYetRouted(ByRef num)

-Range("A537").Clear

-Range("B537").Clear

-Range("C537").Clear

-Range("D537").Clear

-Range("A537").Value = "xlNotYetRouted"

-Range("B537").Value = 0

-Range("C537").Value = num

-B537 = Range("B537").Value

-C537 = Range("C537").Value

-If B537 = C537 Then

-Range("D537").Value = "OK"

-Else

-Range("D537").Value = "NG"

-End If

-End Function

-

-Function test_xlRoutingComplete(ByRef num)

-Range("A538").Clear

-Range("B538").Clear

-Range("C538").Clear

-Range("D538").Clear

-Range("A538").Value = "xlRoutingComplete"

-Range("B538").Value = 2

-Range("C538").Value = num

-B538 = Range("B538").Value

-C538 = Range("C538").Value

-If B538 = C538 Then

-Range("D538").Value = "OK"

-Else

-Range("D538").Value = "NG"

-End If

-End Function

-

-Function test_xlRoutingInProgress(ByRef num)

-Range("A539").Clear

-Range("B539").Clear

-Range("C539").Clear

-Range("D539").Clear

-Range("A539").Value = "xlRoutingInProgress"

-Range("B539").Value = 1

-Range("C539").Value = num

-B539 = Range("B539").Value

-C539 = Range("C539").Value

-If B539 = C539 Then

-Range("D539").Value = "OK"

-Else

-Range("D539").Value = "NG"

-End If

-End Function

-

-Function test_xlColumns(ByRef num)

-Range("A540").Clear

-Range("B540").Clear

-Range("C540").Clear

-Range("D540").Clear

-Range("A540").Value = "xlColumns"

-Range("B540").Value = 2

-Range("C540").Value = num

-B540 = Range("B540").Value

-C540 = Range("C540").Value

-If B540 = C540 Then

-Range("D540").Value = "OK"

-Else

-Range("D540").Value = "NG"

-End If

-End Function

-

-Function test_xlRows(ByRef num)

-Range("A541").Clear

-Range("B541").Clear

-Range("C541").Clear

-Range("D541").Clear

-Range("A541").Value = "xlRows"

-Range("B541").Value = 1

-Range("C541").Value = num

-B541 = Range("B541").Value

-C541 = Range("C541").Value

-If B541 = C541 Then

-Range("D541").Value = "OK"

-Else

-Range("D541").Value = "NG"

-End If

-End Function

-

-Function test_xlAutoActivate(ByRef num)

-Range("A542").Clear

-Range("B542").Clear

-Range("C542").Clear

-Range("D542").Clear

-Range("A542").Value = "xlAutoActivate"

-Range("B542").Value = 3

-Range("C542").Value = num

-B542 = Range("B542").Value

-C542 = Range("C542").Value

-If B542 = C542 Then

-Range("D542").Value = "OK"

-Else

-Range("D542").Value = "NG"

-End If

-End Function

-

-Function test_xlAutoClose(ByRef num)

-Range("A543").Clear

-Range("B543").Clear

-Range("C543").Clear

-Range("D543").Clear

-Range("A543").Value = "xlAutoClose"

-Range("B543").Value = 2

-Range("C543").Value = num

-B543 = Range("B543").Value

-C543 = Range("C543").Value

-If B543 = C543 Then

-Range("D543").Value = "OK"

-Else

-Range("D543").Value = "NG"

-End If

-End Function

-

-Function test_xlAutoDeactivate(ByRef num)

-Range("A544").Clear

-Range("B544").Clear

-Range("C544").Clear

-Range("D544").Clear

-Range("A544").Value = "xlAutoDeactivate"

-Range("B544").Value = 4

-Range("C544").Value = num

-B544 = Range("B544").Value

-C544 = Range("C544").Value

-If B544 = C544 Then

-Range("D544").Value = "OK"

-Else

-Range("D544").Value = "NG"

-End If

-End Function

-

-Function test_xlAutoOpen(ByRef num)

-Range("A545").Clear

-Range("B545").Clear

-Range("C545").Clear

-Range("D545").Clear

-Range("A545").Value = "xlAutoOpen"

-Range("B545").Value = 1

-Range("C545").Value = num

-B545 = Range("B545").Value

-C545 = Range("C545").Value

-If B545 = C545 Then

-Range("D545").Value = "OK"

-Else

-Range("D545").Value = "NG"

-End If

-End Function

-

-Function test_xlDoNotSaveChanges(ByRef num)

-Range("A546").Clear

-Range("B546").Clear

-Range("C546").Clear

-Range("D546").Clear

-Range("A546").Value = "xlDoNotSaveChanges"

-Range("B546").Value = 2

-Range("C546").Value = num

-B546 = Range("B546").Value

-C546 = Range("C546").Value

-If B546 = C546 Then

-Range("D546").Value = "OK"

-Else

-Range("D546").Value = "NG"

-End If

-End Function

-

-Function test_xlSaveChanges(ByRef num)

-Range("A547").Clear

-Range("B547").Clear

-Range("C547").Clear

-Range("D547").Clear

-Range("A547").Value = "xlSaveChanges"

-Range("B547").Value = 1

-Range("C547").Value = num

-B547 = Range("B547").Value

-C547 = Range("C547").Value

-If B547 = C547 Then

-Range("D547").Value = "OK"

-Else

-Range("D547").Value = "NG"

-End If

-End Function

-

-Function test_xlExclusive(ByRef num)

-Range("A548").Clear

-Range("B548").Clear

-Range("C548").Clear

-Range("D548").Clear

-Range("A548").Value = "xlExclusive"

-Range("B548").Value = 3

-Range("C548").Value = num

-B548 = Range("B548").Value

-C548 = Range("C548").Value

-If B548 = C548 Then

-Range("D548").Value = "OK"

-Else

-Range("D548").Value = "NG"

-End If

-End Function

-

-Function test_xlNoChange(ByRef num)

-Range("A549").Clear

-Range("B549").Clear

-Range("C549").Clear

-Range("D549").Clear

-Range("A549").Value = "xlNoChange"

-Range("B549").Value = 1

-Range("C549").Value = num

-B549 = Range("B549").Value

-C549 = Range("C549").Value

-If B549 = C549 Then

-Range("D549").Value = "OK"

-Else

-Range("D549").Value = "NG"

-End If

-End Function

-

-Function test_xlShared(ByRef num)

-Range("A550").Clear

-Range("B550").Clear

-Range("C550").Clear

-Range("D550").Clear

-Range("A550").Value = "xlShared"

-Range("B550").Value = 2

-Range("C550").Value = num

-B550 = Range("B550").Value

-C550 = Range("C550").Value

-If B550 = C550 Then

-Range("D550").Value = "OK"

-Else

-Range("D550").Value = "NG"

-End If

-End Function

-

-Function test_xlLocalSessionsChanges(ByRef num)

-Range("A551").Clear

-Range("B551").Clear

-Range("C551").Clear

-Range("D551").Clear

-Range("A551").Value = "xlLocalSessionsChanges"

-Range("B551").Value = 2

-Range("C551").Value = num

-B551 = Range("B551").Value

-C551 = Range("C551").Value

-If B551 = C551 Then

-Range("D551").Value = "OK"

-Else

-Range("D551").Value = "NG"

-End If

-End Function

-

-Function test_xlOtherSessionsChanges(ByRef num)

-Range("A552").Clear

-Range("B552").Clear

-Range("C552").Clear

-Range("D552").Clear

-Range("A552").Value = "xlOtherSessionsChanges"

-Range("B552").Value = 3

-Range("C552").Value = num

-B552 = Range("B552").Value

-C552 = Range("C552").Value

-If B552 = C552 Then

-Range("D552").Value = "OK"

-Else

-Range("D552").Value = "NG"

-End If

-End Function

-

-Function test_xlUserResolution(ByRef num)

-Range("A553").Clear

-Range("B553").Clear

-Range("C553").Clear

-Range("D553").Clear

-Range("A553").Value = "xlUserResolution"

-Range("B553").Value = 1

-Range("C553").Value = num

-B553 = Range("B553").Value

-C553 = Range("C553").Value

-If B553 = C553 Then

-Range("D553").Value = "OK"

-Else

-Range("D553").Value = "NG"

-End If

-End Function

-

-Function test_xlScaleLinear(ByRef num)

-Range("A554").Clear

-Range("B554").Clear

-Range("C554").Clear

-Range("D554").Clear

-Range("A554").Value = "xlScaleLinear"

-Range("B554").Value = -4132

-Range("C554").Value = num

-B554 = Range("B554").Value

-C554 = Range("C554").Value

-If B554 = C554 Then

-Range("D554").Value = "OK"

-Else

-Range("D554").Value = "NG"

-End If

-End Function

-

-Function test_xlScaleLogarithmicr(ByRef num)

-Range("A555").Clear

-Range("B555").Clear

-Range("C555").Clear

-Range("D555").Clear

-Range("A555").Value = "xlScaleLogarithmicr"

-Range("B555").Value = -4133

-Range("C555").Value = num

-B555 = Range("B555").Value

-C555 = Range("C555").Value

-If B555 = C555 Then

-Range("D555").Value = "OK"

-Else

-Range("D555").Value = "NG"

-End If

-End Function

-

-Function test_xlNext(ByRef num)

-Range("A556").Clear

-Range("B556").Clear

-Range("C556").Clear

-Range("D556").Clear

-Range("A556").Value = "xlNext"

-Range("B556").Value = 1

-Range("C556").Value = num

-B556 = Range("B556").Value

-C556 = Range("C556").Value

-If B556 = C556 Then

-Range("D556").Value = "OK"

-Else

-Range("D556").Value = "NG"

-End If

-End Function

-

-Function test_xlPrevious(ByRef num)

-Range("A557").Clear

-Range("B557").Clear

-Range("C557").Clear

-Range("D557").Clear

-Range("A557").Value = "xlPrevious"

-Range("B557").Value = 2

-Range("C557").Value = num

-B557 = Range("B557").Value

-C557 = Range("C557").Value

-If B557 = C557 Then

-Range("D557").Value = "OK"

-Else

-Range("D557").Value = "NG"

-End If

-End Function

-

-Function test_xlByColumns(ByRef num)

-Range("A558").Clear

-Range("B558").Clear

-Range("C558").Clear

-Range("D558").Clear

-Range("A558").Value = "xlByColumns"

-Range("B558").Value = 2

-Range("C558").Value = num

-B558 = Range("B558").Value

-C558 = Range("C558").Value

-If B558 = C558 Then

-Range("D558").Value = "OK"

-Else

-Range("D558").Value = "NG"

-End If

-End Function

-

-Function test_xlByRows(ByRef num)

-Range("A559").Clear

-Range("B559").Clear

-Range("C559").Clear

-Range("D559").Clear

-Range("A559").Value = "xlByRows"

-Range("B559").Value = 1

-Range("C559").Value = num

-B559 = Range("B559").Value

-C559 = Range("C559").Value

-If B559 = C559 Then

-Range("D559").Value = "OK"

-Else

-Range("D559").Value = "NG"

-End If

-End Function

-

-Function test_xlWithinSheet(ByRef num)

-Range("A560").Clear

-Range("B560").Clear

-Range("C560").Clear

-Range("D560").Clear

-Range("A560").Value = "xlWithinSheet"

-Range("B560").Value = 1

-Range("C560").Value = num

-B560 = Range("B560").Value

-C560 = Range("C560").Value

-If B560 = C560 Then

-Range("D560").Value = "OK"

-Else

-Range("D560").Value = "NG"

-End If

-End Function

-

-Function test_xlWithinWorkbook(ByRef num)

-Range("A561").Clear

-Range("B561").Clear

-Range("C561").Clear

-Range("D561").Clear

-Range("A561").Value = "xlWithinWorkbook"

-Range("B561").Value = 2

-Range("C561").Value = num

-B561 = Range("B561").Value

-C561 = Range("C561").Value

-If B561 = C561 Then

-Range("D561").Value = "OK"

-Else

-Range("D561").Value = "NG"

-End If

-End Function

-

-Function test_xlChart(ByRef num)

-Range("A562").Clear

-Range("B562").Clear

-Range("C562").Clear

-Range("D562").Clear

-Range("A562").Value = "xlChart"

-Range("B562").Value = -4109

-Range("C562").Value = num

-B562 = Range("B562").Value

-C562 = Range("C562").Value

-If B562 = C562 Then

-Range("D562").Value = "OK"

-Else

-Range("D562").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSheet(ByRef num)

-Range("A563").Clear

-Range("B563").Clear

-Range("C563").Clear

-Range("D563").Clear

-Range("A563").Value = "xlDialogSheet"

-Range("B563").Value = -4116

-Range("C563").Value = num

-B563 = Range("B563").Value

-C563 = Range("C563").Value

-If B563 = C563 Then

-Range("D563").Value = "OK"

-Else

-Range("D563").Value = "NG"

-End If

-End Function

-

-Function test_xlExcel4IntMacroSheet(ByRef num)

-Range("A564").Clear

-Range("B564").Clear

-Range("C564").Clear

-Range("D564").Clear

-Range("A564").Value = "xlExcel4IntMacroSheet"

-Range("B564").Value = 4

-Range("C564").Value = num

-B564 = Range("B564").Value

-C564 = Range("C564").Value

-If B564 = C564 Then

-Range("D564").Value = "OK"

-Else

-Range("D564").Value = "NG"

-End If

-End Function

-

-Function test_xlExcel4MacroSheet(ByRef num)

-Range("A565").Clear

-Range("B565").Clear

-Range("C565").Clear

-Range("D565").Clear

-Range("A565").Value = "xlExcel4MacroSheet"

-Range("B565").Value = 3

-Range("C565").Value = num

-B565 = Range("B565").Value

-C565 = Range("C565").Value

-If B565 = C565 Then

-Range("D565").Value = "OK"

-Else

-Range("D565").Value = "NG"

-End If

-End Function

-

-Function test_xlWorkSheet(ByRef num)

-Range("A566").Clear

-Range("B566").Clear

-Range("C566").Clear

-Range("D566").Clear

-Range("A566").Value = "xlWorkSheet"

-Range("B566").Value = -4167

-Range("C566").Value = num

-B566 = Range("B566").Value

-C566 = Range("C566").Value

-If B566 = C566 Then

-Range("D566").Value = "OK"

-Else

-Range("D566").Value = "NG"

-End If

-End Function

-

-Function test_xlSheetHidden(ByRef num)

-Range("A567").Clear

-Range("B567").Clear

-Range("C567").Clear

-Range("D567").Clear

-Range("A567").Value = "xlSheetHidden"

-Range("B567").Value = 0

-Range("C567").Value = num

-B567 = Range("B567").Value

-C567 = Range("C567").Value

-If B567 = C567 Then

-Range("D567").Value = "OK"

-Else

-Range("D567").Value = "NG"

-End If

-End Function

-

-Function test_xlSheetVeryHidden(ByRef num)

-Range("A568").Clear

-Range("B568").Clear

-Range("C568").Clear

-Range("D568").Clear

-Range("A568").Value = "xlSheetVeryHidden"

-Range("B568").Value = 2

-Range("C568").Value = num

-B568 = Range("B568").Value

-C568 = Range("C568").Value

-If B568 = C568 Then

-Range("D568").Value = "OK"

-Else

-Range("D568").Value = "NG"

-End If

-End Function

-

-Function test_xlSheetVisible(ByRef num)

-Range("A569").Clear

-Range("B569").Clear

-Range("C569").Clear

-Range("D569").Clear

-Range("A569").Value = "xlSheetVisible"

-Range("B569").Value = -1

-Range("C569").Value = num

-B569 = Range("B569").Value

-C569 = Range("C569").Value

-If B569 = C569 Then

-Range("D569").Value = "OK"

-Else

-Range("D569").Value = "NG"

-End If

-End Function

-

-Function test_xlSizeIsArea(ByRef num)

-Range("A570").Clear

-Range("B570").Clear

-Range("C570").Clear

-Range("D570").Clear

-Range("A570").Value = "xlSizeIsArea"

-Range("B570").Value = 1

-Range("C570").Value = num

-B570 = Range("B570").Value

-C570 = Range("C570").Value

-If B570 = C570 Then

-Range("D570").Value = "OK"

-Else

-Range("D570").Value = "NG"

-End If

-End Function

-

-Function test_xlSizeIsWidth(ByRef num)

-Range("A571").Clear

-Range("B571").Clear

-Range("C571").Clear

-Range("D571").Clear

-Range("A571").Value = "xlSizeIsWidth"

-Range("B571").Value = 2

-Range("C571").Value = num

-B571 = Range("B571").Value

-C571 = Range("C571").Value

-If B571 = C571 Then

-Range("D571").Value = "OK"

-Else

-Range("D571").Value = "NG"

-End If

-End Function

-

-Function test_xlSmartTagControlActiveX(ByRef num)

-Range("A572").Clear

-Range("B572").Clear

-Range("C572").Clear

-Range("D572").Clear

-Range("A572").Value = "xlSmartTagControlActiveX"

-Range("B572").Value = 13

-Range("C572").Value = num

-B572 = Range("B572").Value

-C572 = Range("C572").Value

-If B572 = C572 Then

-Range("D572").Value = "OK"

-Else

-Range("D572").Value = "NG"

-End If

-End Function

-

-Function test_xlSmartTagControlButton(ByRef num)

-Range("A573").Clear

-Range("B573").Clear

-Range("C573").Clear

-Range("D573").Clear

-Range("A573").Value = "xlSmartTagControlButton"

-Range("B573").Value = 6

-Range("C573").Value = num

-B573 = Range("B573").Value

-C573 = Range("C573").Value

-If B573 = C573 Then

-Range("D573").Value = "OK"

-Else

-Range("D573").Value = "NG"

-End If

-End Function

-

-Function test_xlSmartTagControlCheckbox(ByRef num)

-Range("A574").Clear

-Range("B574").Clear

-Range("C574").Clear

-Range("D574").Clear

-Range("A574").Value = "xlSmartTagControlCheckbox"

-Range("B574").Value = 9

-Range("C574").Value = num

-B574 = Range("B574").Value

-C574 = Range("C574").Value

-If B574 = C574 Then

-Range("D574").Value = "OK"

-Else

-Range("D574").Value = "NG"

-End If

-End Function

-

-Function test_xlSmartTagControlCombo(ByRef num)

-Range("A575").Clear

-Range("B575").Clear

-Range("C575").Clear

-Range("D575").Clear

-Range("A575").Value = "xlSmartTagControlCombo"

-Range("B575").Value = 12

-Range("C575").Value = num

-B575 = Range("B575").Value

-C575 = Range("C575").Value

-If B575 = C575 Then

-Range("D575").Value = "OK"

-Else

-Range("D575").Value = "NG"

-End If

-End Function

-

-Function test_xlSmartTagControlHelp(ByRef num)

-Range("A576").Clear

-Range("B576").Clear

-Range("C576").Clear

-Range("D576").Clear

-Range("A576").Value = "xlSmartTagControlHelp"

-Range("B576").Value = 3

-Range("C576").Value = num

-B576 = Range("B576").Value

-C576 = Range("C576").Value

-If B576 = C576 Then

-Range("D576").Value = "OK"

-Else

-Range("D576").Value = "NG"

-End If

-End Function

-

-Function test_xlSmartTagControlHelpURL(ByRef num)

-Range("A577").Clear

-Range("B577").Clear

-Range("C577").Clear

-Range("D577").Clear

-Range("A577").Value = "xlSmartTagControlHelpURL"

-Range("B577").Value = 4

-Range("C577").Value = num

-B577 = Range("B577").Value

-C577 = Range("C577").Value

-If B577 = C577 Then

-Range("D577").Value = "OK"

-Else

-Range("D577").Value = "NG"

-End If

-End Function

-

-Function test_xlSmartTagControlImage(ByRef num)

-Range("A578").Clear

-Range("B578").Clear

-Range("C578").Clear

-Range("D578").Clear

-Range("A578").Value = "xlSmartTagControlImage"

-Range("B578").Value = 8

-Range("C578").Value = num

-B578 = Range("B578").Value

-C578 = Range("C578").Value

-If B578 = C578 Then

-Range("D578").Value = "OK"

-Else

-Range("D578").Value = "NG"

-End If

-End Function

-

-Function test_xlSmartTagControlLabel(ByRef num)

-Range("A579").Clear

-Range("B579").Clear

-Range("C579").Clear

-Range("D579").Clear

-Range("A579").Value = "xlSmartTagControlLabel"

-Range("B579").Value = 7

-Range("C579").Value = num

-B579 = Range("B579").Value

-C579 = Range("C579").Value

-If B579 = C579 Then

-Range("D579").Value = "OK"

-Else

-Range("D579").Value = "NG"

-End If

-End Function

-

-Function test_xlSmartTagControlLink(ByRef num)

-Range("A580").Clear

-Range("B580").Clear

-Range("C580").Clear

-Range("D580").Clear

-Range("A580").Value = "xlSmartTagControlLink"

-Range("B580").Value = 2

-Range("C580").Value = num

-B580 = Range("B580").Value

-C580 = Range("C580").Value

-If B580 = C580 Then

-Range("D580").Value = "OK"

-Else

-Range("D580").Value = "NG"

-End If

-End Function

-

-Function test_xlSmartTagControlListbox(ByRef num)

-Range("A581").Clear

-Range("B581").Clear

-Range("C581").Clear

-Range("D581").Clear

-Range("A581").Value = "xlSmartTagControlListbox"

-Range("B581").Value = 11

-Range("C581").Value = num

-B581 = Range("B581").Value

-C581 = Range("C581").Value

-If B581 = C581 Then

-Range("D581").Value = "OK"

-Else

-Range("D581").Value = "NG"

-End If

-End Function

-

-Function test_xlSmartTagControlRadioGroup(ByRef num)

-Range("A582").Clear

-Range("B582").Clear

-Range("C582").Clear

-Range("D582").Clear

-Range("A582").Value = "xlSmartTagControlRadioGroup"

-Range("B582").Value = 14

-Range("C582").Value = num

-B582 = Range("B582").Value

-C582 = Range("C582").Value

-If B582 = C582 Then

-Range("D582").Value = "OK"

-Else

-Range("D582").Value = "NG"

-End If

-End Function

-

-Function test_xlSmartTagControlSeparator(ByRef num)

-Range("A583").Clear

-Range("B583").Clear

-Range("C583").Clear

-Range("D583").Clear

-Range("A583").Value = "xlSmartTagControlSeparator"

-Range("B583").Value = 5

-Range("C583").Value = num

-B583 = Range("B583").Value

-C583 = Range("C583").Value

-If B583 = C583 Then

-Range("D583").Value = "OK"

-Else

-Range("D583").Value = "NG"

-End If

-End Function

-

-Function test_xlSmartTagControlSmartTag(ByRef num)

-Range("A584").Clear

-Range("B584").Clear

-Range("C584").Clear

-Range("D584").Clear

-Range("A584").Value = "xlSmartTagControlSmartTag"

-Range("B584").Value = 1

-Range("C584").Value = num

-B584 = Range("B584").Value

-C584 = Range("C584").Value

-If B584 = C584 Then

-Range("D584").Value = "OK"

-Else

-Range("D584").Value = "NG"

-End If

-End Function

-

-Function test_xlSmartTagControlTextbox(ByRef num)

-Range("A585").Clear

-Range("B585").Clear

-Range("C585").Clear

-Range("D585").Clear

-Range("A585").Value = "xlSmartTagControlTextbox"

-Range("B585").Value = 10

-Range("C585").Value = num

-B585 = Range("B585").Value

-C585 = Range("C585").Value

-If B585 = C585 Then

-Range("D585").Value = "OK"

-Else

-Range("D585").Value = "NG"

-End If

-End Function

-

-Function test_xlButtonOnly(ByRef num)

-Range("A586").Clear

-Range("B586").Clear

-Range("C586").Clear

-Range("D586").Clear

-Range("A586").Value = "xlButtonOnly"

-Range("B586").Value = 2

-Range("C586").Value = num

-B586 = Range("B586").Value

-C586 = Range("C586").Value

-If B586 = C586 Then

-Range("D586").Value = "OK"

-Else

-Range("D586").Value = "NG"

-End If

-End Function

-

-Function test_xlDisplayNone(ByRef num)

-Range("A587").Clear

-Range("B587").Clear

-Range("C587").Clear

-Range("D587").Clear

-Range("A587").Value = "xlDisplayNone"

-Range("B587").Value = 1

-Range("C587").Value = num

-B587 = Range("B587").Value

-C587 = Range("C587").Value

-If B587 = C587 Then

-Range("D587").Value = "OK"

-Else

-Range("D587").Value = "NG"

-End If

-End Function

-

-Function test_xlIndicatorAndButton(ByRef num)

-Range("A588").Clear

-Range("B588").Clear

-Range("C588").Clear

-Range("D588").Clear

-Range("A588").Value = "xlIndicatorAndButton"

-Range("B588").Value = 0

-Range("C588").Value = num

-B588 = Range("B588").Value

-C588 = Range("C588").Value

-If B588 = C588 Then

-Range("D588").Value = "OK"

-Else

-Range("D588").Value = "NG"

-End If

-End Function

-

-Function test_xlSortNormal(ByRef num)

-Range("A589").Clear

-Range("B589").Clear

-Range("C589").Clear

-Range("D589").Clear

-Range("A589").Value = "xlSortNormal"

-Range("B589").Value = 0

-Range("C589").Value = num

-B589 = Range("B589").Value

-C589 = Range("C589").Value

-If B589 = C589 Then

-Range("D589").Value = "OK"

-Else

-Range("D589").Value = "NG"

-End If

-End Function

-

-Function test_xlSortTextAsNumbers(ByRef num)

-Range("A590").Clear

-Range("B590").Clear

-Range("C590").Clear

-Range("D590").Clear

-Range("A590").Value = "xlSortTextAsNumbers"

-Range("B590").Value = 1

-Range("C590").Value = num

-B590 = Range("B590").Value

-C590 = Range("C590").Value

-If B590 = C590 Then

-Range("D590").Value = "OK"

-Else

-Range("D590").Value = "NG"

-End If

-End Function

-

-Function test_xlPinYin(ByRef num)

-Range("A591").Clear

-Range("B591").Clear

-Range("C591").Clear

-Range("D591").Clear

-Range("A591").Value = "xlPinYin"

-Range("B591").Value = 1

-Range("C591").Value = num

-B591 = Range("B591").Value

-C591 = Range("C591").Value

-If B591 = C591 Then

-Range("D591").Value = "OK"

-Else

-Range("D591").Value = "NG"

-End If

-End Function

-

-Function test_xlStroke(ByRef num)

-Range("A592").Clear

-Range("B592").Clear

-Range("C592").Clear

-Range("D592").Clear

-Range("A592").Value = "xlStroke"

-Range("B592").Value = 2

-Range("C592").Value = num

-B592 = Range("B592").Value

-C592 = Range("C592").Value

-If B592 = C592 Then

-Range("D592").Value = "OK"

-Else

-Range("D592").Value = "NG"

-End If

-End Function

-

-Function test_xlCodePage(ByRef num)

-Range("A593").Clear

-Range("B593").Clear

-Range("C593").Clear

-Range("D593").Clear

-Range("A593").Value = "xlCodePage"

-Range("B593").Value = 2

-Range("C593").Value = num

-B593 = Range("B593").Value

-C593 = Range("C593").Value

-If B593 = C593 Then

-Range("D593").Value = "OK"

-Else

-Range("D593").Value = "NG"

-End If

-End Function

-

-Function test_xlSyllabary(ByRef num)

-Range("A594").Clear

-Range("B594").Clear

-Range("C594").Clear

-Range("D594").Clear

-Range("A594").Value = "xlSyllabary"

-Range("B594").Value = 1

-Range("C594").Value = num

-B594 = Range("B594").Value

-C594 = Range("C594").Value

-If B594 = C594 Then

-Range("D594").Value = "OK"

-Else

-Range("D594").Value = "NG"

-End If

-End Function

-

-Function test_xlAscending(ByRef num)

-Range("A595").Clear

-Range("B595").Clear

-Range("C595").Clear

-Range("D595").Clear

-Range("A595").Value = "xlAscending"

-Range("B595").Value = 1

-Range("C595").Value = num

-B595 = Range("B595").Value

-C595 = Range("C595").Value

-If B595 = C595 Then

-Range("D595").Value = "OK"

-Else

-Range("D595").Value = "NG"

-End If

-End Function

-

-Function test_xlDescending(ByRef num)

-Range("A596").Clear

-Range("B596").Clear

-Range("C596").Clear

-Range("D596").Clear

-Range("A596").Value = "xlDescending"

-Range("B596").Value = 2

-Range("C596").Value = num

-B596 = Range("B596").Value

-C596 = Range("C596").Value

-If B596 = C596 Then

-Range("D596").Value = "OK"

-Else

-Range("D596").Value = "NG"

-End If

-End Function

-

-Function test_xlSortColumns(ByRef num)

-Range("A597").Clear

-Range("B597").Clear

-Range("C597").Clear

-Range("D597").Clear

-Range("A597").Value = "xlSortColumns"

-Range("B597").Value = 1

-Range("C597").Value = num

-B597 = Range("B597").Value

-C597 = Range("C597").Value

-If B597 = C597 Then

-Range("D597").Value = "OK"

-Else

-Range("D597").Value = "NG"

-End If

-End Function

-

-Function test_xlSortRows(ByRef num)

-Range("A598").Clear

-Range("B598").Clear

-Range("C598").Clear

-Range("D598").Clear

-Range("A598").Value = "xlSortRows"

-Range("B598").Value = 2

-Range("C598").Value = num

-B598 = Range("B598").Value

-C598 = Range("C598").Value

-If B598 = C598 Then

-Range("D598").Value = "OK"

-Else

-Range("D598").Value = "NG"

-End If

-End Function

-

-Function test_xlSortLabels(ByRef num)

-Range("A599").Clear

-Range("B599").Clear

-Range("C599").Clear

-Range("D599").Clear

-Range("A599").Value = "xlSortLabels"

-Range("B599").Value = 2

-Range("C599").Value = num

-B599 = Range("B599").Value

-C599 = Range("C599").Value

-If B599 = C599 Then

-Range("D599").Value = "OK"

-Else

-Range("D599").Value = "NG"

-End If

-End Function

-

-Function test_xlSortValues(ByRef num)

-Range("A600").Clear

-Range("B600").Clear

-Range("C600").Clear

-Range("D600").Clear

-Range("A600").Value = "xlSortValues"

-Range("B600").Value = 1

-Range("C600").Value = num

-B600 = Range("B600").Value

-C600 = Range("C600").Value

-If B600 = C600 Then

-Range("D600").Value = "OK"

-Else

-Range("D600").Value = "NG"

-End If

-End Function

-

-Function test_xlSourceAutoFilter(ByRef num)

-Range("A601").Clear

-Range("B601").Clear

-Range("C601").Clear

-Range("D601").Clear

-Range("A601").Value = "xlSourceAutoFilter"

-Range("B601").Value = 3

-Range("C601").Value = num

-B601 = Range("B601").Value

-C601 = Range("C601").Value

-If B601 = C601 Then

-Range("D601").Value = "OK"

-Else

-Range("D601").Value = "NG"

-End If

-End Function

-

-Function test_xlSourceChart(ByRef num)

-Range("A602").Clear

-Range("B602").Clear

-Range("C602").Clear

-Range("D602").Clear

-Range("A602").Value = "xlSourceChart"

-Range("B602").Value = 5

-Range("C602").Value = num

-B602 = Range("B602").Value

-C602 = Range("C602").Value

-If B602 = C602 Then

-Range("D602").Value = "OK"

-Else

-Range("D602").Value = "NG"

-End If

-End Function

-

-Function test_xlSourcePivotTable(ByRef num)

-Range("A603").Clear

-Range("B603").Clear

-Range("C603").Clear

-Range("D603").Clear

-Range("A603").Value = "xlSourcePivotTable"

-Range("B603").Value = 6

-Range("C603").Value = num

-B603 = Range("B603").Value

-C603 = Range("C603").Value

-If B603 = C603 Then

-Range("D603").Value = "OK"

-Else

-Range("D603").Value = "NG"

-End If

-End Function

-

-Function test_xlSourcePrintArea(ByRef num)

-Range("A604").Clear

-Range("B604").Clear

-Range("C604").Clear

-Range("D604").Clear

-Range("A604").Value = "xlSourcePrintArea"

-Range("B604").Value = 2

-Range("C604").Value = num

-B604 = Range("B604").Value

-C604 = Range("C604").Value

-If B604 = C604 Then

-Range("D604").Value = "OK"

-Else

-Range("D604").Value = "NG"

-End If

-End Function

-

-Function test_xlSourceQuery(ByRef num)

-Range("A605").Clear

-Range("B605").Clear

-Range("C605").Clear

-Range("D605").Clear

-Range("A605").Value = "xlSourceQuery"

-Range("B605").Value = 7

-Range("C605").Value = num

-B605 = Range("B605").Value

-C605 = Range("C605").Value

-If B605 = C605 Then

-Range("D605").Value = "OK"

-Else

-Range("D605").Value = "NG"

-End If

-End Function

-

-Function test_xlSourceRange(ByRef num)

-Range("A606").Clear

-Range("B606").Clear

-Range("C606").Clear

-Range("D606").Clear

-Range("A606").Value = "xlSourceRange"

-Range("B606").Value = 4

-Range("C606").Value = num

-B606 = Range("B606").Value

-C606 = Range("C606").Value

-If B606 = C606 Then

-Range("D606").Value = "OK"

-Else

-Range("D606").Value = "NG"

-End If

-End Function

-

-Function test_xlSourceSheet(ByRef num)

-Range("A607").Clear

-Range("B607").Clear

-Range("C607").Clear

-Range("D607").Clear

-Range("A607").Value = "xlSourceSheet"

-Range("B607").Value = 1

-Range("C607").Value = num

-B607 = Range("B607").Value

-C607 = Range("C607").Value

-If B607 = C607 Then

-Range("D607").Value = "OK"

-Else

-Range("D607").Value = "NG"

-End If

-End Function

-

-Function test_xlSourceWordbook(ByRef num)

-Range("A608").Clear

-Range("B608").Clear

-Range("C608").Clear

-Range("D608").Clear

-Range("A608").Value = "xlSourceWordbook"

-Range("B608").Value = 0

-Range("C608").Value = num

-B608 = Range("B608").Value

-C608 = Range("C608").Value

-If B608 = C608 Then

-Range("D608").Value = "OK"

-Else

-Range("D608").Value = "NG"

-End If

-End Function

-

-Function test_xlSpeakByColumns(ByRef num)

-Range("A609").Clear

-Range("B609").Clear

-Range("C609").Clear

-Range("D609").Clear

-Range("A609").Value = "xlSpeakByColumns"

-Range("B609").Value = 1

-Range("C609").Value = num

-B609 = Range("B609").Value

-C609 = Range("C609").Value

-If B609 = C609 Then

-Range("D609").Value = "OK"

-Else

-Range("D609").Value = "NG"

-End If

-End Function

-

-Function test_xlSpeakByRows(ByRef num)

-Range("A610").Clear

-Range("B610").Clear

-Range("C610").Clear

-Range("D610").Clear

-Range("A610").Value = "xlSpeakByRows"

-Range("B610").Value = 0

-Range("C610").Value = num

-B610 = Range("B610").Value

-C610 = Range("C610").Value

-If B610 = C610 Then

-Range("D610").Value = "OK"

-Else

-Range("D610").Value = "NG"

-End If

-End Function

-

-Function test_xlErrors(ByRef num)

-Range("A611").Clear

-Range("B611").Clear

-Range("C611").Clear

-Range("D611").Clear

-Range("A611").Value = "xlErrors"

-Range("B611").Value = 16

-Range("C611").Value = num

-B611 = Range("B611").Value

-C611 = Range("C611").Value

-If B611 = C611 Then

-Range("D611").Value = "OK"

-Else

-Range("D611").Value = "NG"

-End If

-End Function

-

-Function test_xlLogical(ByRef num)

-Range("A612").Clear

-Range("B612").Clear

-Range("C612").Clear

-Range("D612").Clear

-Range("A612").Value = "xlLogical"

-Range("B612").Value = 4

-Range("C612").Value = num

-B612 = Range("B612").Value

-C612 = Range("C612").Value

-If B612 = C612 Then

-Range("D612").Value = "OK"

-Else

-Range("D612").Value = "NG"

-End If

-End Function

-

-Function test_xlNumbers(ByRef num)

-Range("A613").Clear

-Range("B613").Clear

-Range("C613").Clear

-Range("D613").Clear

-Range("A613").Value = "xlNumbers"

-Range("B613").Value = 1

-Range("C613").Value = num

-B613 = Range("B613").Value

-C613 = Range("C613").Value

-If B613 = C613 Then

-Range("D613").Value = "OK"

-Else

-Range("D613").Value = "NG"

-End If

-End Function

-

-Function test_xlTextValues(ByRef num)

-Range("A614").Clear

-Range("B614").Clear

-Range("C614").Clear

-Range("D614").Clear

-Range("A614").Value = "xlTextValues"

-Range("B614").Value = 2

-Range("C614").Value = num

-B614 = Range("B614").Value

-C614 = Range("C614").Value

-If B614 = C614 Then

-Range("D614").Value = "OK"

-Else

-Range("D614").Value = "NG"

-End If

-End Function

-

-Function test_xlSubscribeToPicture(ByRef num)

-Range("A615").Clear

-Range("B615").Clear

-Range("C615").Clear

-Range("D615").Clear

-Range("A615").Value = "xlSubscribeToPicture"

-Range("B615").Value = -4147

-Range("C615").Value = num

-B615 = Range("B615").Value

-C615 = Range("C615").Value

-If B615 = C615 Then

-Range("D615").Value = "OK"

-Else

-Range("D615").Value = "NG"

-End If

-End Function

-

-Function test_xlSubscribeToText(ByRef num)

-Range("A616").Clear

-Range("B616").Clear

-Range("C616").Clear

-Range("D616").Clear

-Range("A616").Value = "xlSubscribeToText"

-Range("B616").Value = -4158

-Range("C616").Value = num

-B616 = Range("B616").Value

-C616 = Range("C616").Value

-If B616 = C616 Then

-Range("D616").Value = "OK"

-Else

-Range("D616").Value = "NG"

-End If

-End Function

-

-Function test_xlAtBottom(ByRef num)

-Range("A617").Clear

-Range("B617").Clear

-Range("C617").Clear

-Range("D617").Clear

-Range("A617").Value = "xlAtBottom"

-Range("B617").Value = 2

-Range("C617").Value = num

-B617 = Range("B617").Value

-C617 = Range("C617").Value

-If B617 = C617 Then

-Range("D617").Value = "OK"

-Else

-Range("D617").Value = "NG"

-End If

-End Function

-

-Function test_xlAtTop(ByRef num)

-Range("A618").Clear

-Range("B618").Clear

-Range("C618").Clear

-Range("D618").Clear

-Range("A618").Value = "xlAtTop"

-Range("B618").Value = 1

-Range("C618").Value = num

-B618 = Range("B618").Value

-C618 = Range("C618").Value

-If B618 = C618 Then

-Range("D618").Value = "OK"

-Else

-Range("D618").Value = "NG"

-End If

-End Function

-

-Function test_xlSummaryOnLeft(ByRef num)

-Range("A619").Clear

-Range("B619").Clear

-Range("C619").Clear

-Range("D619").Clear

-Range("A619").Value = "xlSummaryOnLeft"

-Range("B619").Value = -4131

-Range("C619").Value = num

-B619 = Range("B619").Value

-C619 = Range("C619").Value

-If B619 = C619 Then

-Range("D619").Value = "OK"

-Else

-Range("D619").Value = "NG"

-End If

-End Function

-

-Function test_xlSummaryOnRight(ByRef num)

-Range("A620").Clear

-Range("B620").Clear

-Range("C620").Clear

-Range("D620").Clear

-Range("A620").Value = "xlSummaryOnRight"

-Range("B620").Value = -4152

-Range("C620").Value = num

-B620 = Range("B620").Value

-C620 = Range("C620").Value

-If B620 = C620 Then

-Range("D620").Value = "OK"

-Else

-Range("D620").Value = "NG"

-End If

-End Function

-

-Function test_xlStandardSummary(ByRef num)

-Range("A621").Clear

-Range("B621").Clear

-Range("C621").Clear

-Range("D621").Clear

-Range("A621").Value = "xlStandardSummary"

-Range("B621").Value = 1

-Range("C621").Value = num

-B621 = Range("B621").Value

-C621 = Range("C621").Value

-If B621 = C621 Then

-Range("D621").Value = "OK"

-Else

-Range("D621").Value = "NG"

-End If

-End Function

-

-Function test_xlSummaryPivotTable(ByRef num)

-Range("A622").Clear

-Range("B622").Clear

-Range("C622").Clear

-Range("D622").Clear

-Range("A622").Value = "xlSummaryPivotTable"

-Range("B622").Value = -4148

-Range("C622").Value = num

-B622 = Range("B622").Value

-C622 = Range("C622").Value

-If B622 = C622 Then

-Range("D622").Value = "OK"

-Else

-Range("D622").Value = "NG"

-End If

-End Function

-

-Function test_xlSummaryAbove(ByRef num)

-Range("A623").Clear

-Range("B623").Clear

-Range("C623").Clear

-Range("D623").Clear

-Range("A623").Value = "xlSummaryAbove"

-Range("B623").Value = 0

-Range("C623").Value = num

-B623 = Range("B623").Value

-C623 = Range("C623").Value

-If B623 = C623 Then

-Range("D623").Value = "OK"

-Else

-Range("D623").Value = "NG"

-End If

-End Function

-

-Function test_xlSummaryBelow(ByRef num)

-Range("A624").Clear

-Range("B624").Clear

-Range("C624").Clear

-Range("D624").Clear

-Range("A624").Value = "xlSummaryBelow"

-Range("B624").Value = 1

-Range("C624").Value = num

-B624 = Range("B624").Value

-C624 = Range("C624").Value

-If B624 = C624 Then

-Range("D624").Value = "OK"

-Else

-Range("D624").Value = "NG"

-End If

-End Function

-

-Function test_xlTabPositionFirst(ByRef num)

-Range("A625").Clear

-Range("B625").Clear

-Range("C625").Clear

-Range("D625").Clear

-Range("A625").Value = "xlTabPositionFirst"

-Range("B625").Value = 0

-Range("C625").Value = num

-B625 = Range("B625").Value

-C625 = Range("C625").Value

-If B625 = C625 Then

-Range("D625").Value = "OK"

-Else

-Range("D625").Value = "NG"

-End If

-End Function

-

-Function test_xlTabPositionLast(ByRef num)

-Range("A626").Clear

-Range("B626").Clear

-Range("C626").Clear

-Range("D626").Clear

-Range("A626").Value = "xlTabPositionLast"

-Range("B626").Value = 1

-Range("C626").Value = num

-B626 = Range("B626").Value

-C626 = Range("C626").Value

-If B626 = C626 Then

-Range("D626").Value = "OK"

-Else

-Range("D626").Value = "NG"

-End If

-End Function

-

-Function test_xlDelimited(ByRef num)

-Range("A627").Clear

-Range("B627").Clear

-Range("C627").Clear

-Range("D627").Clear

-Range("A627").Value = "xlDelimited"

-Range("B627").Value = 1

-Range("C627").Value = num

-B627 = Range("B627").Value

-C627 = Range("C627").Value

-If B627 = C627 Then

-Range("D627").Value = "OK"

-Else

-Range("D627").Value = "NG"

-End If

-End Function

-

-Function test_xlFixedWidth(ByRef num)

-Range("A628").Clear

-Range("B628").Clear

-Range("C628").Clear

-Range("D628").Clear

-Range("A628").Value = "xlFixedWidth"

-Range("B628").Value = 2

-Range("C628").Value = num

-B628 = Range("B628").Value

-C628 = Range("C628").Value

-If B628 = C628 Then

-Range("D628").Value = "OK"

-Else

-Range("D628").Value = "NG"

-End If

-End Function

-

-Function test_xlTextQualifierDoubleQuote(ByRef num)

-Range("A629").Clear

-Range("B629").Clear

-Range("C629").Clear

-Range("D629").Clear

-Range("A629").Value = "xlTextQualifierDoubleQuote"

-Range("B629").Value = 1

-Range("C629").Value = num

-B629 = Range("B629").Value

-C629 = Range("C629").Value

-If B629 = C629 Then

-Range("D629").Value = "OK"

-Else

-Range("D629").Value = "NG"

-End If

-End Function

-

-Function test_xlTextQualifierNone(ByRef num)

-Range("A630").Clear

-Range("B630").Clear

-Range("C630").Clear

-Range("D630").Clear

-Range("A630").Value = "xlTextQualifierNone"

-Range("B630").Value = -4142

-Range("C630").Value = num

-B630 = Range("B630").Value

-C630 = Range("C630").Value

-If B630 = C630 Then

-Range("D630").Value = "OK"

-Else

-Range("D630").Value = "NG"

-End If

-End Function

-

-Function test_xlTextQualifierSingleQuote(ByRef num)

-Range("A631").Clear

-Range("B631").Clear

-Range("C631").Clear

-Range("D631").Clear

-Range("A631").Value = "xlTextQualifierSingleQuote"

-Range("B631").Value = 2

-Range("C631").Value = num

-B631 = Range("B631").Value

-C631 = Range("C631").Value

-If B631 = C631 Then

-Range("D631").Value = "OK"

-Else

-Range("D631").Value = "NG"

-End If

-End Function

-

-Function test_xlTextVisualLTR(ByRef num)

-Range("A632").Clear

-Range("B632").Clear

-Range("C632").Clear

-Range("D632").Clear

-Range("A632").Value = "xlTextVisualLTR"

-Range("B632").Value = 1

-Range("C632").Value = num

-B632 = Range("B632").Value

-C632 = Range("C632").Value

-If B632 = C632 Then

-Range("D632").Value = "OK"

-Else

-Range("D632").Value = "NG"

-End If

-End Function

-

-Function test_xlTextVisualRTL(ByRef num)

-Range("A633").Clear

-Range("B633").Clear

-Range("C633").Clear

-Range("D633").Clear

-Range("A633").Value = "xlTextVisualRTL"

-Range("B633").Value = 2

-Range("C633").Value = num

-B633 = Range("B633").Value

-C633 = Range("C633").Value

-If B633 = C633 Then

-Range("D633").Value = "OK"

-Else

-Range("D633").Value = "NG"

-End If

-End Function

-

-Function test_XlTickLabelOrientationAutomatic(ByRef num)

-Range("A634").Clear

-Range("B634").Clear

-Range("C634").Clear

-Range("D634").Clear

-Range("A634").Value = "XlTickLabelOrientationAutomatic"

-Range("B634").Value = -4105

-Range("C634").Value = num

-B634 = Range("B634").Value

-C634 = Range("C634").Value

-If B634 = C634 Then

-Range("D634").Value = "OK"

-Else

-Range("D634").Value = "NG"

-End If

-End Function

-

-Function test_XlTickLabelOrientationDownward(ByRef num)

-Range("A635").Clear

-Range("B635").Clear

-Range("C635").Clear

-Range("D635").Clear

-Range("A635").Value = "XlTickLabelOrientationDownward"

-Range("B635").Value = -4170

-Range("C635").Value = num

-B635 = Range("B635").Value

-C635 = Range("C635").Value

-If B635 = C635 Then

-Range("D635").Value = "OK"

-Else

-Range("D635").Value = "NG"

-End If

-End Function

-

-Function test_XlTickLabelOrientationHorizontal(ByRef num)

-Range("A636").Clear

-Range("B636").Clear

-Range("C636").Clear

-Range("D636").Clear

-Range("A636").Value = "XlTickLabelOrientationHorizontal"

-Range("B636").Value = -4128

-Range("C636").Value = num

-B636 = Range("B636").Value

-C636 = Range("C636").Value

-If B636 = C636 Then

-Range("D636").Value = "OK"

-Else

-Range("D636").Value = "NG"

-End If

-End Function

-

-Function test_XlTickLabelOrientationUpward(ByRef num)

-Range("A637").Clear

-Range("B637").Clear

-Range("C637").Clear

-Range("D637").Clear

-Range("A637").Value = "XlTickLabelOrientationUpward"

-Range("B637").Value = -4171

-Range("C637").Value = num

-B637 = Range("B637").Value

-C637 = Range("C637").Value

-If B637 = C637 Then

-Range("D637").Value = "OK"

-Else

-Range("D637").Value = "NG"

-End If

-End Function

-

-Function test_XlTickLabelOrientationVertical(ByRef num)

-Range("A638").Clear

-Range("B638").Clear

-Range("C638").Clear

-Range("D638").Clear

-Range("A638").Value = "XlTickLabelOrientationVertical"

-Range("B638").Value = -4166

-Range("C638").Value = num

-B638 = Range("B638").Value

-C638 = Range("C638").Value

-If B638 = C638 Then

-Range("D638").Value = "OK"

-Else

-Range("D638").Value = "NG"

-End If

-End Function

-

-Function test_xlTickLabelPositionHigh(ByRef num)

-Range("A639").Clear

-Range("B639").Clear

-Range("C639").Clear

-Range("D639").Clear

-Range("A639").Value = "xlTickLabelPositionHigh"

-Range("B639").Value = -4127

-Range("C639").Value = num

-B639 = Range("B639").Value

-C639 = Range("C639").Value

-If B639 = C639 Then

-Range("D639").Value = "OK"

-Else

-Range("D639").Value = "NG"

-End If

-End Function

-

-Function test_xlTickLabelPositionLow(ByRef num)

-Range("A640").Clear

-Range("B640").Clear

-Range("C640").Clear

-Range("D640").Clear

-Range("A640").Value = "xlTickLabelPositionLow"

-Range("B640").Value = -4134

-Range("C640").Value = num

-B640 = Range("B640").Value

-C640 = Range("C640").Value

-If B640 = C640 Then

-Range("D640").Value = "OK"

-Else

-Range("D640").Value = "NG"

-End If

-End Function

-

-Function test_xlTickLabelPositionNextToAxis(ByRef num)

-Range("A641").Clear

-Range("B641").Clear

-Range("C641").Clear

-Range("D641").Clear

-Range("A641").Value = "xlTickLabelPositionNextToAxis"

-Range("B641").Value = 4

-Range("C641").Value = num

-B641 = Range("B641").Value

-C641 = Range("C641").Value

-If B641 = C641 Then

-Range("D641").Value = "OK"

-Else

-Range("D641").Value = "NG"

-End If

-End Function

-

-Function test_xlTickLabelPositionNone(ByRef num)

-Range("A642").Clear

-Range("B642").Clear

-Range("C642").Clear

-Range("D642").Clear

-Range("A642").Value = "xlTickLabelPositionNone"

-Range("B642").Value = -4142

-Range("C642").Value = num

-B642 = Range("B642").Value

-C642 = Range("C642").Value

-If B642 = C642 Then

-Range("D642").Value = "OK"

-Else

-Range("D642").Value = "NG"

-End If

-End Function

-

-Function test_xlTickMarkCross(ByRef num)

-Range("A643").Clear

-Range("B643").Clear

-Range("C643").Clear

-Range("D643").Clear

-Range("A643").Value = "xlTickMarkCross"

-Range("B643").Value = 4

-Range("C643").Value = num

-B643 = Range("B643").Value

-C643 = Range("C643").Value

-If B643 = C643 Then

-Range("D643").Value = "OK"

-Else

-Range("D643").Value = "NG"

-End If

-End Function

-

-Function test_xlTickMarkInside(ByRef num)

-Range("A644").Clear

-Range("B644").Clear

-Range("C644").Clear

-Range("D644").Clear

-Range("A644").Value = "xlTickMarkInside"

-Range("B644").Value = 2

-Range("C644").Value = num

-B644 = Range("B644").Value

-C644 = Range("C644").Value

-If B644 = C644 Then

-Range("D644").Value = "OK"

-Else

-Range("D644").Value = "NG"

-End If

-End Function

-

-Function test_xlTickMarkNone(ByRef num)

-Range("A645").Clear

-Range("B645").Clear

-Range("C645").Clear

-Range("D645").Clear

-Range("A645").Value = "xlTickMarkNone"

-Range("B645").Value = -4142

-Range("C645").Value = num

-B645 = Range("B645").Value

-C645 = Range("C645").Value

-If B645 = C645 Then

-Range("D645").Value = "OK"

-Else

-Range("D645").Value = "NG"

-End If

-End Function

-

-Function test_xlTickMarkOutside(ByRef num)

-Range("A646").Clear

-Range("B646").Clear

-Range("C646").Clear

-Range("D646").Clear

-Range("A646").Value = "xlTickMarkOutside"

-Range("B646").Value = 3

-Range("C646").Value = num

-B646 = Range("B646").Value

-C646 = Range("C646").Value

-If B646 = C646 Then

-Range("D646").Value = "OK"

-Else

-Range("D646").Value = "NG"

-End If

-End Function

-

-Function test_xlDays(ByRef num)

-Range("A647").Clear

-Range("B647").Clear

-Range("C647").Clear

-Range("D647").Clear

-Range("A647").Value = "xlDays"

-Range("B647").Value = 0

-Range("C647").Value = num

-B647 = Range("B647").Value

-C647 = Range("C647").Value

-If B647 = C647 Then

-Range("D647").Value = "OK"

-Else

-Range("D647").Value = "NG"

-End If

-End Function

-

-Function test_xlMonths(ByRef num)

-Range("A648").Clear

-Range("B648").Clear

-Range("C648").Clear

-Range("D648").Clear

-Range("A648").Value = "xlMonths"

-Range("B648").Value = 1

-Range("C648").Value = num

-B648 = Range("B648").Value

-C648 = Range("C648").Value

-If B648 = C648 Then

-Range("D648").Value = "OK"

-Else

-Range("D648").Value = "NG"

-End If

-End Function

-

-Function test_xlYears(ByRef num)

-Range("A649").Clear

-Range("B649").Clear

-Range("C649").Clear

-Range("D649").Clear

-Range("A649").Value = "xlYears"

-Range("B649").Value = 2

-Range("C649").Value = num

-B649 = Range("B649").Value

-C649 = Range("C649").Value

-If B649 = C649 Then

-Range("D649").Value = "OK"

-Else

-Range("D649").Value = "NG"

-End If

-End Function

-

-Function test_xlNoButtonChanges(ByRef num)

-Range("A650").Clear

-Range("B650").Clear

-Range("C650").Clear

-Range("D650").Clear

-Range("A650").Value = "xlNoButtonChanges"

-Range("B650").Value = 1

-Range("C650").Value = num

-B650 = Range("B650").Value

-C650 = Range("C650").Value

-If B650 = C650 Then

-Range("D650").Value = "OK"

-Else

-Range("D650").Value = "NG"

-End If

-End Function

-

-Function test_xlNoChanges(ByRef num)

-Range("A651").Clear

-Range("B651").Clear

-Range("C651").Clear

-Range("D651").Clear

-Range("A651").Value = "xlNoChanges"

-Range("B651").Value = 4

-Range("C651").Value = num

-B651 = Range("B651").Value

-C651 = Range("C651").Value

-If B651 = C651 Then

-Range("D651").Value = "OK"

-Else

-Range("D651").Value = "NG"

-End If

-End Function

-

-Function test_xlNoDockingChanges(ByRef num)

-Range("A652").Clear

-Range("B652").Clear

-Range("C652").Clear

-Range("D652").Clear

-Range("A652").Value = "xlNoDockingChanges"

-Range("B652").Value = 3

-Range("C652").Value = num

-B652 = Range("B652").Value

-C652 = Range("C652").Value

-If B652 = C652 Then

-Range("D652").Value = "OK"

-Else

-Range("D652").Value = "NG"

-End If

-End Function

-

-Function test_xlNoShapeChanges(ByRef num)

-Range("A653").Clear

-Range("B653").Clear

-Range("C653").Clear

-Range("D653").Clear

-Range("A653").Value = "xlNoShapeChanges"

-Range("B653").Value = 2

-Range("C653").Value = num

-B653 = Range("B653").Value

-C653 = Range("C653").Value

-If B653 = C653 Then

-Range("D653").Value = "OK"

-Else

-Range("D653").Value = "NG"

-End If

-End Function

-

-Function test_xlToolbarProtectionNone(ByRef num)

-Range("A654").Clear

-Range("B654").Clear

-Range("C654").Clear

-Range("D654").Clear

-Range("A654").Value = "xlToolbarProtectionNone"

-Range("B654").Value = -4143

-Range("C654").Value = num

-B654 = Range("B654").Value

-C654 = Range("C654").Value

-If B654 = C654 Then

-Range("D654").Value = "OK"

-Else

-Range("D654").Value = "NG"

-End If

-End Function

-

-Function test_xlTotalsCalculationAverage(ByRef num)

-Range("A655").Clear

-Range("B655").Clear

-Range("C655").Clear

-Range("D655").Clear

-Range("A655").Value = "xlTotalsCalculationAverage"

-Range("B655").Value = 2

-Range("C655").Value = num

-B655 = Range("B655").Value

-C655 = Range("C655").Value

-If B655 = C655 Then

-Range("D655").Value = "OK"

-Else

-Range("D655").Value = "NG"

-End If

-End Function

-

-Function test_xlTotalsCalculationCount(ByRef num)

-Range("A656").Clear

-Range("B656").Clear

-Range("C656").Clear

-Range("D656").Clear

-Range("A656").Value = "xlTotalsCalculationCount"

-Range("B656").Value = 3

-Range("C656").Value = num

-B656 = Range("B656").Value

-C656 = Range("C656").Value

-If B656 = C656 Then

-Range("D656").Value = "OK"

-Else

-Range("D656").Value = "NG"

-End If

-End Function

-

-Function test_xlTotalsCalculationCountNums(ByRef num)

-Range("A657").Clear

-Range("B657").Clear

-Range("C657").Clear

-Range("D657").Clear

-Range("A657").Value = "xlTotalsCalculationCountNums"

-Range("B657").Value = 4

-Range("C657").Value = num

-B657 = Range("B657").Value

-C657 = Range("C657").Value

-If B657 = C657 Then

-Range("D657").Value = "OK"

-Else

-Range("D657").Value = "NG"

-End If

-End Function

-

-Function test_xlTotalsCalculationCountMax(ByRef num)

-Range("A658").Clear

-Range("B658").Clear

-Range("C658").Clear

-Range("D658").Clear

-Range("A658").Value = "xlTotalsCalculationCountMax"

-Range("B658").Value = 6

-Range("C658").Value = num

-B658 = Range("B658").Value

-C658 = Range("C658").Value

-If B658 = C658 Then

-Range("D658").Value = "OK"

-Else

-Range("D658").Value = "NG"

-End If

-End Function

-

-Function test_xlTotalsCalculationCountMin(ByRef num)

-Range("A659").Clear

-Range("B659").Clear

-Range("C659").Clear

-Range("D659").Clear

-Range("A659").Value = "xlTotalsCalculationCountMin"

-Range("B659").Value = 5

-Range("C659").Value = num

-B659 = Range("B659").Value

-C659 = Range("C659").Value

-If B659 = C659 Then

-Range("D659").Value = "OK"

-Else

-Range("D659").Value = "NG"

-End If

-End Function

-

-Function test_xlTotalsCalculationCountNone(ByRef num)

-Range("A660").Clear

-Range("B660").Clear

-Range("C660").Clear

-Range("D660").Clear

-Range("A660").Value = "xlTotalsCalculationCountNone"

-Range("B660").Value = 0

-Range("C660").Value = num

-B660 = Range("B660").Value

-C660 = Range("C660").Value

-If B660 = C660 Then

-Range("D660").Value = "OK"

-Else

-Range("D660").Value = "NG"

-End If

-End Function

-

-Function test_xlTotalsCalculationCountStdDev(ByRef num)

-Range("A661").Clear

-Range("B661").Clear

-Range("C661").Clear

-Range("D661").Clear

-Range("A661").Value = "xlTotalsCalculationCountStdDev"

-Range("B661").Value = 7

-Range("C661").Value = num

-B661 = Range("B661").Value

-C661 = Range("C661").Value

-If B661 = C661 Then

-Range("D661").Value = "OK"

-Else

-Range("D661").Value = "NG"

-End If

-End Function

-

-Function test_xlTotalsCalculationCountSum(ByRef num)

-Range("A662").Clear

-Range("B662").Clear

-Range("C662").Clear

-Range("D662").Clear

-Range("A662").Value = "xlTotalsCalculationCountSum"

-Range("B662").Value = 1

-Range("C662").Value = num

-B662 = Range("B662").Value

-C662 = Range("C662").Value

-If B662 = C662 Then

-Range("D662").Value = "OK"

-Else

-Range("D662").Value = "NG"

-End If

-End Function

-

-Function test_xlTotalsCalculationCountVar(ByRef num)

-Range("A663").Clear

-Range("B663").Clear

-Range("C663").Clear

-Range("D663").Clear

-Range("A663").Value = "xlTotalsCalculationCountVar"

-Range("B663").Value = 8

-Range("C663").Value = num

-B663 = Range("B663").Value

-C663 = Range("C663").Value

-If B663 = C663 Then

-Range("D663").Value = "OK"

-Else

-Range("D663").Value = "NG"

-End If

-End Function

-

-Function test_xlExponential(ByRef num)

-Range("A664").Clear

-Range("B664").Clear

-Range("C664").Clear

-Range("D664").Clear

-Range("A664").Value = "xlExponential"

-Range("B664").Value = 5

-Range("C664").Value = num

-B664 = Range("B664").Value

-C664 = Range("C664").Value

-If B664 = C664 Then

-Range("D664").Value = "OK"

-Else

-Range("D664").Value = "NG"

-End If

-End Function

-

-Function test_xlLinear(ByRef num)

-Range("A665").Clear

-Range("B665").Clear

-Range("C665").Clear

-Range("D665").Clear

-Range("A665").Value = "xlLinear"

-Range("B665").Value = -4132

-Range("C665").Value = num

-B665 = Range("B665").Value

-C665 = Range("C665").Value

-If B665 = C665 Then

-Range("D665").Value = "OK"

-Else

-Range("D665").Value = "NG"

-End If

-End Function

-

-Function test_xlLogarithmic(ByRef num)

-Range("A666").Clear

-Range("B666").Clear

-Range("C666").Clear

-Range("D666").Clear

-Range("A666").Value = "xlLogarithmic"

-Range("B666").Value = -4133

-Range("C666").Value = num

-B666 = Range("B666").Value

-C666 = Range("C666").Value

-If B666 = C666 Then

-Range("D666").Value = "OK"

-Else

-Range("D666").Value = "NG"

-End If

-End Function

-

-Function test_xlMovingAvg(ByRef num)

-Range("A667").Clear

-Range("B667").Clear

-Range("C667").Clear

-Range("D667").Clear

-Range("A667").Value = "xlMovingAvg"

-Range("B667").Value = 6

-Range("C667").Value = num

-B667 = Range("B667").Value

-C667 = Range("C667").Value

-If B667 = C667 Then

-Range("D667").Value = "OK"

-Else

-Range("D667").Value = "NG"

-End If

-End Function

-

-Function test_xlPolynomial(ByRef num)

-Range("A668").Clear

-Range("B668").Clear

-Range("C668").Clear

-Range("D668").Clear

-Range("A668").Value = "xlPolynomial"

-Range("B668").Value = 3

-Range("C668").Value = num

-B668 = Range("B668").Value

-C668 = Range("C668").Value

-If B668 = C668 Then

-Range("D668").Value = "OK"

-Else

-Range("D668").Value = "NG"

-End If

-End Function

-

-Function test_xlPower(ByRef num)

-Range("A669").Clear

-Range("B669").Clear

-Range("C669").Clear

-Range("D669").Clear

-Range("A669").Value = "xlPower"

-Range("B669").Value = 4

-Range("C669").Value = num

-B669 = Range("B669").Value

-C669 = Range("C669").Value

-If B669 = C669 Then

-Range("D669").Value = "OK"

-Else

-Range("D669").Value = "NG"

-End If

-End Function

-

-Function test_XlUnderlineStyleDouble(ByRef num)

-Range("A670").Clear

-Range("B670").Clear

-Range("C670").Clear

-Range("D670").Clear

-Range("A670").Value = "XlUnderlineStyleDouble"

-Range("B670").Value = -4119

-Range("C670").Value = num

-B670 = Range("B670").Value

-C670 = Range("C670").Value

-If B670 = C670 Then

-Range("D670").Value = "OK"

-Else

-Range("D670").Value = "NG"

-End If

-End Function

-

-Function test_XlUnderlineStyleDoubleAccounting(ByRef num)

-Range("A671").Clear

-Range("B671").Clear

-Range("C671").Clear

-Range("D671").Clear

-Range("A671").Value = "XlUnderlineStyleDoubleAccounting"

-Range("B671").Value = 5

-Range("C671").Value = num

-B671 = Range("B671").Value

-C671 = Range("C671").Value

-If B671 = C671 Then

-Range("D671").Value = "OK"

-Else

-Range("D671").Value = "NG"

-End If

-End Function

-

-Function test_XlUnderlineStyleNone(ByRef num)

-Range("A672").Clear

-Range("B672").Clear

-Range("C672").Clear

-Range("D672").Clear

-Range("A672").Value = "XlUnderlineStyleNone"

-Range("B672").Value = -4142

-Range("C672").Value = num

-B672 = Range("B672").Value

-C672 = Range("C672").Value

-If B672 = C672 Then

-Range("D672").Value = "OK"

-Else

-Range("D672").Value = "NG"

-End If

-End Function

-

-Function test_XlUnderlineStyleSingle(ByRef num)

-Range("A673").Clear

-Range("B673").Clear

-Range("C673").Clear

-Range("D673").Clear

-Range("A673").Value = "XlUnderlineStyleSingle"

-Range("B673").Value = 2

-Range("C673").Value = num

-B673 = Range("B673").Value

-C673 = Range("C673").Value

-If B673 = C673 Then

-Range("D673").Value = "OK"

-Else

-Range("D673").Value = "NG"

-End If

-End Function

-

-Function test_XlUnderlineStyleSingleAccounting(ByRef num)

-Range("A674").Clear

-Range("B674").Clear

-Range("C674").Clear

-Range("D674").Clear

-Range("A674").Value = "XlUnderlineStyleSingleAccounting"

-Range("B674").Value = 4

-Range("C674").Value = num

-B674 = Range("B674").Value

-C674 = Range("C674").Value

-If B674 = C674 Then

-Range("D674").Value = "OK"

-Else

-Range("D674").Value = "NG"

-End If

-End Function

-

-Function test_XlUpdateLinksAlways(ByRef num)

-Range("A675").Clear

-Range("B675").Clear

-Range("C675").Clear

-Range("D675").Clear

-Range("A675").Value = "XlUpdateLinksAlways"

-Range("B675").Value = 3

-Range("C675").Value = num

-B675 = Range("B675").Value

-C675 = Range("C675").Value

-If B675 = C675 Then

-Range("D675").Value = "OK"

-Else

-Range("D675").Value = "NG"

-End If

-End Function

-

-Function test_XlUpdateLinksNever(ByRef num)

-Range("A676").Clear

-Range("B676").Clear

-Range("C676").Clear

-Range("D676").Clear

-Range("A676").Value = "XlUpdateLinksNever"

-Range("B676").Value = 2

-Range("C676").Value = num

-B676 = Range("B676").Value

-C676 = Range("C676").Value

-If B676 = C676 Then

-Range("D676").Value = "OK"

-Else

-Range("D676").Value = "NG"

-End If

-End Function

-

-Function test_XlUpdateLinksUserSetting(ByRef num)

-Range("A677").Clear

-Range("B677").Clear

-Range("C677").Clear

-Range("D677").Clear

-Range("A677").Value = "XlUpdateLinksUserSetting"

-Range("B677").Value = 1

-Range("C677").Value = num

-B677 = Range("B677").Value

-C677 = Range("C677").Value

-If B677 = C677 Then

-Range("D677").Value = "OK"

-Else

-Range("D677").Value = "NG"

-End If

-End Function

-

-Function test_xlVAlignBottom(ByRef num)

-Range("A678").Clear

-Range("B678").Clear

-Range("C678").Clear

-Range("D678").Clear

-Range("A678").Value = "xlVAlignBottom"

-Range("B678").Value = -4107

-Range("C678").Value = num

-B678 = Range("B678").Value

-C678 = Range("C678").Value

-If B678 = C678 Then

-Range("D678").Value = "OK"

-Else

-Range("D678").Value = "NG"

-End If

-End Function

-

-Function test_xlVAlignCenter(ByRef num)

-Range("A679").Clear

-Range("B679").Clear

-Range("C679").Clear

-Range("D679").Clear

-Range("A679").Value = "xlVAlignCenter"

-Range("B679").Value = -4108

-Range("C679").Value = num

-B679 = Range("B679").Value

-C679 = Range("C679").Value

-If B679 = C679 Then

-Range("D679").Value = "OK"

-Else

-Range("D679").Value = "NG"

-End If

-End Function

-

-Function test_xlVAlignDistributed(ByRef num)

-Range("A680").Clear

-Range("B680").Clear

-Range("C680").Clear

-Range("D680").Clear

-Range("A680").Value = "xlVAlignDistributed"

-Range("B680").Value = -4117

-Range("C680").Value = num

-B680 = Range("B680").Value

-C680 = Range("C680").Value

-If B680 = C680 Then

-Range("D680").Value = "OK"

-Else

-Range("D680").Value = "NG"

-End If

-End Function

-

-Function test_xlVAlignJustify(ByRef num)

-Range("A681").Clear

-Range("B681").Clear

-Range("C681").Clear

-Range("D681").Clear

-Range("A681").Value = "xlVAlignJustify"

-Range("B681").Value = -4130

-Range("C681").Value = num

-B681 = Range("B681").Value

-C681 = Range("C681").Value

-If B681 = C681 Then

-Range("D681").Value = "OK"

-Else

-Range("D681").Value = "NG"

-End If

-End Function

-

-Function test_xlVAlignTop(ByRef num)

-Range("A682").Clear

-Range("B682").Clear

-Range("C682").Clear

-Range("D682").Clear

-Range("A682").Value = "xlVAlignTop"

-Range("B682").Value = -4160

-Range("C682").Value = num

-B682 = Range("B682").Value

-C682 = Range("C682").Value

-If B682 = C682 Then

-Range("D682").Value = "OK"

-Else

-Range("D682").Value = "NG"

-End If

-End Function

-

-Function test_XlWBATChart(ByRef num)

-Range("A683").Clear

-Range("B683").Clear

-Range("C683").Clear

-Range("D683").Clear

-Range("A683").Value = "XlWBATChart"

-Range("B683").Value = -4109

-Range("C683").Value = num

-B683 = Range("B683").Value

-C683 = Range("C683").Value

-If B683 = C683 Then

-Range("D683").Value = "OK"

-Else

-Range("D683").Value = "NG"

-End If

-End Function

-

-Function test_XlWBATExcel4IntlMacroSheet(ByRef num)

-Range("A684").Clear

-Range("B684").Clear

-Range("C684").Clear

-Range("D684").Clear

-Range("A684").Value = "XlWBATExcel4IntlMacroSheet"

-Range("B684").Value = 4

-Range("C684").Value = num

-B684 = Range("B684").Value

-C684 = Range("C684").Value

-If B684 = C684 Then

-Range("D684").Value = "OK"

-Else

-Range("D684").Value = "NG"

-End If

-End Function

-

-Function test_XlWBATExcel4MacroSheet(ByRef num)

-Range("A685").Clear

-Range("B685").Clear

-Range("C685").Clear

-Range("D685").Clear

-Range("A685").Value = "XlWBATExcel4MacroSheet"

-Range("B685").Value = 3

-Range("C685").Value = num

-B685 = Range("B685").Value

-C685 = Range("C685").Value

-If B685 = C685 Then

-Range("D685").Value = "OK"

-Else

-Range("D685").Value = "NG"

-End If

-End Function

-

-Function test_XlWBATWorksheet(ByRef num)

-Range("A686").Clear

-Range("B686").Clear

-Range("C686").Clear

-Range("D686").Clear

-Range("A686").Value = "XlWBATWorksheet"

-Range("B686").Value = -4167

-Range("C686").Value = num

-B686 = Range("B686").Value

-C686 = Range("C686").Value

-If B686 = C686 Then

-Range("D686").Value = "OK"

-Else

-Range("D686").Value = "NG"

-End If

-End Function

-

-Function test_xlWebFormattingAll(ByRef num)

-Range("A687").Clear

-Range("B687").Clear

-Range("C687").Clear

-Range("D687").Clear

-Range("A687").Value = "xlWebFormattingAll"

-Range("B687").Value = 1

-Range("C687").Value = num

-B687 = Range("B687").Value

-C687 = Range("C687").Value

-If B687 = C687 Then

-Range("D687").Value = "OK"

-Else

-Range("D687").Value = "NG"

-End If

-End Function

-

-Function test_xlWebFormattingNone(ByRef num)

-Range("A688").Clear

-Range("B688").Clear

-Range("C688").Clear

-Range("D688").Clear

-Range("A688").Value = "xlWebFormattingNone"

-Range("B688").Value = 3

-Range("C688").Value = num

-B688 = Range("B688").Value

-C688 = Range("C688").Value

-If B688 = C688 Then

-Range("D688").Value = "OK"

-Else

-Range("D688").Value = "NG"

-End If

-End Function

-

-Function test_xlWebFormattingRTF(ByRef num)

-Range("A689").Clear

-Range("B689").Clear

-Range("C689").Clear

-Range("D689").Clear

-Range("A689").Value = "xlWebFormattingRTF"

-Range("B689").Value = 2

-Range("C689").Value = num

-B689 = Range("B689").Value

-C689 = Range("C689").Value

-If B689 = C689 Then

-Range("D689").Value = "OK"

-Else

-Range("D689").Value = "NG"

-End If

-End Function

-

-Function test_xlAllTables(ByRef num)

-Range("A690").Clear

-Range("B690").Clear

-Range("C690").Clear

-Range("D690").Clear

-Range("A690").Value = "xlAllTables"

-Range("B690").Value = 2

-Range("C690").Value = num

-B690 = Range("B690").Value

-C690 = Range("C690").Value

-If B690 = C690 Then

-Range("D690").Value = "OK"

-Else

-Range("D690").Value = "NG"

-End If

-End Function

-

-Function test_xlEntirePage(ByRef num)

-Range("A691").Clear

-Range("B691").Clear

-Range("C691").Clear

-Range("D691").Clear

-Range("A691").Value = "xlEntirePage"

-Range("B691").Value = 1

-Range("C691").Value = num

-B691 = Range("B691").Value

-C691 = Range("C691").Value

-If B691 = C691 Then

-Range("D691").Value = "OK"

-Else

-Range("D691").Value = "NG"

-End If

-End Function

-

-Function test_xlSpecifiedTables(ByRef num)

-Range("A692").Clear

-Range("B692").Clear

-Range("C692").Clear

-Range("D692").Clear

-Range("A692").Value = "xlSpecifiedTables"

-Range("B692").Value = 3

-Range("C692").Value = num

-B692 = Range("B692").Value

-C692 = Range("C692").Value

-If B692 = C692 Then

-Range("D692").Value = "OK"

-Else

-Range("D692").Value = "NG"

-End If

-End Function

-

-Function test_xlMaximized(ByRef num)

-Range("A693").Clear

-Range("B693").Clear

-Range("C693").Clear

-Range("D693").Clear

-Range("A693").Value = "xlMaximized"

-Range("B693").Value = -4137

-Range("C693").Value = num

-B693 = Range("B693").Value

-C693 = Range("C693").Value

-If B693 = C693 Then

-Range("D693").Value = "OK"

-Else

-Range("D693").Value = "NG"

-End If

-End Function

-

-Function test_xlMinimized(ByRef num)

-Range("A694").Clear

-Range("B694").Clear

-Range("C694").Clear

-Range("D694").Clear

-Range("A694").Value = "xlMinimized"

-Range("B694").Value = -4140

-Range("C694").Value = num

-B694 = Range("B694").Value

-C694 = Range("C694").Value

-If B694 = C694 Then

-Range("D694").Value = "OK"

-Else

-Range("D694").Value = "NG"

-End If

-End Function

-

-Function test_xlNormal(ByRef num)

-Range("A695").Clear

-Range("B695").Clear

-Range("C695").Clear

-Range("D695").Clear

-Range("A695").Value = "xlNormal"

-Range("B695").Value = -4143

-Range("C695").Value = num

-B695 = Range("B695").Value

-C695 = Range("C695").Value

-If B695 = C695 Then

-Range("D695").Value = "OK"

-Else

-Range("D695").Value = "NG"

-End If

-End Function

-

-Function test_xlChartAsWindow(ByRef num)

-Range("A696").Clear

-Range("B696").Clear

-Range("C696").Clear

-Range("D696").Clear

-Range("A696").Value = "xlChartAsWindow"

-Range("B696").Value = 5

-Range("C696").Value = num

-B696 = Range("B696").Value

-C696 = Range("C696").Value

-If B696 = C696 Then

-Range("D696").Value = "OK"

-Else

-Range("D696").Value = "NG"

-End If

-End Function

-

-Function test_xlChartInPlace(ByRef num)

-Range("A697").Clear

-Range("B697").Clear

-Range("C697").Clear

-Range("D697").Clear

-Range("A697").Value = "xlChartInPlace"

-Range("B697").Value = 4

-Range("C697").Value = num

-B697 = Range("B697").Value

-C697 = Range("C697").Value

-If B697 = C697 Then

-Range("D697").Value = "OK"

-Else

-Range("D697").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboard(ByRef num)

-Range("A698").Clear

-Range("B698").Clear

-Range("C698").Clear

-Range("D698").Clear

-Range("A698").Value = "xlClipboard"

-Range("B698").Value = 3

-Range("C698").Value = num

-B698 = Range("B698").Value

-C698 = Range("C698").Value

-If B698 = C698 Then

-Range("D698").Value = "OK"

-Else

-Range("D698").Value = "NG"

-End If

-End Function

-

-Function test_xlInfo(ByRef num)

-Range("A699").Clear

-Range("B699").Clear

-Range("C699").Clear

-Range("D699").Clear

-Range("A699").Value = "xlInfo"

-Range("B699").Value = -4129

-Range("C699").Value = num

-B699 = Range("B699").Value

-C699 = Range("C699").Value

-If B699 = C699 Then

-Range("D699").Value = "OK"

-Else

-Range("D699").Value = "NG"

-End If

-End Function

-

-Function test_xlWordbook(ByRef num)

-Range("A700").Clear

-Range("B700").Clear

-Range("C700").Clear

-Range("D700").Clear

-Range("A700").Value = "xlWordbook"

-Range("B700").Value = 1

-Range("C700").Value = num

-B700 = Range("B700").Value

-C700 = Range("C700").Value

-If B700 = C700 Then

-Range("D700").Value = "OK"

-Else

-Range("D700").Value = "NG"

-End If

-End Function

-

-Function test_xlNormalView(ByRef num)

-Range("A701").Clear

-Range("B701").Clear

-Range("C701").Clear

-Range("D701").Clear

-Range("A701").Value = "xlNormalView"

-Range("B701").Value = 1

-Range("C701").Value = num

-B701 = Range("B701").Value

-C701 = Range("C701").Value

-If B701 = C701 Then

-Range("D701").Value = "OK"

-Else

-Range("D701").Value = "NG"

-End If

-End Function

-

-Function test_xlPageBreakPreview(ByRef num)

-Range("A702").Clear

-Range("B702").Clear

-Range("C702").Clear

-Range("D702").Clear

-Range("A702").Value = "xlPageBreakPreview"

-Range("B702").Value = 2

-Range("C702").Value = num

-B702 = Range("B702").Value

-C702 = Range("C702").Value

-If B702 = C702 Then

-Range("D702").Value = "OK"

-Else

-Range("D702").Value = "NG"

-End If

-End Function

-

-Function test_xlCommand(ByRef num)

-Range("A703").Clear

-Range("B703").Clear

-Range("C703").Clear

-Range("D703").Clear

-Range("A703").Value = "xlCommand"

-Range("B703").Value = 2

-Range("C703").Value = num

-B703 = Range("B703").Value

-C703 = Range("C703").Value

-If B703 = C703 Then

-Range("D703").Value = "OK"

-Else

-Range("D703").Value = "NG"

-End If

-End Function

-

-Function test_xlFunction(ByRef num)

-Range("A704").Clear

-Range("B704").Clear

-Range("C704").Clear

-Range("D704").Clear

-Range("A704").Value = "xlFunction"

-Range("B704").Value = 1

-Range("C704").Value = num

-B704 = Range("B704").Value

-C704 = Range("C704").Value

-If B704 = C704 Then

-Range("D704").Value = "OK"

-Else

-Range("D704").Value = "NG"

-End If

-End Function

-

-Function test_xlnotXLM(ByRef num)

-Range("A705").Clear

-Range("B705").Clear

-Range("C705").Clear

-Range("D705").Clear

-Range("A705").Value = "xlnotXLM"

-Range("B705").Value = 3

-Range("C705").Value = num

-B705 = Range("B705").Value

-C705 = Range("C705").Value

-If B705 = C705 Then

-Range("D705").Value = "OK"

-Else

-Range("D705").Value = "NG"

-End If

-End Function

-

-Function test_xlXmlExportSuccess(ByRef num)

-Range("A706").Clear

-Range("B706").Clear

-Range("C706").Clear

-Range("D706").Clear

-Range("A706").Value = "xlXmlExportSuccess"

-Range("B706").Value = 0

-Range("C706").Value = num

-B706 = Range("B706").Value

-C706 = Range("C706").Value

-If B706 = C706 Then

-Range("D706").Value = "OK"

-Else

-Range("D706").Value = "NG"

-End If

-End Function

-

-Function test_xlXmlExportValidationFailed(ByRef num)

-Range("A707").Clear

-Range("B707").Clear

-Range("C707").Clear

-Range("D707").Clear

-Range("A707").Value = "xlXmlExportValidationFailed"

-Range("B707").Value = 1

-Range("C707").Value = num

-B707 = Range("B707").Value

-C707 = Range("C707").Value

-If B707 = C707 Then

-Range("D707").Value = "OK"

-Else

-Range("D707").Value = "NG"

-End If

-End Function

-

-Function test_xlXmlImportElementsTruncated(ByRef num)

-Range("A708").Clear

-Range("B708").Clear

-Range("C708").Clear

-Range("D708").Clear

-Range("A708").Value = "xlXmlImportElementsTruncated"

-Range("B708").Value = 1

-Range("C708").Value = num

-B708 = Range("B708").Value

-C708 = Range("C708").Value

-If B708 = C708 Then

-Range("D708").Value = "OK"

-Else

-Range("D708").Value = "NG"

-End If

-End Function

-

-Function test_xlXmlImportSuccess(ByRef num)

-Range("A709").Clear

-Range("B709").Clear

-Range("C709").Clear

-Range("D709").Clear

-Range("A709").Value = "xlXmlImportSuccess"

-Range("B709").Value = 0

-Range("C709").Value = num

-B709 = Range("B709").Value

-C709 = Range("C709").Value

-If B709 = C709 Then

-Range("D709").Value = "OK"

-Else

-Range("D709").Value = "NG"

-End If

-End Function

-

-Function test_xlXmlImportValidationFailed(ByRef num)

-Range("A710").Clear

-Range("B710").Clear

-Range("C710").Clear

-Range("D710").Clear

-Range("A710").Value = "xlXmlImportValidationFailed"

-Range("B710").Value = 2

-Range("C710").Value = num

-B710 = Range("B710").Value

-C710 = Range("C710").Value

-If B710 = C710 Then

-Range("D710").Value = "OK"

-Else

-Range("D710").Value = "NG"

-End If

-End Function

-

-Function test_xlXmlLoadImportToList(ByRef num)

-Range("A711").Clear

-Range("B711").Clear

-Range("C711").Clear

-Range("D711").Clear

-Range("A711").Value = "xlXmlLoadImportToList"

-Range("B711").Value = 2

-Range("C711").Value = num

-B711 = Range("B711").Value

-C711 = Range("C711").Value

-If B711 = C711 Then

-Range("D711").Value = "OK"

-Else

-Range("D711").Value = "NG"

-End If

-End Function

-

-Function test_xlXmlLoadMapXml(ByRef num)

-Range("A712").Clear

-Range("B712").Clear

-Range("C712").Clear

-Range("D712").Clear

-Range("A712").Value = "xlXmlLoadMapXml"

-Range("B712").Value = 3

-Range("C712").Value = num

-B712 = Range("B712").Value

-C712 = Range("C712").Value

-If B712 = C712 Then

-Range("D712").Value = "OK"

-Else

-Range("D712").Value = "NG"

-End If

-End Function

-

-Function test_xlXmlLoadOpenXml(ByRef num)

-Range("A713").Clear

-Range("B713").Clear

-Range("C713").Clear

-Range("D713").Clear

-Range("A713").Value = "xlXmlLoadOpenXml"

-Range("B713").Value = 1

-Range("C713").Value = num

-B713 = Range("B713").Value

-C713 = Range("C713").Value

-If B713 = C713 Then

-Range("D713").Value = "OK"

-Else

-Range("D713").Value = "NG"

-End If

-End Function

-

-Function test_xlXmlLoadPromptUser(ByRef num)

-Range("A714").Clear

-Range("B714").Clear

-Range("C714").Clear

-Range("D714").Clear

-Range("A714").Value = "xlXmlLoadPromptUser"

-Range("B714").Value = 0

-Range("C714").Value = num

-B714 = Range("B714").Value

-C714 = Range("C714").Value

-If B714 = C714 Then

-Range("D714").Value = "OK"

-Else

-Range("D714").Value = "NG"

-End If

-End Function

-

-Function test_xlGuess(ByRef num)

-Range("A715").Clear

-Range("B715").Clear

-Range("C715").Clear

-Range("D715").Clear

-Range("A715").Value = "xlGuess"

-Range("B715").Value = 0

-Range("C715").Value = num

-B715 = Range("B715").Value

-C715 = Range("C715").Value

-If B715 = C715 Then

-Range("D715").Value = "OK"

-Else

-Range("D715").Value = "NG"

-End If

-End Function

-

-Function test_xlNo(ByRef num)

-Range("A716").Clear

-Range("B716").Clear

-Range("C716").Clear

-Range("D716").Clear

-Range("A716").Value = "xlNo"

-Range("B716").Value = 2

-Range("C716").Value = num

-B716 = Range("B716").Value

-C716 = Range("C716").Value

-If B716 = C716 Then

-Range("D716").Value = "OK"

-Else

-Range("D716").Value = "NG"

-End If

-End Function

-

-Function test_xlYes(ByRef num)

-Range("A717").Clear

-Range("B717").Clear

-Range("C717").Clear

-Range("D717").Clear

-Range("A717").Value = "xlYes"

-Range("B717").Value = 1

-Range("C717").Value = num

-B717 = Range("B717").Value

-C717 = Range("C717").Value

-If B717 = C717 Then

-Range("D717").Value = "OK"

-Else

-Range("D717").Value = "NG"

-End If

-End Function

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'ProjectFoo'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Simple
->>>>>>
-Attribute VB_Name = "Simple"

-Function SGetThree()

-SGetThree = 3

-End Function

-

-Function SLoop()

-Dim i As Integer

-Dim j As Integer

-j = 0

-For i = 0 To 10

-    j = j + 1

-Next i

-SLoop = j

-End Function

-

-Function SNoRetVal()

-End Function

-<<<<<<
-======================
-MoreComplex
->>>>>>
-Attribute VB_Name = "MoreComplex"

-Function MGetThree()

-MGetThree = 3

-If MGetThree = 2 Then

- MsgBox ("Hello World")

-End If

-End Function

-

-Function MLoop()

-Dim i As Integer

-Dim j As Integer

-j = 0

-For i = 0 To 10

-    j = j + 1

-Next i

-If j = 17 Then

-    MLoop = Application.Sum(Range("A1:A10"))

-End If

-MLoop = j

-End Function

-

-Function MNoRetVal()

-Dim i As Integer

-End Function

-<<<<<<
-======================
-Real
->>>>>>
-Attribute VB_Name = "Real"

-Function CtoF(Centigrade)

-  CtoF = Centigrade * 9 / 5 + 32

-End Function

-

-Function WsF(Angle)

-  WsF = WorksheetFunction.Sinh(Angle)

-End Function

-<<<<<<
-======================
-FuncVal
->>>>>>
-Attribute VB_Name = "FuncVal"

-Function MyString()

-MyString = "teststring"

-End Function

-

-Function MyDouble()

-MyDouble = 1 / 8

-End Function

-

-Function MyBoolean()

-MyBoolean = False

-End Function

-

-Function MyInt()

-MyInt = 7

-End Function

-

-Function TakeOneArg(arg1)

-TakeOneArg = arg1

-End Function

-

-Function TakeTwoArgs(arg1, arg2)

-TakeTwoArgs = arg2

-End Function

-

-Function TakeThreeArgs(arg1, arg2, arg3)

-TakeThreeArgs = arg3

-End Function

-

-Function ContainsComment()

-Rem This is a comment

-ContainsComment = 3

-End Function

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-   

-    On Error Resume Next

-    Worksheets("Example4").ChartObjects.Delete

- 

-End Sub

-

-Private Sub Workbook_Open()

-    Worksheets("Change History").Activate

-    Range("VersionStart").Select

-    Selection.End(xlDown).Select

-    Selection.Copy (Worksheets("Overview").Range("VersionNumber"))

-    

-    On Error Resume Next

-    Worksheets("Example4").ChartObjects.Delete

-    

-    Worksheets("Overview").Activate

-    Range("A1").Activate

-

-End Sub

-<<<<<<
-======================
-UserForm1
->>>>>>
-Attribute VB_Name = "UserForm1"

-Attribute VB_Base = "0{DFA44B18-A9D7-11DA-9F20-0000E8226B19}{DFA44B00-A9D7-11DA-9F20-0000E8226B19}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-Dim ComboChoices()

-Private Sub CheckBox1_Click()

-

-End Sub

-

-Private Sub ComboBox1_Change()

-

-End Sub

-

-Private Sub CommandButton1_Click()

-    With UserForm1

-        .ValueOfTextBox.Value = .TextBox1.Value

-        .StateOfCheckBox.Value = .CheckBox1.Value

-        .StateOfOption1.Value = .OptionButton1.Value

-        .StateOfOption2.Value = .OptionButton2.Value

-        

-        If .ComboBox1.ListIndex > -1 Then

-            .SelectedItemComboBox.Value = ComboChoices(.ComboBox1.ListIndex)

-        Else

-            .SelectedItemComboBox.Value = "Unkown"

-        End If

-    End With

-End Sub

-

-Private Sub Label2_Click()

-

-End Sub

-

-Private Sub OptionButton1_Click()

-

-End Sub

-

-Private Sub Label3_Click()

-

-End Sub

-

-Private Sub UserForm_Click()

-

-End Sub

-

-Private Sub UserForm_Initialize()

-    ComboChoices = Array("Choice1", "Choice2", "Choice3")

-    With UserForm1.ComboBox1

-        .AddItem ComboChoices(0)

-        .AddItem ComboChoices(1)

-        .AddItem ComboChoices(2)

-    End With

-    

-    With UserForm1

-        .ValueOfTextBox.Value = ""

-        .StateOfCheckBox.Value = ""

-        .StateOfOption1.Value = ""

-        .StateOfOption2.Value = ""

-        .SelectedItemComboBox.Value = ""

-    End With

-    

-End Sub

-

-Private Sub ValueOfTextBox_Change()

-

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("WbkInformationArea").ClearContents

-    Application.Wait (Now() + TimeValue("00:00:01"))

-    Range("WbkPath").Value = ActiveWorkbook.Path

-    Range("WbkActiveWorkbook") = ActiveWorkbook.Name

-    Range("WbkActiveWorksheet") = ActiveSheet.Name

-    Range("WbkActiveCell") = ActiveCell.Address

-    Range("CurrentDateTime") = Now()

-    Range("WkShNameArea").ClearContents

-    Call ListAllWorksheets

-End Sub

-

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("WbkActiveCell") = Target.Address

-    Range("CurrentDateTime") = Now()

-End Sub

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CommandButton3Ex5, 3, 2, MSForms, CommandButton"

-

-Private Sub CommandButton3Ex5_Click()

-    Call ElementOperations

-End Sub

-

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Not (Intersect(Target, Range("MyCell")) Is Nothing) Then

-        Select Case LCase(Target.Value)

-            Case "a", "e", "i", "o", "u"

-                Range("MsgCell").Value = "vowel"

-                

-            Case "b" To "d", "f" To "h", "j" To "n", "p" To "t", "v" To "z"

-                Range("MsgCell").Value = "consonant"

-            

-            Case 0 To 9

-                Range("MsgCell").Value = "number"

-                

-            Case Else

-                Range("MsgCell").Value = "unknown"

-        End Select

-        Target.Select

-    End If

-    

-    If Not (Intersect(Target, Range("MyVector")) Is Nothing) Then

-        Range("ElementProduct").ClearContents

-        Range("ElementSum").ClearContents

-    End If

-End Sub

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CommandButton1Ex4, 2, 0, MSForms, CommandButton"

-Private Sub CommandButton1Ex4_Click()

-    Call GenerateChart

-End Sub

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CommandButtonEx6, 1, 0, MSForms, CommandButton"

-Private Sub CommandButtonEx6_Click()

-        MsgBox "Button Click recognized"

-End Sub

-

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CommandButton2Ex2, 2, 1, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton3Ex2, 3, 2, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton4Ex2, 5, 4, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton5Ex2, 6, 5, MSForms, CommandButton"

-Private Sub CommandButton1Ex2_Click()

-    Call getApplProperties

-End Sub

-

-Private Sub CommandButton2Ex2_Click()

-    Call generateDataToSort

-End Sub

-

-Private Sub CommandButton3Ex2_Click()

-    Call SortWithScreenUpdating

-End Sub

-

-Private Sub CommandButton4Ex2_Click()

-    Call SortWithNoScreenUpdating

-End Sub

-

-Private Sub CommandButton5Ex2_Click()

-    Call generateDataToSort

-End Sub

-

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-

-End Sub

-<<<<<<
-======================
-SampleCode
->>>>>>
-Attribute VB_Name = "SampleCode"

-'''

-''' Contains various VBA coding examples on accessing the Application Object

-'''

-Option Explicit

-

-Sub generateDataToSort()

-    Dim i As Integer

-    

-    With Range("SortArray")

-        For i = 1 To .Rows.Count

-            .Cells(i) = Int((100 * Rnd) + 1)    ' Generate random value between 1 and 100.

-        Next i

-    End With

-

-End Sub

-

-Sub SortWithScreenUpdating()

-    Application.ScreenUpdating = True

-    Call BubbleSort(Range("SortArray"))

-    Range("SortArray").Select

-    MsgBox "Sorting Completed"

-End Sub

-Sub SortWithNoScreenUpdating()

-    Application.ScreenUpdating = False

-    Call BubbleSort(Range("SortArray"))

-    Range("SortArray").Select

-    Application.ScreenUpdating = True

-    MsgBox "Sorting Completed"

-End Sub

-

-Sub BubbleSort(rngToSort As Range)

-    Dim i, j As Integer

-    Dim Temp As Variant

-

-    With rngToSort

-        For j = .Rows.Count To 1 Step -1

-            For i = 1 To j

-                .Cells(i).Interior.ColorIndex = 6

-                .Cells(j).Interior.ColorIndex = 8

-                Application.Wait (Now + TimeValue("0:00:01"))

-                If .Cells(i) > .Cells(j) Then

-                    Temp = .Cells(i)

-                    .Cells(i) = .Cells(j)

-                    .Cells(j) = Temp

-                End If

-                .Cells(i).Interior.ColorIndex = xlColorIndexNone

-                .Cells(j).Interior.ColorIndex = xlColorIndexNone

-            Next i

-        Next j

-    

-    End With

-

-End Sub

-

-Sub ElementOperations()

-    Range("ElementProduct").Value = WorksheetFunction.Sum(Range("MyVector"))

-    Range("ElementSum").Value = WorksheetFunction.Product(Range("MyVector"))

-End Sub

-

-Sub ListAllWorksheets()

-    Dim wksh As Worksheet

-    Dim i As Integer

-    

-    With Range("WkShNames")

-        i = 1

-        For Each wksh In ActiveWorkbook.Worksheets

-            .Cells(i).Value = wksh.Name

-            i = i + 1

-        Next

-    End With

-

-End Sub

-

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CommandButton1Ex7, 1, 0, MSForms, CommandButton"

-Private Sub CommandButton1Ex7_Click()

-    UserForm1.Show

-End Sub

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ChartDemoCode
->>>>>>
-Attribute VB_Name = "ChartDemoCode"

-Sub GenerateChart()

-Attribute GenerateChart.VB_Description = "Macro recorded 5/14/2004 by Jim Thompson"

-Attribute GenerateChart.VB_ProcData.VB_Invoke_Func = " \n14"

-'

-' Macro2 Macro

-' Macro recorded 5/14/2004 by Jim Thompson

-'

-

-'

-    Range("ChartData").Select

-    Charts.Add

-    ActiveChart.ChartType = xlColumnClustered

-    ActiveChart.Name = "Sample Chart"

-    ActiveChart.SetSourceData Source:=Sheets("Example4").Range("ChartData"), PlotBy:= _

-        xlColumns

-    ActiveChart.Location Where:=xlLocationAsObject, Name:="Example4"

-    With ActiveChart

-        .HasTitle = True

-        .HasLegend = False

-        .ChartTitle.Characters.Text = "Sample Chart"

-        .Axes(xlCategory, xlPrimary).HasTitle = True

-        .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Category"

-        .Axes(xlValue, xlPrimary).HasTitle = True

-        .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Amount"

-    End With

-    

-    Range("ChartData").Select

-End Sub

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CommandButton1Ex3, 1, 0, MSForms, CommandButton"

-Private Sub CommandButton1Ex3_Click()

-    Application.Wait (Now + TimeValue("00:00:01"))

-    Range("UpperLeftCell").Select

-    Range("RangeAddress") = Selection.Address

-    Application.Wait (Now + TimeValue("00:00:01"))

-    Selection.End(xlToRight).Select

-    Range("RangeAddress") = Selection. _

-          Address

-    Application.Wait (Now + TimeValue("00:00:01"))

-    Selection.End(xlDown).Select

-    Range("RangeAddress") = Selection.Address

-    Application.Wait (Now + TimeValue("00:00:01"))

-    Selection.End(xlToLeft).Select

-    Range("RangeAddress") = Selection.Address

-    Application.Wait (Now + TimeValue("00:00:01"))

-    Selection.End(xlUp).Select

-    Range("RangeAddress") = Selection.Address

-    Application.Wait (Now + TimeValue("00:00:01"))

-    Range(Selection, Selection.End(xlToRight)).Select

-    Range("RangeAddress") = Selection.Address

-    Application.Wait (Now + TimeValue("00:00:01"))

-    Range("UpperLeftCell").Select

-    Range("RangeAddress") = Selection.Address

-    Application.Wait (Now + TimeValue("00:00:01"))

-    Range(Selection, Selection.End(xlDown)).Select

-    Range("RangeAddress") = Selection.Address

-    Application.Wait (Now + TimeValue("00:00:01"))

-    Range("UpperLeftCell").Select

-    Range("RangeAddress") = Selection.Address

-    Application.Wait (Now + TimeValue("00:00:01"))

-    Selection.CurrentRegion.Select

-    Range("RangeAddress") = Selection.Address

-End Sub

-

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CommandButton1, 1, 0, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton2, 2, 1, MSForms, CommandButton"

-Private Sub CommandButton1_Click()

-test_main

-End Sub

-

-Private Sub CommandButton2_Click()

-init

-End Sub

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Option Base 1

-Dim numTests As Integer

-

-Sub init()

-numTests = 23

-reset_results

-End Sub

-Sub test_main()

-init

-On Error Resume Next ' comment out this line to help debug errors

-test1

-test2

-test3

-test4

-test5

-test6

-test7

-test8

-test9

-test10

-test11

-test12

-test13

-test14

-test15

-test16

-test17

-test18

-test19

-test20

-test21

-test22

-test23

-display_results

-End Sub

-

-

-' result for test 1 is in named range test1

-' Tests .Value property LHS assignment

-Sub test1()

-Range("B1").Value = 50

-If Range("B1").Value = 50 Then

-    Range("test1").Value = 1

-End If

-End Sub

-' result for test 2 is in named range test2

-' Tests ( default ) .Value property LHS assignment

-Sub test2()

-Range("B2") = 50

-If Range("B2").Value = 50 Then

-    Range("test2").Value = 1

-End If

-End Sub

-' result for test 3 is in named range test3

-' Tests RHS .Value property assignment

-

-Sub test3()

-Dim testVal As Integer

-testVal = 99

-Range("B3").Value = 50

-testVal = Range("B3").Value

-If testVal = 50 Then

-    Range("test3").Value = 1

-End If

-End Sub

-

-' result for test 4 is in named range test4

-' Tests RHS .Value default property assignment

-

-Sub test4()

-Dim testVal As Integer

-testVal = 99

-Range("B4").Value = 50

-testVal = Range("B4")

-If testVal = 50 Then

-    Range("test4").Value = 1

-End If

-End Sub

-' result for test 5 is in named range test5

-' Tests Range("XX") = Range("YY").Value ( lhs) default value property assignment

-' LHS is a cleared cell

-Sub test5()

-Range("B5").Value = 50

-Range("B6") = Range("B5").Value

-If Range("B6").Value = 50 Then

-    Range("test5").Value = 1

-End If

-

-End Sub

-

-' result for test 6 is in named range test6

-' Tests Range("XX").Value = Range("YY") ( rhs) default value property access

-' LHS is a cleared cell

-Sub test6()

-Range("B7").Value = 50

-Range("B8").Value = Range("B7")

-If Range("B8").Value = 50 Then

-    Range("test6").Value = 1

-End If

-End Sub

-' result for test 7 is in named range test7

-' Tests Range("XX") = Range("YY")

-' (rhs) default value property access

-' (lhs) default value property set

-' LHS is a cleared cell

-Sub test7()

-Range("B9").Value = 50

-Range("B10") = Range("B9")

-If Range("B10").Value = 50 Then

-    Range("test7").Value = 1

-End If

-End Sub

-

-' result for test 8 is in named range test8

-' Tests set objectVariable to a Range("YY") object

-Sub test8()

-Dim aRange As Object

-Range("B11") = 99

-Set aRange = Range("B11")

-If aRange.Value = 99 Then

-    Range("test8").Value = 1

-End If

-End Sub

-' result for test 9 is in named range test9

-' Tests Multiplication of a range, in Openoffice

-' val = Range("B12") * 0.1

-' this was failing due to Range("B12") getting overwritten

-' with the result of the calculation e.g. Range("B12") had 9 if

-' initial value of B12 was 90

-Sub test9()

-Range("B12").Value = 90

-Dim val As Integer

-val = 0

-val = (Range("B12") * 0.1)

-Range("B13") = val

-If Range("B13").Value = 9 And Range("B12").Value = 90 Then

-    Range("test9").Value = 1

-End If

-End Sub

-' result for test 10 is in named range test10

-' Tests multiplication of Range, there was a bug

-' in OO where "B15" in the test below would be overwritten

-' with 10

-Sub test10()

-Range("B15") = 100

-Range("B14") = (Range("B15") * 0.1)

-If Range("B14").Value = 10 And Range("B15") = 100 Then

-    Range("test10").Value = 1

-End If

-

-End Sub

-

-

-' result for test 11 is in named range test11

-' test the result of a 2-Dim range value prop

-' which should be a 2 Dim array containing the values

-' as set up in the tests below

-' e.g.

-' 1 4 7 10

-' 2 5 8 11

-' 3 6 9 12

-

-Sub test11()

-Dim testDatasc1

-Dim testDatasc2

-Dim testDatasc3

-Dim testDatasc4

-Dim cellNamesc1

-Dim cellNamesc2

-Dim cellNamesc3

-

-Dim cellName As String

-Dim cellval As Integer

-Dim colValues()

-

-testDatac1 = Array(1, 2, 3)

-testDatac2 = Array(4, 5, 6)

-testDatac3 = Array(7, 8, 9)

-testDatac4 = Array(10, 11, 12)

-

-colValues = Array(testDatac1, testDatac2, testDatac3, testDatac4)

-

-cellNamesc1 = Array("D1", "D2", "D3")

-cellNamesc2 = Array("E1", "E2", "E3")

-cellNamesc3 = Array("F1", "F2", "F3")

-cellNamesc4 = Array("G1", "G2", "G3")

-

-' set cellnames with values

-arrayset cellNamesc1, testDatac1

-arrayset cellNamesc2, testDatac2

-arrayset cellNamesc3, testDatac3

-arrayset cellNamesc4, testDatac4

-

-Dim contents As Variant

-Dim colcontents As Variant

-

-' get contents of range

-

-contents = Range("D1:G3").Value

-Dim lcol As Integer

-Dim ucol As Integer

-Dim col As Integer

-lcol = LBound(contents, 2)

-ucol = UBound(contents, 2)

-Dim res As Integer

-result = 1 ' success

-

-' check values

-For col = lcol To ucol

-

-    colcontents = getCol(contents, col)

-    For counter = LBound(colcontents) To UBound(colcontents)

-        'MsgBox " content of col " & col & " index " & counter & " has value " & colcontents(counter)

-        If checkarray(colcontents, colValues(col)) = False Then

-            result = -1

-            Exit For

-        End If

-        

-    Next counter

-Range("test11").Value = result

-Next col

-

-

-' note

-' Range("D4:G6") = Range("D1:G3") does not do a copy

-' nor does Range("D4:G6") = Range("D1:G3".Value

-' or Range("D4:G6").Value = Range("D1:G3")

-End Sub

-

-' tests a copy of a multicell range to

-' a multi cell range of the same dimensions

-

-Sub test12()

-

-Dim testDatasc1

-Dim testDatasc2

-Dim testDatasc3

-Dim testDatasc4

-Dim cellNamesc1

-Dim cellNamesc2

-Dim cellNamesc3

-

-Dim cellName As String

-Dim cellval As Integer

-Dim colValues()

-

-testDatac1 = Array(1, 2, 3)

-testDatac2 = Array(4, 5, 6)

-testDatac3 = Array(7, 8, 9)

-testDatac4 = Array(10, 11, 12)

-

-colValues = Array(testDatac1, testDatac2, testDatac3, testDatac4)

-

-cellNamesc1 = Array("D6", "D7", "D8")

-cellNamesc2 = Array("E6", "E7", "E8")

-cellNamesc3 = Array("F6", "F7", "F8")

-cellNamesc4 = Array("G6", "G7", "G8")

-' set cellnames with values

-arrayset cellNamesc1, testDatac1

-arrayset cellNamesc2, testDatac2

-arrayset cellNamesc3, testDatac3

-arrayset cellNamesc4, testDatac4

-

-Range("D9:G11").Value = Range("D6:G8").Value

-

-' Check the result of Range("D9:G11")

-Dim result As Integer

-result = 1 ' assume pass

-

-Dim origcontents

-Dim copycontents

-

-origcontents = Range("D6:G8").Value

-copycontents = Range("D9:G11").Value

-Dim lb1 As Integer

-Dim ub1 As Integer

-Dim lb2 As Integer

-Dim ub2 As Integer

-lb1 = LBound(origcontents, 1)

-ub1 = UBound(origcontents, 1)

-lb2 = LBound(origcontents, 2)

-ub2 = UBound(origcontents, 2)

-Dim i As Integer

-Dim j As Integer

-For i = lb1 To ub1

-    For j = lb2 To ub2

-        If copycontents(i, j) <> origcontents(i, j) Then

-            result = -1

-            Exit For

-        End If

-    Next j

-    If result = -1 Then

-        Exit For

-    End If

-    

-Next i

-Range("test12").Value = result

-End Sub

-

-' test setting Range.Value with 2 Dim array

-

-Sub test13()

-Dim dArray

-dArray = Range("D12:g14")

-Dim lb1 As Integer

-Dim ub1 As Integer

-Dim lb2 As Integer

-Dim ub2 As Integer

-lb1 = LBound(dArray, 1)

-ub1 = UBound(dArray, 1)

-lb2 = LBound(dArray, 2)

-ub2 = UBound(dArray, 2)

-Dim count As Integer

-For i = lb1 To ub1

-    For j = lb2 To ub2

-        dArray(i, j) = count

-        count = count + 1

-    Next j

-Next i

-Range("D12:g14").Value = dArray

-

-' get values for Range

-Dim contents

-Dim result As Integer

-result = 1

-contents = Range("D12:g14").Value

-

-' compare to values from array

-For i = lb1 To ub1

-    For j = lb2 To ub2

-        If contents(i, j) <> dArray(i, j) Then

-            result = -1

-            Exit For

-        End If

-        count = count + 1

-    Next j

-    If result = -1 Then

-        Exit For

-    End If

-Next i

-

-Range("test13").Value = result

-End Sub

-' test Range("XX").Value = number

-' the number should be applied over the range

-Sub test14()

-

-Dim contents

-Dim dValue As Integer

-dValue = 99

-Range("D16:F17").Value = dValue

-

-contents = Range("D16:F17").Value

-Dim lb1 As Integer

-Dim ub1 As Integer

-Dim lb2 As Integer

-Dim ub2 As Integer

-Dim result As Integer

-result = 1 '

-lb1 = LBound(contents, 1)

-ub1 = UBound(contents, 1)

-lb2 = LBound(contents, 2)

-ub2 = UBound(contents, 2)

-For i = lb1 To ub1

-    For j = lb2 To ub2

-        If contents(i, j) <> dValue Then

-            result = -1

-            Exit For

-        End If

-    If result = -1 Then

-        Exit For

-    End If

-    

-        

-    Next j

-Next i

-Range("test14").Value = result

-End Sub

-' test assigment of row Range to a single Array

-Sub test15()

-Dim testData()

-testData = Array(1, 2, 3, 4, 5)

-Range("A20:E20").Value = testData()

-Dim resultData()

-resultData = Range("A20:E20").Value

-Dim result As Integer

-result = 1 '

-RowIndex = LBound(resultData, 1)

-For count = LBound(resultData, 2) To UBound(resultData, 2)

-    If resultData(RowIndex, count) <> testData(count) Then

-        result = -1

-        Exit For

-    End If

-        

-    

-Next count

-Range("test15") = result

-End Sub

-

-' test assigment of col Range to a single Array

-

-Sub test16()

-Dim testData()

-testData = Array(1, 2, 3, 4, 5)

-Range("A21:A25").Value = testData()

-Dim resultData()

-resultData = Range("A21:A25").Value

-Dim result As Integer

-result = 1 '

-ColIndex = LBound(resultData, 2)

-For count = LBound(resultData, 1) To UBound(resultData, 1)

-    If resultData(count, ColIndex) <> testData(LBound(testData)) Then

-        result = -1

-        Exit For

-    End If

-        

-    

-Next count

-Range("test16") = result

-End Sub

-

-' test assigment of range to a single Array

-' to a Range of the same row size

-Sub test17()

-Dim testData()

-testData = Array(1, 2, 3, 4, 5)

-Range("A28:E29").Value = testData()

-

-Dim resultData()

-resultData = Range("A28:E29").Value

-Dim result As Integer

-result = 1 '

-

-For row = LBound(resultData, 1) To UBound(resultData, 1)

-    For col = LBound(resultData, 2) To UBound(resultData, 2)

-    'MsgBox row & "," & col & " = " & resultData(row, col)

-        If resultData(row, col) <> testData(col) Then

-            result = -1

-            Exit For

-        End If

-    Next col

-Next row

-Range("test17") = result

-End Sub

-' Test18 tests ActiveSheet.Range( Cell1, Cell2 ) method

-' results involve no offset, unlike Range.Range( Cell1, Cell2 )

-' simple range

-Sub test18()

-Dim result As Integer

-Range("c5").Select

-result = 1

-If ActiveSheet.Range(Range("a2"), Range("d5")).Address <> "$A$2:$D$5" Then

-    result = -1

-End If

-Range("test18") = result

-

-End Sub

-' Test19 tests ActiveSheet.Range( Cell1, Cell2 ) method

-' results involve no offset, unlike Range.Range( Cell1, Cell2 )

-' more complex range, the range selected is the greatest range defined

-' by overlap of Cell1 & Cell2

-Sub test19()

-Dim result As Integer

-Range("c5").Select

-result = 1

-If ActiveSheet.Range(Range("a2:d6"), Range("d5:d8")).Address <> "$A$2:$D$8" Then

-    result = -1

-End If

-Range("test19") = result

-

-End Sub

-

-Sub test20()

-Dim result As Integer

-result = 1

-If Range("c5").Range("a2").Address <> "$C$6" Then

-    result = -1

-End If

-Range("test20") = result

-End Sub

-

-

-Sub test21()

-Dim result As Integer

-result = 1

-If Range("c5:f10").Range("g4").Address <> "$I$8" Then

-    result = -1

-End If

-Range("test21") = result

-End Sub

-

-Sub test22()

-Dim result As Integer

-result = 1

-If Range("c5:c8").Range(Range("g4"), Range("l10")).Address <> "$I$8:$N$14" Then

-    result = -1

-End If

-Range("test22") = result

-End Sub

-Sub test23()

-Dim result As Integer

-result = 1

-If Range("c5:f10").Range("g4:i8").Address <> "$I$8:$K$12" Then

-    result = -1

-End If

-Range("test23") = result

-End Sub

-

-Function getCol(matrix As Variant, col As Integer) As Variant

-Dim lrow As Integer

-Dim urow As Integer

-Dim row As Integer

-lrow = LBound(matrix, 1)

-urow = UBound(matrix, 1)

-

-Dim column()

-ReDim column(urow)

-

-For row = lrow To urow

-    'column(row) = matrix(col, row)

-    Dim val As Integer

-    column(row) = matrix(row, col)

-Next row

-getCol = column()

-End Function

-Function checkarray(values As Variant, newvalues As Variant) As Boolean

-Dim count As Integer

-Dim result As Boolean

-result = True

-For count = LBound(values) To UBound(values)

-    If values(count) <> newvalues(count) Then

-        result = False

-        Exit For

-    End If

-Next count

-checkarray = result

-End Function

-Sub arrayset(names As Variant, values As Variant)

-Dim count As Integer

-Dim cellName As String

-Dim cellval As Integer

-

-For count = LBound(names) To UBound(values)

-    cellName = names(count)

-    cellval = values(count)

-    Range(cellName).Value = cellval

-Next count

-End Sub

-

-Sub reset_results()

-For count = 1 To numTests

-    Range("test" & count).Value = -1

-Next count

-' test 1

-Range("B1").Clear

-' test 2

-Range("B2").Clear

-' test 3

-Range("B3").Clear

-' test 4

-Range("B4").Clear

-' test 5

-Range("B5").Clear

-Range("B6").Clear

-' test 6

-Range("B7").Clear

-Range("B8").Clear

-' test 7

-Range("B9").Clear

-Range("B10").Clear

-' test 8

-Range("B11").Clear

-' test 9

-Range("B12").Clear

-Range("B13").Clear

-' test 10

-Range("B14").Clear

-Range("B15").Clear

-' test 11

-Range("D1:G3").Clear

-' test 12

-Range("D6:G8").Clear

-Range("D9:g11").Clear

-' test 13

-Range("D12:g14").Clear

-' test 14

-Range("D16:F17").Clear

-' test 15

-Range("A20:E20").Clear

-' test 16

-Range("A20:A25").Clear

-' test 17

-Range("A28:E29").Clear

-End Sub

-

-Sub display_results()

-Dim results As String

-Dim failed As String

-

-Dim count As Integer

-Dim testsRun As Integer

-

-For count = 1 To numTests

-    If testResult("test" & count) = False Then

-        failed = failed & "      test" & count & " failed" & Chr$(10)

-    Else

-        succeeded = succeeded + 1

-    End If

-Next count

-testsRun = count - 1

-results = results & "No. tests: " & numTests & Chr$(10)

-

-results = results & "Summary" & Chr$(10)

-results = results & "=======" & Chr$(10)

-results = results & "Run:       " & testsRun & Chr$(10)

-results = results & "Passed:    " & succeeded & Chr$(10)

-results = results & "Failed:    " & (testsRun - succeeded) & Chr$(10)

-results = results & failed

-results = results & Chr$(10) + "Expected Failure On OpenOffice: test13"

-MsgBox results

-End Sub

-

-Function testResult(arg As String) As Boolean

-If (Range(arg).Value = 1) Then

-    testResult = True

-Else

-    testResult = False

-End If

-End Function

-

-

-Sub tempStuff()

-

-' in openoffice a1 = 5, in xl its 50

-' the line below seems not do the expected in xl (?)

-Range("B1") = 50

-Range("A1").Value = (Range("B1").Value * 0.1)

-MsgBox ("A1 = " + Range("A1"))

-Range("A1") = Range("B1").Value

-Range("B2") = 100

-Range("B3") = Range("B2")

-MsgBox "B3 = " & Range("B3")

-

-val = Range("A1")

-MsgBox (Range("A1"))

-    

-'Range("A5:A8").Value =Range("A1:A4").Value

-MsgBox (val)

-End Sub

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Sub main()

-test (xlCellTypeAllFormatConditions)

-test2 (Excel.XlCellType.xlCellTypeAllValidation)

-test3 (XlCellType.xlCellTypeAllValidation)

-test4 xlCellTypeSameValidation

-End Sub

-

-Function test(ByRef num As Integer)

-MsgBox "test got " & num

-End Function

-

-Function test2(num)

-MsgBox "test2 got " & num

-End Function

-

-

-Function test3(num)

-MsgBox "test3 got " & num

-End Function

-

-Function test4(num)

-MsgBox "test4 got " & num

-End Function

-<<<<<<
-Project Name : 'VBProject'
-Quirk - duff tag length======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Option Explicit

-Dim NextTick

-

-Sub StartClock()

-    UpdateClock

-End Sub

-

-Sub StopClock()

-'   Cancels the OnTime event (stops the clock)

-    On Error Resume Next

-    Application.OnTime NextTick, "UpdateClock", , False

-End Sub

-

-Sub cbClockType_Click()

-'   Hides or unhids the clock

-    With ThisWorkbook.Sheets("Clock")

-        If .DrawingObjects("cbClockType").Value = xlOn Then

-            .ChartObjects("ClockChart").Visible = True

-        Else

-            .ChartObjects("ClockChart").Visible = False

-        End If

-    End With

-End Sub

-

-Sub UpdateClock()

-'   Updates the clock that's visible

-    Dim Clock As Chart

-    Set Clock = ThisWorkbook.Sheets("Clock").ChartObjects("ClockChart").Chart

-    

-    If Clock.Parent.Visible Then

-'       ANALOG CLOCK

-        Const PI As Double = 3.14159265358979

-        Dim CurrentSeries As Series

-        Dim s As Series

-        Dim x(1 To 2) As Variant

-        Dim v(1 To 2) As Variant

-    

-'       Hour hand

-        Set CurrentSeries = Clock.SeriesCollection("HourHand")

-        x(1) = 0

-        x(2) = 0.5 * Sin((Hour(Time) + (Minute(Time) / 60)) * (2 * PI / 12))

-        v(1) = 0

-        v(2) = 0.5 * Cos((Hour(Time) + (Minute(Time) / 60)) * (2 * PI / 12))

-        CurrentSeries.XValues = x

-        CurrentSeries.Values = v

-        

-'       Minute hand

-        Set CurrentSeries = Clock.SeriesCollection("MinuteHand")

-        x(1) = 0

-        x(2) = 0.8 * Sin((Minute(Time) + (Second(Time) / 60)) * (2 * PI / 60))

-        v(1) = 0

-        v(2) = 0.8 * Cos((Minute(Time) + (Second(Time) / 60)) * (2 * PI / 60))

-        CurrentSeries.XValues = x

-        CurrentSeries.Values = v

-    

-'       Second hand

-        Set CurrentSeries = Clock.SeriesCollection("SecondHand")

-        x(1) = 0

-        x(2) = 0.85 * Sin(Second(Time) * (2 * PI / 60))

-        v(1) = 0

-        v(2) = 0.85 * Cos(Second(Time) * (2 * PI / 60))

-        CurrentSeries.XValues = x

-        CurrentSeries.Values = v

-    Else

-'       DIGITAL CLOCK

-        ThisWorkbook.Sheets("Clock").Range("DigitalClock").Value = CDbl(Time)

-    End If

-    

-'   Set up the next event one second from now

-    NextTick = Now + TimeValue("00:00:01")

-    Application.OnTime NextTick, "UpdateClock"

-End Sub

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Private Sub Workbook_Open()

-    Call StartClock

-End Sub

-

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    Call StopClock

-End Sub

-

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Option Explicit

-

-' Developed by John Walkenbach

-' of JWalk and Associates

-' http://www.j-walk.com/ss/

-' Thanks to GeeDee for suggesting the animation and colors.

-

-Dim r As Long

-

-

-

-

-Sub Scroller_Click()

-    Range("FavoriteNum").Value = " "

-End Sub

-Sub RandomButton_Click()

-    Application.ScreenUpdating = False

-    Range("a_inc").Value = Rnd() * 1000

-    Range("b_inc").Value = Rnd() * 1000

-    Range("t_inc").Value = Rnd() * 1000

-    Range("FavoriteNum").Value = ""

-    Application.ScreenUpdating = True

-End Sub

-

-Sub NextFavoriteButton_Click()

-    Application.ScreenUpdating = False

-    r = Range("FavoriteNum").Value + 1

-    If r > Application.CountA(Range("Favorites").EntireColumn) Then r = 1

-    Range("a_inc").Value = Range("Favorites").Offset(r - 1, 0).Value

-    Range("b_inc").Value = Range("Favorites").Offset(r - 1, 1).Value

-    Range("t_inc").Value = Range("Favorites").Offset(r - 1, 2).Value

-    Range("FavoriteNum").Value = r

-    Application.ScreenUpdating = True

-End Sub

-

-Sub PreviousFavoriteButton_Click()

-    Application.ScreenUpdating = False

-    r = Range("FavoriteNum").Value - 1

-    If r <= 0 Then r = Application.CountA(Range("Favorites").EntireColumn)

-    Range("a_inc").Value = Range("Favorites").Offset(r - 1, 0).Value

-    Range("b_inc").Value = Range("Favorites").Offset(r - 1, 1).Value

-    Range("t_inc").Value = Range("Favorites").Offset(r - 1, 2).Value

-    Range("FavoriteNum").Value = r

-    Application.ScreenUpdating = True

-End Sub

-

-Sub AddToFavoritesButton_Cklick()

-Attribute AddToFavoritesButton_Cklick.VB_ProcData.VB_Invoke_Func = " \n14"

-    Dim EmptyStr As String

-    EmptyStr = ""

-    

-    If Range("FavoriteNum").Value = EmptyStr Then

-        Application.ScreenUpdating = False

-        Application.Calculation = xlCalculationManual

-        r = Application.CountA(Range("Favorites").EntireColumn) + 1

-        Range("FavoriteNum").Value = r

-        Cells(r, Range("Favorites").Column) = Range("a_inc").Value

-        Cells(r, Range("Favorites").Column + 1) = Range("b_inc").Value

-        Cells(r, Range("Favorites").Column + 2) = Range("t_inc").Value

-        Application.Calculation = xlCalculationAutomatic

-        Application.ScreenUpdating = True

-    End If

-End Sub

-

-

-

-

-

-Sub InfoButton_Click()

-    ChartIsAnimated = False

-    Sheets("Info").Activate

-    Range("A2").Select

-End Sub

-

-Sub ReturnButton_Click()

-    Sheets("Chart").Activate

-    Range("E4").Select

-End Sub

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Private Sub Workbook_Open()

-    ThisWorkbook.Windows(1).WindowState = xlNormal

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    If Range("CloseFlag") <> "Y" Then

-        Worksheets("Workbook Examples").Activate

-        Range("CloseFlag").Activate

-        MsgBox "CloseFlag Cell must be 'Y' to close workbook"

-        Cancel = True

-    End If

-End Sub

-

-Private Sub Workbook_Open()

-    Worksheets("Change History").Activate

-    Range("VersionStart").Select

-    Selection.End(xlDown).Select

-    Selection.Copy (Worksheets("Overview").Range("VersionNumber"))

-    Worksheets("Workbook Examples").Activate

-    Range("CloseFlag") = "N"

-    Worksheets("Overview").Activate

-    Range("A1").Activate

-

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CommandButton1, 1, 0, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton2, 2, 1, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton3, 4, 2, MSForms, CommandButton"

-Private Sub CommandButton1_Click()

-    Call ListAllWorksheets

-End Sub

-

-Private Sub CommandButton2_Click()

-    Call ClearWorksheetNames

-End Sub

-

-Private Sub CommandButton3_Click()

-    Call AddNewWorksheet

-End Sub

-

-Private Sub Worksheet_Activate()

-    MsgBox "This pop-up message is displayed whenever this worksheet is activated."

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-

-End Sub

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CommandButton1, 1, 0, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton2, 2, 1, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton3, 3, 2, MSForms, CommandButton"

-Private Sub CommandButton1_Click()

-    Call SelectToFromCells

-End Sub

-

-Private Sub CommandButton2_Click()

-    Call RotateMatrix

-End Sub

-

-Private Sub CommandButton3_Click()

-    Call ElementOperations

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Not (Intersect(Target, Range("MyCell")) Is Nothing) Then

-        Select Case LCase(Target.Value)

-            Case "a", "e", "i", "o", "u"

-                Range("MsgCell").Value = "vowel"

-                

-            Case "b" To "d", "f" To "h", "j" To "n", "p" To "t", "v" To "z"

-                Range("MsgCell").Value = "consonant"

-            

-            Case 0 To 9

-                Range("MsgCell").Value = "number"

-                

-            Case Else

-                Range("MsgCell").Value = "unknown"

-        End Select

-    End If

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-

-End Sub

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-WorksheetsVBACode
->>>>>>
-Attribute VB_Name = "WorksheetsVBACode"

-Sub AddNewWorksheet()

-    Dim wksh As Worksheet

-    

-    Set wksh = Worksheets.Add

-    wksh.Name = "MyNewSheet"

-End Sub

-Sub ListAllWorksheets()

-    Dim wksh As Worksheet

-    Dim i As Integer

-    

-    With Range("WkShNames")

-        i = 1

-        For Each wksh In ActiveWorkbook.Worksheets

-            .Cells(i).Value = wksh.Name

-            i = i + 1

-        Next

-    End With

-

-End Sub

-

-Sub ClearWorksheetNames()

-    Dim YesNoResponse As Integer

-    

-    Range("WkShNameArea").Select

-    

-    YesNoResponse = MsgBox("Clear Worksheet Name Area?", vbYesNo)

-    

-    If YesNoResponse = vbYes Then

-        Range("WkShNameArea").ClearContents

-

-    End If

-    

-    Range("a1").Select

-End Sub

-<<<<<<
-======================
-CellVBACode
->>>>>>
-Attribute VB_Name = "CellVBACode"

-Sub SelectToFromCells()

-    Range("FromCell", "ToCell").Select

-End Sub

-

-Sub RotateMatrix()

-    Dim i As Integer, j As Integer

-    Dim Temp As Variant

-    

-    With Range("MyMatrix")

-        Temp = .Cells(2, 1)

-        .Cells(2, 1) = .Cells(2, 2)

-        .Cells(2, 2) = .Cells(1, 2)

-        .Cells(1, 2) = .Cells(1, 1)

-        .Cells(1, 1) = Temp

-    End With

-End Sub

-

-

-Sub ElementOperations()

-    Dim i As Integer

-    Dim NumberOfElements As Integer

-    Dim ElementProduct As Double

-    Dim ElementSum As Double

-    

-    With Range("MyVector")

-        NumberOfElements = .Rows.Count

-        ElementProduct = 1

-        ElementSum = 0

-        For i = 1 To NumberOfElements

-            ElementProduct = ElementProduct * .Cells(i)

-            ElementSum = ElementSum + .Cells(i)

-        Next i

-    End With

-

-    Range("ElementProduct").Value = ElementProduct

-    Range("ElementSum").Value = ElementSum

-End Sub

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CommandButton1, 1, 0, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton2, 2, 1, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton3, 3, 2, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton4, 5, 4, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton5, 6, 5, MSForms, CommandButton"

-Private Sub CommandButton1_Click()

-    Call getApplProperties

-End Sub

-

-Private Sub CommandButton2_Click()

-    Call generateDataToSort

-End Sub

-

-Private Sub CommandButton3_Click()

-    Call SortWithScreenUpdating

-End Sub

-

-Private Sub CommandButton4_Click()

-    Call SortWithNoScreenUpdating

-End Sub

-

-Private Sub CommandButton5_Click()

-    Call generateDataToSort

-End Sub

-

-Private Sub Worksheet_Activate()

-    Range("ApplProperties").ClearContents

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-

-End Sub

-<<<<<<
-======================
-ApplicationCode
->>>>>>
-Attribute VB_Name = "ApplicationCode"

-'''

-''' Contains various VBA coding examples on accessing the Application Object

-'''

-Option Explicit

-

-

-Sub getApplProperties()

-    Range("ApplParent") = Application.Parent

-    Range("ApplPath") = Application.Path

-    Range("ApplActiveWorkbook") = Application.ActiveWorkbook.Name

-    Range("ApplActiveSheet") = Application.ActiveSheet.Name

-    Range("ApplActiveCell") = Application.ActiveCell.Address

-    

-End Sub

-

-

-Sub generateDataToSort()

-    Dim i As Integer

-    

-    With Range("SortArray")

-        For i = 1 To .Rows.Count

-            .Cells(i) = Int((100 * Rnd) + 1)    ' Generate random value between 1 and 100.

-        Next i

-    End With

-

-End Sub

-

-Sub SortWithScreenUpdating()

-    Application.ScreenUpdating = True

-    Call BubbleSort(Range("SortArray"))

-    Range("SortArray").Select

-    MsgBox "Sorting Completed"

-End Sub

-Sub SortWithNoScreenUpdating()

-    Application.ScreenUpdating = False

-    Call BubbleSort(Range("SortArray"))

-    Range("SortArray").Select

-    Application.ScreenUpdating = True

-    MsgBox "Sorting Completed"

-End Sub

-

-Sub BubbleSort(rngToSort As Range)

-    Dim i, j As Integer

-    Dim Temp As Variant

-

-    With rngToSort

-        For j = .Rows.Count To 1 Step -1

-            For i = 1 To j

-                .Cells(i).Interior.ColorIndex = 6

-                .Cells(j).Interior.ColorIndex = 8

-                Application.Wait (Now + TimeValue("0:00:01"))

-                If .Cells(i) > .Cells(j) Then

-                    Temp = .Cells(i)

-                    .Cells(i) = .Cells(j)

-                    .Cells(j) = Temp

-                End If

-                .Cells(i).Interior.ColorIndex = xlColorIndexNone

-                .Cells(j).Interior.ColorIndex = xlColorIndexNone

-            Next i

-        Next j

-    

-    End With

-

-End Sub

-

-

-

-

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Sub Macro1()

-Attribute Macro1.VB_Description = "Macro recorded 5/5/2004 by Jim Thompson"

-Attribute Macro1.VB_ProcData.VB_Invoke_Func = " \n14"

-'

-' Macro1 Macro

-' Macro recorded 5/5/2004 by Jim Thompson

-'

-

-'

-    Selection.End(xlDown).Select

-End Sub

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'Controls'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CommandButton1, 1, 0, MSForms, CommandButton"

-

-Private Sub CommandButton1_Click()

-ActiveSheet.Next.Select

-Rem Range("A1").Select - broken for some stupid reason

-Rem Selection.Copy

-Rem If Selection.EntireRow.Hidden = False Then

-Rem     MsgBox ("Selection Error")

-Rem End If

-ActiveSheet.Previous.Select

-End Sub

-<<<<<<
-======================
-Invocations
->>>>>>
-Attribute VB_Name = "Invocations"

-Rem       No defined return value

-

-Function INoReturnNoRet()

-End Function

-Function IGetThreeNoRet()

-IGetThreeNoRet = 3

-End Function

-Function IGetFooNoRet()

-IGetFooNoRet = "foo"

-End Function

-Function IGetPINoRet()

-IGetPINoRet = 3.1415926535898

-End Function

-

-Rem       Various return types

-

-Function IGetInteger() As Integer

-IGetInteger = 42

-End Function

-Function IGetString() As String

-IGetString = "baa"

-End Function

-Function IGetDouble() As Double

-IGetDouble = 3.1415926535898

-End Function

-Function IGetSingle() As Single

-IGetSingle = 23

-End Function

-Function IGetBoolean() As Boolean

-IGetBoolean = True

-End Function

-

-Rem       Misc parameter types

-

-Function TakesNothing()

-TakesNothing = 1

-End Function

-Function TakesInteger(arg As Integer) As Integer

-TakesInteger = 21

-End Function

-Function TakesString(arg As String) As Integer

-TakesString = 17

-End Function

-Function TakesDouble(arg As Double) As Integer

-TakesDouble = 38

-End Function

-Function TakesDate(arg As Date) As Integer

-TakesDate = 23

-End Function

-Function TakesRange(arg As Range) As Integer

-TakesRange = 11

-End Function

-

-

-Rem Optional arguments

-Function OptionalArgument(Length As Integer, Optional Width As Variant) As Integer

-If IsMissing(Width) Then

-    OptionalArgument = Length * Length

-Else

-    OptionalArgument = Length * Width

-End If

-End Function

-

-Function OptionalNonVariant(Optional IsZero As Integer) As Integer

-If IsMissing(IsZero) Then

-Rem This never occurs

-    OptionalNonVariant = 23

-Else

-    OptionalNonVariant = 17

-End If

-End Function

-

-<<<<<<
-======================
-ObjectModel
->>>>>>
-Attribute VB_Name = "ObjectModel"

-Function ObjectWorksheetFn() As Double

-ObjectWorksheetFn = WorksheetFunction.Sinh(2.3)

-End Function

-Function ObjectIsVolatile() As Double

-Application.Volatile

-ObjectIsVolatile = 3

-End Function

-Function ObjectRange(a As Range) As Integer

-ObjectRange = a.Column + a.Row + a.Height + a.Width

-End Function

-<<<<<<
-======================
-Syntax
->>>>>>
-Attribute VB_Name = "Syntax"

-Rem       Basic Statements

-Function StmtIf() As Boolean

-Dim bIf As Boolean

-bIf = True

-If bIf Then StmtIf = True

-If Not bIf Then

-    StmtIf = False

-Else

-    StmtIf = True

-End If

-End Function

-Function StmtSel() As Boolean

-Dim Digit As Integer

-Select Case Digit

-    Case 0

-        StmtSel = True

-    Case 1

-        StmtSel = False

-End Select

-End Function

-Function StmtFor() As Integer

-Dim i As Integer

-Dim j As Integer

-For i = 0 To 10

-    j = j + i

-Next i

-StmtFor = j

-End Function

-Function StmtForEach() As Integer

-Dim i(3)

-Dim j As Variant

-Dim c As Integer

-i(1) = "1"

-i(2) = Now

-i(3) = "1"

-For Each j In i()

-    c = c + 1

-Next j

-StmtForEach = c

-End Function

-Function StmtWhile() As Integer

-Dim i As Integer

-While i < 11

-    i = i + 1

-Wend

-StmtWhile = i

-End Function

-Function StmtWith() As Integer

-With Selection

-    .Orientation = 0

-End With

-StmtWith = 15

-End Function

-

-Rem       Unary Operators

-Function UnaryNot() As Boolean

-UnaryNot = Not False

-End Function

-

-Rem       Comparison Operators

-Function BinaryIsGreater() As Boolean

-BinaryIsGreater = 3 > 2

-End Function

-Function BinaryIsGreaterEqual() As Boolean

-BinaryIsGreaterEqual = 2 >= 2

-End Function

-Function BinaryIsLess() As Boolean

-BinaryIsLess = 2 < 2

-End Function

-Function BinaryIsLessEqual() As Boolean

-BinaryIsLessEqual = 4 <= 4

-End Function

-Function BinaryIsEqual() As Boolean

-BinaryIsEqual = 4 = 4

-End Function

-

-Rem       Arithmetic Operators

-Function BinaryExp() As Integer

-BinaryExp = 10 ^ 2

-End Function

-Function BinaryAdd() As Integer

-BinaryAdd = 2 + 3

-End Function

-Function BinarySub() As Integer

-BinarySub = 5 - 7

-End Function

-Function BinaryMult() As Integer

-BinaryMult = 2 * 7

-End Function

-Function BinaryDivide() As Integer

-BinaryDivide = 17 / 6

-End Function

-Function RShift() As Integer

-' RShift = 10 << 1

-End Function

-Function LShift() As Integer

-' LShift = 10 >> 1

-End Function

-

-<<<<<<
-======================
-RecordedMacros
->>>>>>
-Attribute VB_Name = "RecordedMacros"

-Sub Boldify()

-Attribute Boldify.VB_Description = "Macro recorded 20/04/2004 by Michael"

-Attribute Boldify.VB_ProcData.VB_Invoke_Func = "t\n14"

-'

-' Boldify Macro

-' Macro recorded 20/04/2004 by Michael

-'

-' Keyboard Shortcut: Ctrl+t

-'

-    Selection.Font.Bold = True

-End Sub

-Sub Italicize()

-Attribute Italicize.VB_Description = "Second Macro description"

-Attribute Italicize.VB_ProcData.VB_Invoke_Func = "J\n14"

-'

-' Italicize Macro

-' Second Macro description

-'

-' Keyboard Shortcut: Ctrl+Shift+J

-'

-    Selection.Font.Italic = True

-End Sub

-Sub Complex()

-Attribute Complex.VB_Description = "Daft thing ..."

-Attribute Complex.VB_ProcData.VB_Invoke_Func = "C\n14"

-'

-' Complex Macro

-' Daft thing ...

-'

-' Keyboard Shortcut: Ctrl+Shift+C

-'

-    ActiveCell.FormulaR1C1 = "2"

-    Range("F8").Select

-    ActiveCell.FormulaR1C1 = "3"

-    Range("F9").Select

-    Selection.Font.Bold = True

-    ActiveCell.FormulaR1C1 = "5"

-    Range("F10").Select

-    ActiveCell.FormulaR1C1 = "=R[-3]C+R[-1]C"

-    Range("F11").Select

-    With Selection.Font

-        .Name = "Arial Black"

-        .Size = 10

-        .Strikethrough = False

-        .Superscript = False

-        .Subscript = False

-        .OutlineFont = False

-        .Shadow = False

-        .Underline = xlUnderlineStyleNone

-        .ColorIndex = xlAutomatic

-    End With

-    ActiveCell.FormulaR1C1 = "Arial Black"

-    Range("F12").Select

-    ActiveCell.FormulaR1C1 = "Centered"

-    Range("F13").Select

-    ActiveCell.FormulaR1C1 = "Left"

-    Range("F14").Select

-    ActiveCell.FormulaR1C1 = "Right"

-    Range("F12").Select

-    With Selection

-        .HorizontalAlignment = xlCenter

-        .VerticalAlignment = xlBottom

-        .WrapText = False

-        .Orientation = 0

-        .AddIndent = False

-        .IndentLevel = 0

-        .ShrinkToFit = False

-        .ReadingOrder = xlContext

-        .MergeCells = False

-    End With

-    Range("F13").Select

-    With Selection

-        .HorizontalAlignment = xlLeft

-        .VerticalAlignment = xlBottom

-        .WrapText = False

-        .Orientation = 0

-        .AddIndent = False

-        .IndentLevel = 0

-        .ShrinkToFit = False

-        .ReadingOrder = xlContext

-        .MergeCells = False

-    End With

-    Range("F14").Select

-    With Selection

-        .HorizontalAlignment = xlRight

-        .VerticalAlignment = xlBottom

-        .WrapText = False

-        .Orientation = 0

-        .AddIndent = False

-        .IndentLevel = 0

-        .ShrinkToFit = False

-        .ReadingOrder = xlContext

-        .MergeCells = False

-    End With

-    Range("F15:G15").Select

-    ActiveCell.FormulaR1C1 = "Joiined"

-    Range("F15:G15").Select

-    Range("G15").Activate

-    With Selection

-        .HorizontalAlignment = xlCenter

-        .VerticalAlignment = xlBottom

-        .WrapText = False

-        .Orientation = 0

-        .AddIndent = False

-        .IndentLevel = 0

-        .ShrinkToFit = False

-        .ReadingOrder = xlContext

-        .MergeCells = False

-    End With

-    Selection.Merge

-End Sub

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Constants
->>>>>>
-Attribute VB_Name = "Constants"

-Rem  *****  BASIC  *****

-    

-Function vbUseCompareOptionConst() As Double

-    vbUseCompareOptionConst = vbUseCompareOption

-End Function

-Function vbBinaryCompareConst() As Double

-    vbBinaryCompareConst = vbBinaryCompare

-End Function

-Function vbTextCompareConst() As Double

-    vbTextCompareConst = vbTextCompare

-End Function

-Function vbDatabaseCompareConst() As Double

-    vbDatabaseCompareConst = vbDatabaseCompare

-End Function

-Function vbSundayConst() As Double

-    vbSundayConst = vbSunday

-End Function

-Function vbMondayConst() As Double

-    vbMondayConst = vbMonday

-End Function

-Function vbTuesdayConst() As Double

-    vbTuesdayConst = vbTuesday

-End Function

-Function vbWednesdayConst() As Double

-    vbWednesdayConst = vbWednesday

-End Function

-Function vbThursdayConst() As Double

-    vbThursdayConst = vbThursday

-End Function

-Function vbFridayConst() As Double

-    vbFridayConst = vbFriday

-End Function

-Function vbSaturdayConst() As Double

-    vbSaturdayConst = vbSaturday

-End Function

-Function vbUseSystemConst() As Double

-    vbUseSystemConst = vbUseSystem

-End Function

-Function vbGeneralDateConst() As Double

-    vbGeneralDateConst = vbGeneralDate

-End Function

-Function vbLongDateConst() As Double

-    vbLongDateConst = vbLongDate

-End Function

-Function vbShortDateConst() As Double

-    vbShortDateConst = vbShortDate

-End Function

-Function vbLongTimeConst() As Double

-    vbLongTimeConst = vbLongTime

-End Function

-Function vbShortTimeConst() As Double

-    vbShortTimeConst = vbShortTime

-End Function

-Function vbObjectErrorConst() As Double

-    vbObjectErrorConst = vbObjectError

-End Function

-Function vbOKOnlyConst() As Double

-    vbOKOnlyConst = vbOKOnly

-End Function

-Function vbOKCancelConst() As Double

-    vbOKCancelConst = vbOKCancel

-End Function

-Function vbAbortRetryIgnoreConst() As Double

-    vbAbortRetryIgnoreConst = vbAbortRetryIgnore

-End Function

-Function vbYesNoCancelConst() As Double

-    vbYesNoCancelConst = vbYesNoCancel

-End Function

-Function vbYesNoConst() As Double

-    vbYesNoConst = vbYesNo

-End Function

-Function vbRetryCancelConst() As Double

-    vbRetryCancelConst = vbRetryCancel

-End Function

-Function vbCriticalConst() As Double

-    vbCriticalConst = vbCritical

-End Function

-Function vbQuestionConst() As Double

-    vbQuestionConst = vbQuestion

-End Function

-Function vbExclamationConst() As Double

-    vbExclamationConst = vbExclamation

-End Function

-Function vbInformationConst() As Double

-    vbInformationConst = vbInformation

-End Function

-Function vbDefaultButton1Const() As Double

-    vbDefaultButton1Const = vbDefaultButton1

-End Function

-Function vbDefaultButton2Const() As Double

-    vbDefaultButton2Const = vbDefaultButton2

-End Function

-Function vbDefaultButton3Const() As Double

-    vbDefaultButton3Const = vbDefaultButton3

-End Function

-Function vbDefaultButton4Const() As Double

-    vbDefaultButton4Const = vbDefaultButton4

-End Function

-Function vbApplicationModalConst() As Double

-    vbApplicationModalConst = vbApplicationModal

-End Function

-Function vbSystemModalConst() As Double

-    vbSystemModalConst = vbSystemModal

-End Function

-Function vbMsgBoxHelpButtonConst() As Double

-    vbMsgBoxHelpButtonConst = vbMsgBoxHelpButton

-End Function

-Function vbMsgBoxSetForegroundConst() As Double

-    vbMsgBoxSetForegroundConst = vbMsgBoxSetForeground

-End Function

-Function vbMsgBoxRightConst() As Double

-    vbMsgBoxRightConst = vbMsgBoxRight

-End Function

-Function vbMsgBoxRtlReadingConst() As Double

-    vbMsgBoxRtlReadingConst = vbMsgBoxRtlReading

-End Function

-

-<<<<<<
-======================
-Constants1
->>>>>>
-Attribute VB_Name = "Constants1"

-Rem  *****  BASIC  *****

-    

-Function vbCrConst() As String

-    vbCrConst = vbCr

-End Function

-Function VbCrLfConst() As String

-    VbCrLfConst = vbCrLf

-End Function

-Function vbFormFeedConst() As String

-    vbFormFeedConst = vbFormFeed

-End Function

-Function vbLfConst() As String

-    vbLfConst = vbLf

-End Function

-Function vbNewLineConst() As String

-    vbNewLineConst = vbNewLine

-End Function

-Function vbNullCharConst() As String

-    vbNullCharConst = vbNullChar

-End Function

-Function vbNullStringConst() As String

-    vbNullStringConst = vbNullString

-End Function

-Function vbTabConst() As String

-    vbTabConst = vbTab

-End Function

-Function vbVerticalTabConst() As String

-    vbVerticalTabConst = vbVerticalTab

-End Function

-Function vbUpperCaseConst() As Integer

-    vbUpperCaseConst = vbUpperCase

-End Function

-Function vbLowerCaseConst() As Integer

-    vbLowerCaseConst = vbLowerCase

-End Function

-Function vbProperCaseConst() As Integer

-    vbProperCaseConst = vbProperCase

-End Function

-Function vbWideConst() As Integer

-    vbWideConst = vbWide

-End Function

-Function vbNarrowConst() As Integer

-    vbNarrowConst = vbNarrow

-End Function

-Function vbKatakanaConst() As Integer

-    vbKatakanaConst = vbKatakana

-End Function

-Function vbHiraganaConst() As Integer

-    vbHiraganaConst = vbHiragana

-End Function

-Function vbUnicodeConst() As Integer

-    vbUnicodeConst = vbUnicode

-End Function

-Function vbFromUnicodeConst() As Integer

-    vbFromUnicodeConst = vbFromUnicode

-End Function

-Function vbUseDefaultConst() As String

-    vbUseDefaultConst = vbUseDefault

-End Function

-Function vbTrueConst() As String

-    vbTrueConst = vbTrue

-End Function

-Function vbFalseConst() As String

-    vbFalseConst = vbFalse

-End Function

-Function vbEmptyConst() As Double

-    vbEmptyConst = vbEmpty

-End Function

-Function vbNullConst() As Double

-    vbNullConst = vbNull

-End Function

-Function vbIntegerConst() As Double

-    vbIntegerConst = vbInteger

-End Function

-Function vbLongConst() As Double

-    vbLongConst = vbLong

-End Function

-Function vbSingleConst() As Double

-    vbSingleConst = vbSingle

-End Function

-Function vbDoubleConst() As Double

-    vbDoubleConst = vbDouble

-End Function

-Function vbCurrencyConst() As Double

-    vbCurrencyConst = vbCurrency

-End Function

-Function vbDateConst() As Double

-    vbDateConst = vbDate

-End Function

-Function vbStringConst() As Double

-    vbStringConst = vbString

-End Function

-Function vbObjectConst() As Double

-    vbObjectConst = vbObject

-End Function

-Function vbErrorConst() As Double

-    vbErrorConst = vbError

-End Function

-Function vbBooleanConst() As Double

-    vbBooleanConst = vbBoolean

-End Function

-Function vbVariantConst() As Double

-    vbVariantConst = vbVariant

-End Function

-Function vbDataObjectConst() As Double

-    vbDataObjectConst = vbDataObject

-End Function

-Function vbDecimalConst() As Double

-    vbDecimalConst = vbDecimal

-End Function

-Function vbByteConst() As Double

-    vbByteConst = vbByte

-End Function

-Function vbUserDefinedTypeConst() As Double

-    vbUserDefinedTypeConst = vbUserDefinedType

-End Function

-Function vbArrayConst() As Double

-    vbArrayConst = vbArray

-End Function

-

-<<<<<<
-======================
-FunctionA_E
->>>>>>
-Attribute VB_Name = "FunctionA_E"

-Rem  *****  BASIC  *****

-    

-Function rtl_abs() As Double

-    rtl_abs = Abs(-53)

-End Function

-Function rtl_array() As Variant

-    rtl_array = Array(10, 20, 30)

-End Function

-Function rtl_asc() As Integer

-    rtl_asc = Asc("A")

-End Function

-Function rtl_atn() As Double

-    rtl_atn = Atn(3.14 / 4)

-End Function

-Function rtl_callbyname()

-End Function

-Function rtl_choose()

-   rtl_choose = Choose(1, "Choose", "Error", "Error")

-End Function

-Function rtl_chr() As String

-    rtl_chr = Chr(65)

-End Function

-Function rtl_command()

-End Function

-Function rtl_cos() As Double

-    rtl_cos = Cos(0)

-End Function

-Function rtl_createobject()

-End Function

-Function rtl_curdir() As String

-    rtl_curdir = CurDir()

-End Function

-Function rtl_cverr()

-End Function

-Function rtl_date() As Date

-    rtl_date = Date

-End Function

-Function rtl_dateadd() As Double

-    Dim myDate As Date

-    myDate = "08/10/2004"

-    rtl_dateadd = DateAdd("yyyy", 1, myDate)

-End Function

-Function rtl_datediff() As Long

-    Dim myDate As Date

-    myDate = "08/10/2004"

-    rtl_datediff = DateDiff("d", "08/01/2004", myDate)

-End Function

-Function rtl_datepart() As Integer

-    Dim myDate As Date

-    myDate = "08/10/2004"

-    rtl_datepart = DatePart("q", myDate)

-End Function

-Function rtl_dateserial() As Date

-    Dim myDate As Date

-    myDate = "08/10/2004"

-    rtl_dateserial = DateSerial(2004, 8, 10)

-End Function

-Function rtl_datevalue() As Date

-    Dim myDate As Date

-    rtl_datevalue = DateValue("12/02/1969")

-End Function

-Function rtl_day() As Integer

-    Dim myDate As Date

-    myDate = "08/10/2004"

-    rtl_day = Day(myDate)

-End Function

-Function rtl_ddb() As Integer

-End Function

-Function rtl_dir() As String

-    rtl_dir = Dir(CurDir())

-End Function

-Function rtl_doevents()

-End Function

-Function rtl_environ() As String

-    rtl_environ = Environ(1)

-End Function

-Function rtl_eof()

-End Function

-Function rtl_error() As String

-    rtl_error = Error(1)

-End Function

-Function rtl_exp() As Double

-    rtl_exp = Exp(1)

-End Function

-

-<<<<<<
-======================
-FunctionF_I
->>>>>>
-Attribute VB_Name = "FunctionF_I"

-Rem  *****  BASIC  *****

-        

-Function rtl_fileattr()

-End Function

-Function rtl_filedatetime()

-End Function

-Function rtl_filelen()

-End Function

-Function rtl_filter() As String

-    Dim MyIndex() As String

-    Dim MyArray(3)

-    MyArray(0) = "Format"

-    MyArray(1) = "Filter"

-    MyArray(2) = 10

-    MyIndex() = Filter(MyArray(), "Fil")   ' MyIndex(0) contains "Monday".

-    rtl_filter = MyIndex(0)

-End Function

-Function rtl_format() As String

-    rtl_format = Format(334.9, "###0.00")   ' Returns "334.90".

-End Function

-Function rtl_formatcurrency() As String

-    rtl_formatcurrency = FormatCurrency(1000)   ' MyCurrency contains $1000.00.

-End Function

-Function rtl_FormatDateTime() As String

-    rtl_FormatDateTime = FormatDateTime("08/10/2004", vbLongDate) 'Tuesday, August 10, 2004

-End Function

-Function rtl_formatnumber() As String

-    Dim MyAngle, MySecant

-    MyAngle = 1.3   ' Define angle in radians.

-    MySecant = 1 / Cos(MyAngle)   ' Calculate secant.

-    rtl_formatnumber = FormatNumber(MySecant, 4) ' Format MySecant to four decimal places.

-End Function

-Function rtl_formatpercent() As String

-    rtl_formatpercent = FormatPercent(2 / 32) ' MyPercent contains 6.25%.

-End Function

-Function rtl_freefile()

-End Function

-Function rtl_fv()

-End Function

-Function rtl_getallsettings()

-End Function

-Function rtl_getattr()

-End Function

-Function rtl_getautoserversetting()

-End Function

-Function rtl_getobject()

-End Function

-Function rtl_getsetting()

-End Function

-Function rtl_hex() As String

-    rtl_hex = Hex(65535)

-End Function

-Function rtl_hour() As String

-    rtl_hour = Hour("12:00:00")

-End Function

-Function rtl_iif() As String

-    rtl_iif = IIf(10 > 100, "Large", "Small")

-End Function

-Function rtl_imestatus()

-End Function

-Function rtl_input()

-End Function

-Function rtl_inputbox()

-End Function

-Function rtl_instr() As Integer

-    Dim SearchString, SearchChar

-    SearchString = "XXpXXpXXPXXP"  ' String to search in.

-    SearchChar = "P"   ' Search for "P".

-        

-    ' A textual comparison starting at position 4. Returns 6.

-    rtl_instr = InStr(4, SearchString, SearchChar, 1)

-End Function

-Function rtl_instrrev() As Integer

-    Dim SearchString, SearchChar

-    SearchString = "XXpXXpXXPXXP"  ' String to search in.

-    SearchChar = "P"   ' Search for "P".

-        

-    ' returns 12

-    rtl_instrrev = InStrRev(SearchString, SearchChar)

-End Function

-Function rtl_int() As Integer

-    rtl_int = Int(7.45)

-End Function

-Function rtl_ipmt()

-End Function

-Function rtl_irr()

-End Function

-Function rtl_isarray() As Boolean

-    Dim var(3)

-    rtl_isarray = IsArray(var())

-End Function

-Function rtl_isdate() As Boolean

-    Dim var As Date

-    rtl_isdate = IsDate(var)

-End Function

-Function rtl_isempty() As Boolean

-    Dim var

-    rtl_isempty = IsEmpty(var)

-End Function

-Function rtl_iserror() As Boolean

-    Dim var As Error

-    rtl_iserror = IsError(var)

-End Function

-Function rtl_ismissing() As Boolean

-    Dim var

-    rtl_ismissing = IsMissing(var)

-End Function

-Function rtl_isnull() As Boolean

-    Dim var

-    rtl_isnull = IsNull(var)

-End Function

-Function rtl_isnumeric() As Boolean

-    Dim var As Integer

-    rtl_isnumeric = IsNumeric(var)

-End Function

-Function rtl_isobject() As Boolean

-    Dim var As Object

-    rtl_isobject = IsObject(var)

-End Function

-

-<<<<<<
-======================
-FunctionJ_R
->>>>>>
-Attribute VB_Name = "FunctionJ_R"

-Rem  *****  BASIC  *****

-        

-Function rtl_join() As String

-    Dim MyArray(3)

-    MyArray(1) = "1"

-    MyArray(2) = "1"

-    MyArray(3) = "1"

-    rtl_join = Join(MyArray())

-End Function

-Function rtl_lbound() As Integer

-    Dim MyArray(1 To 10, 5 To 15, 10 To 20)    ' Declare array variables.

-    rtl_lbound = LBound(MyArray(), 1)    ' Returns 1.

-End Function

-Function rtl_lcase() As String

-    rtl_lcase = LCase("LowerCase")

-End Function

-Function rtl_left() As String

-    rtl_left = Left("Left", 2)

-End Function

-Function rtl_len() As Long

-    rtl_len = Len("Len")

-End Function

-Function rtl_loadpicture()

-End Function

-Function rtl_loc()

-End Function

-Function rtl_lof()

-End Function

-Function rtl_log() As Double

-    rtl_log = Log(10)

-End Function

-Function rtl_ltrim() As String

-    rtl_ltrim = LTrim(" LTrim")

-End Function

-Function rtl_mid() As String

-    rtl_mid = Mid("Mid Function", 1, 3)

-End Function

-Function rtl_minute() As Integer

-    rtl_minute = Minute("12:31:45")

-End Function

-Function rtl_mirr()

-End Function

-Function rtl_month() As Integer

-    rtl_month = Month("10/08/2004")

-End Function

-Function rtl_monthname() As String

-    rtl_monthname = MonthName(10)

-End Function

-Function rtl_msgbox()

-End Function

-Function rtl_now() As Date

-    rtl_now = Now()

-End Function

-Function rtl_nper()

-End Function

-Function rtl_npv()

-End Function

-Function rtl_oct() As String

-    rtl_oct = Oct(32)

-End Function

-Function rtl_partition()

-End Function

-Function rtl_pmt()

-End Function

-Function rtl_ppmt()

-End Function

-Function rtl_pv()

-End Function

-Function rtl_qbcolor() As Long

-    rtl_qbcolor = QBColor(5)

-End Function

-Function rtl_rate()

-End Function

-Function rtl_replace() As String

-    ' A binary comparison starting at the beginning of the string.

-    rtl_replace = Replace("XXpXXPXXp", "p", "Y")

-End Function

-Function rtl_rgb() As Long

-    rtl_rgb = RGB(255, 0, 0)

-End Function

-Function rtl_right() As String

-    rtl_right = Right("right", 2)

-End Function

-Function rtl_rnd() As Single

-    rtl_rnd = Rnd(10)

-End Function

-Function rtl_round() As Single

-    rtl_round = Round(3.1415, 2)

-End Function

-

-<<<<<<
-======================
-FunctionS_Y
->>>>>>
-Attribute VB_Name = "FunctionS_Y"

-Rem  *****  BASIC  *****

-        

-Function rtl_second() As Integer

-    rtl_second = Second("12:31:45")

-End Function

-Function rtl_seek()

-End Function

-Function rtl_sgn() As Integer

-    rtl_sgn = Sgn(10)

-End Function

-Function rtl_shell() As Integer

-End Function

-Function rtl_sin() As Integer

-    rtl_sin = Sin(0)

-End Function

-Function rtl_sln()

-End Function

-Function rtl_space() As String

-    rtl_space = "4" + Space(4) + "spaces"

-End Function

-Function rtl_split()

-    rtl_split = Split("Part1 Part2 Part3")

-End Function

-Function rtl_sqr() As Double

-    rtl_sqr = Sqr(256)

-End Function

-Function rtl_str() As String

-    rtl_str = str(256)

-End Function

-Function rtl_strcomp() As Integer

-    rtl_strcomp = StrComp("strcomp", "strcomp")

-End Function

-Function rtl_strconv() As String

-    rtl_strconv = StrConv("strconv", 3)

-End Function

-Function rtl_string() As String

-    rtl_string = String(10, "s")

-End Function

-Function rtl_strreverse() As String

-    rtl_strreverse = StrReverse("reverse")

-End Function

-Function rtl_switch() As String

-    Dim str As String

-    str = "switch"

-    rtl_switch = Switch(str = "skip", "noswitch", str = "switch", "switch")

-End Function

-Function rtl_syd()

-End Function

-Function rtl_tab()

-End Function

-Function rtl_tan() As Double

-    rtl_tan = Tan(0)

-End Function

-Function rtl_time() As Date

-    rtl_time = Time()

-End Function

-Function rtl_timer() As Single

-    rtl_timer = Timer()

-End Function

-Function rtl_timeserial() As Date

-    rtl_timeserial = TimeSerial(12, 31, 45)

-End Function

-Function rtl_timevalue() As Date

-    rtl_timevalue = TimeValue("12:31:45 AM")

-End Function

-Function rtl_typename() As String

-    rtl_typename = TypeName("string")

-End Function

-Function rtl_ubound() As Integer

-    Dim MyArray(1 To 10, 5 To 15, 10 To 20)   ' Declare array variables.

-    rtl_ubound = UBound(MyArray(), 1)   ' Returns 10.

-End Function

-Function rtl_ucase() As String

-    rtl_ucase = UCase("Uppercase")

-End Function

-Function rtl_val() As Integer

-    rtl_val = Val("3.1415")

-End Function

-Function rtl_vartype() As Integer

-    rtl_vartype = VarType(10)

-End Function

-Function rtl_weekday() As Integer

-    rtl_weekday = Weekday("10/08/2004")

-End Function

-Function rtl_weekdayname() As String

-    rtl_weekdayname = WeekdayName(6)

-End Function

-Function rtl_year() As String

-    rtl_year = Year("10/08/2004")

-End Function

-

-<<<<<<
-Project Name : 'Animated Chart Example.xls'
-Quirk - duff tag length======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "ScrollBar1, 4, 1, MSForms, ScrollBar"

-Attribute VB_Control = "CommandButton1, 5, 2, MSForms, CommandButton"

-

-

-Private Sub CommandButton1_Click()

-Range("A1").Value = 0

-End Sub

-

-Private Sub ScrollBar1_Change()

-    Range("A1").Value = Range("B1").Value * 0.035

-End Sub

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBProject'
-Quirk - duff tag length======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CommandButton1, 1, 0, MSForms, CommandButton"

-Private Sub CommandButton1_Click()

-    MsgBox "Hello your workbook name is " & Application.ActiveWorkbook.Name

-End Sub

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CheckBox1, 1, 0, MSForms, CheckBox"

-Attribute VB_Control = "CheckBox2, 2, 1, MSForms, CheckBox"

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "OptionButton1, 2, 1, MSForms, OptionButton"

-Attribute VB_Control = "OptionButton2, 3, 2, MSForms, OptionButton"

-Attribute VB_Control = "OptionButton3, 4, 3, MSForms, OptionButton"

-Private Sub OptionButton1_Click()

-    'blue

-    Cells.Interior.Color = RGB(0, 0, 255)

-End Sub

-

-Private Sub OptionButton2_Click()

-    'green

-    Cells.Interior.Color = RGB(0, 255, 0)

-End Sub

-

-Private Sub OptionButton3_Click()

-    'red

-    Cells.Interior.Color = RGB(255, 0, 0)

-End Sub

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "TextBox1, 1, 0, MSForms, TextBox"

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "ListBox1, 1, 0, MSForms, ListBox"

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "ComboBox1, 1, 0, MSForms, ComboBox"

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "ScrollBar1, 1, 0, MSForms, ScrollBar"

-Attribute VB_Control = "ScrollBar2, 2, 1, MSForms, ScrollBar"

-Attribute VB_Control = "ScrollBar3, 3, 2, MSForms, ScrollBar"

-Private Sub ScrollBar1_Change()

-    Call UpdateColor

-End Sub

-

-Private Sub ScrollBar2_Change()

-    Call UpdateColor

-End Sub

-

-Private Sub ScrollBar3_Change()

-    Call UpdateColor

-End Sub

-

-Private Sub UpdateColor()

-    Cells.Interior.Color = RGB(Range("A1"), Range("A2"), Range("A3"))

-End Sub

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "SpinButton1, 1, 0, MSForms, SpinButton"

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Private Sub Workbook_Open()

-

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "SpinButton1, 2, 0, MSForms, SpinButton"

-Attribute VB_Control = "Reset, 3, 1, MSForms, CommandButton"

-Private Sub Reset_Click()

-

-Application.ScreenUpdating = False

-

-ActiveSheet.Range("direction").Cells(1, 1).Value = 1

-ActiveSheet.Range("direction").Cells(1, 2).Value = 0

-Dim center_x As Long

-Dim center_y As Long

-With ActiveSheet.Range("board")

-    .Clear

-    .Interior.Color = RGB(0, 0, 0)

-    center_x = .Column + .Columns.Count / 2

-    center_y = .Row + .Rows.Count / 2

-End With

-With ActiveSheet.Range("position")

-    Dim pos As Long

-    For pos = 1 To .Rows.Count

-        .Cells(pos, 1).Value = center_x

-        .Cells(pos, 2).Value = center_y

-    Next pos

-    pos = .Rows.Count

-    .Cells(pos, 1).Value = center_x - 1

-    .Cells(pos, 2).Value = center_y - 1

-End With

-

-Application.ScreenUpdating = True

-

-End Sub

-

-'Sub DrawSnake(sheet As Worksheet, pos As Range)

-Sub DrawSnake(sheet As Object, pos As Object)

-Dim col As Long

-For idx = 1 To pos.Rows.Count

-    x = pos.Cells(idx, 1).Value

-    y = pos.Cells(idx, 2).Value

-    If idx = pos.Rows.Count Then

-        col = RGB(0, 0, 0)

-    Else

-        col = RGB(150, 0, 0)

-    End If

-'    MsgBox ("Set " + Str(x) + " " + Str(y) + " to " + Str(col))

-    sheet.Cells(y, x).Interior.Color = col

-'    sheet.Range("A1:IV65536").Cells(y, x).Value = col

-Next idx

-End Sub

-

-Sub MoveSnake(board As Object, ByRef x As Long, ByRef y As Long, ByRef dir_x As Long, ByRef dir_y As Long)

-

-x = x + dir_x

-y = y + dir_y

-

-' New wrapping code

-x = ((x - board.Column + board.Columns.Count) Mod board.Columns.Count) + board.Column

-y = ((y - board.Row + board.Rows.Count) Mod board.Rows.Count) + board.Row

-

-' should we change direction ? - bias for X due to non-square foos

-If (dir_x = 0 And Rnd() > 0.75) Or _

-   (dir_x <> 0 And Rnd() > 0.85) Then

-    ' Swap dirx & diry & randomly negate

-    Dim tmp As Long

-    tmp = dir_x

-    dir_x = dir_y

-    dir_y = tmp

-    If Rnd() > 0.5 Then

-        dir_x = -dir_x

-        dir_y = -dir_y

-    End If

-End If

-

-End Sub

-Private Sub SpinButton1_Change()

-

-Application.ScreenUpdating = False

-

-Dim sheet As Object

-Set sheet = ActiveSheet

-

-Dim x As Long

-Dim y As Long

-Dim dir_x As Long

-Dim dir_y As Long

-

-x = sheet.Range("position").Cells(1, 1).Value

-y = sheet.Range("position").Cells(1, 2).Value

-dir_x = sheet.Range("direction").Cells(1, 1).Value

-dir_y = sheet.Range("direction").Cells(1, 2).Value

-

-'Dim board As Range

-Dim board As Object

-Set board = sheet.Range("board")

-

-Call MoveSnake(board, x, y, dir_x, dir_y)

-

-'MsgBox ("Moved to " + Str(x) + " " + Str(y) + " to red")

-

-sheet.Range("position").Cells(1, 1).Value = x

-sheet.Range("position").Cells(1, 2).Value = y

-ActiveSheet.Range("direction").Cells(1, 1).Value = dir_x

-ActiveSheet.Range("direction").Cells(1, 2).Value = dir_y

-

-Call DrawSnake(sheet, sheet.Range("position"))

-

-sheet.Range("src").Copy (sheet.Range("dest"))

-

-Application.ScreenUpdating = True

-

-End Sub

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Sub doSnake()

-

-Dim pos As Integer

-Dim sheet As Object

-

-Set sheet = Application.Workbooks(1).Sheets(1)

-For pos = 1 To 20

-Rem  With sheet.Cells(1, b).Interior

-    sheet.Cells(1, pos).Interior.Color = RGB(123, 0, 0)

-Rem    End With

-Rem Application.Wait (Now + TimeValue("00:00:01"))

-Next pos

-

-End Sub

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Sub test()

-Sheets("sheet1").Activate

-main_1

-Sheets("sheet2").Activate

-main_2

-Sheets("sheet3").Activate

-main_3

-Sheets("sheet4").Activate

-main_4

-Sheets("sheet5").Activate

-main_5

-End Sub

-Sub main_1()

-test_xl24HourClock (xl24HourClock)

-test_xl4DigitYears (xl4DigitYears)

-test_xlAlternateArraySeparator (xlAlternateArraySeparator)

-test_xlColumnSeparator (xlColumnSeparator)

-test_xlCountryCode (xlCountryCode)

-test_xlCountrySetting (xlCountrySetting)

-test_xlCurrencyBefore (xlCurrencyBefore)

-test_xlCurrencyCode (xlCurrencyCode)

-test_xlCurrencyDigits (xlCurrencyDigits)

-test_xlCurrencyLeadingZeros (xlCurrencyLeadingZeros)

-test_xlCurrencyMinusSign (xlCurrencyMinusSign)

-test_xlCurrencyNegative (xlCurrencyNegative)

-test_xlCurrencySpaceBefore (xlCurrencySpaceBefore)

-test_xlCurrencyTrailingZeros (xlCurrencyTrailingZeros)

-test_xlDateOrder (xlDateOrder)

-test_xlDateSeparator (xlDateSeparator)

-test_xlDayCode (xlDayCode)

-test_xlDayLeadingZero (xlDayLeadingZero)

-test_xlDecimalSeparator (xlDecimalSeparator)

-test_xlGeneralFormatName (xlGeneralFormatName)

-test_xlHourCode (xlHourCode)

-test_xlLeftBrace (xlLeftBrace)

-test_xlLeftBracket (xlLeftBracket)

-test_xlListSeparator (xlListSeparator)

-test_xlLowerCaseColumnLetter (xlLowerCaseColumnLetter)

-test_xlLowerCaseRowLetter (xlLowerCaseRowLetter)

-test_xlMDY (xlMDY)

-test_xlMetric (xlMetric)

-test_xlMinuteCode (xlMinuteCode)

-test_xlMonthCode (xlMonthCode)

-test_xlMonthLeadingZero (xlMonthLeadingZero)

-test_xlMonthNameChars (xlMonthNameChars)

-test_xlNocurrencyDigits (xlNocurrencyDigits)

-test_xlNonEnglishFunctions (xlNonEnglishFunctions)

-test_xlRightBrace (xlRightBrace)

-test_xlRightBracket (xlRightBracket)

-test_xlRowSeparator (xlRowSeparator)

-test_xlSecondCode (xlSecondCode)

-test_xlThousandsSeparator (xlThousandsSeparator)

-test_xlTimeLeadingZero (xlTimeLeadingZero)

-test_xlTimeSeparator (xlTimeSeparator)

-test_xlUpperCaseColumnLetter (xlUpperCaseColumnLetter)

-test_xlUpperCaseRowLetter (xlUpperCaseRowLetter)

-test_xlWeekdayNameChars (xlWeekdayNameChars)

-test_xlYearCode (xlYearCode)

-test_xlColumnThenRow (xlColumnThenRow)

-test_xlRowThenColumn (xlRowThenColumn)

-test_xlArabicBothStrict (xlArabicBothStrict)

-test_xlArabicNone (xlArabicNone)

-test_xlArabicStrictAlefHamza (xlArabicStrictAlefHamza)

-test_xlArabicStrictFinalYaa (xlArabicStrictFinalYaa)

-test_xlArrangeStyleCascade (xlArrangeStyleCascade)

-test_xlArrangeStyleHorizontal (xlArrangeStyleHorizontal)

-test_xlArrangeStyleTiled (xlArrangeStyleTiled)

-test_xlArrangeStyleVertical (xlArrangeStyleVertical)

-test_xlArrowHeadLengthLong (xlArrowHeadLengthLong)

-test_xlArrowHeadLengthMedium (xlArrowHeadLengthMedium)

-test_xlArrowHeadLengthShort (xlArrowHeadLengthShort)

-test_xlArrowHeadStyleClosed (xlArrowHeadStyleClosed)

-test_xlArrowHeadStyleDoubleClosed (xlArrowHeadStyleDoubleClosed)

-test_xlArrowHeadStyleDoubleOpen (xlArrowHeadStyleDoubleOpen)

-test_xlArrowHeadStyleNone (xlArrowHeadStyleNone)

-test_xlArrowHeadStyleOpen (xlArrowHeadStyleOpen)

-test_xlArrowHeadWidthMedium (xlArrowHeadWidthMedium)

-test_xlArrowHeadWidthNarrow (xlArrowHeadWidthNarrow)

-test_xlArrowHeadWidthWide (xlArrowHeadWidthWide)

-test_xlFillCopy (xlFillCopy)

-test_xlFillDays (xlFillDays)

-test_xlFillDefault (xlFillDefault)

-test_xlFillFormats (xlFillFormats)

-test_xlFillMonths (xlFillMonths)

-test_xlFillSeries (xlFillSeries)

-test_xlFillValues (xlFillValues)

-test_xlFillWeekdays (xlFillWeekdays)

-test_xlFillYears (xlFillYears)

-test_xlGrowthTrend (xlGrowthTrend)

-test_xlLinearTrend (xlLinearTrend)

-test_xlAnd (xlAnd)

-test_xlBottom10Items (xlBottom10Items)

-test_xlBottom10Percent (xlBottom10Percent)

-test_xlOr (xlOr)

-test_xlTop10Items (xlTop10Items)

-test_xlTop10Percent (xlTop10Percent)

-test_xlAxisCrossesAutomatic (xlAxisCrossesAutomatic)

-test_xlAxisCrossesCustom (xlAxisCrossesCustom)

-test_xlAxisCrossesMaximum (xlAxisCrossesMaximum)

-test_xlAxisCrossesMinimum (xlAxisCrossesMinimum)

-test_xlPrimary (xlPrimary)

-test_xlSecondary (xlSecondary)

-test_xlCategory (xlCategory)

-test_xlSeriesAxis (xlSeriesAxis)

-test_xlValue (xlValue)

-Range("A1").Value = "constant name"

-Range("B1").Value = "OOo result"

-Range("C1").Value = "Excel result"

-Range("D1").Value = "Correct?"

-End Sub

-

-Function test_xl24HourClock(ByRef num)

-Range("A2").Clear

-Range("B2").Clear

-Range("C2").Clear

-Range("D2").Clear

-Range("A2").Value = "xl24HourClock"

-Range("B2").Value = 33

-Range("C2").Value = num

-B2 = Range("B2").Value

-C2 = Range("C2").Value

-If B2 = C2 Then

-Range("D2").Value = "OK"

-Else

-Range("D2").Value = "NG"

-End If

-End Function

-

-Function test_xl4DigitYears(ByRef num)

-Range("A3").Clear

-Range("B3").Clear

-Range("C3").Clear

-Range("D3").Clear

-Range("A3").Value = "xl4DigitYears"

-Range("B3").Value = 43

-Range("C3").Value = num

-B3 = Range("B3").Value

-C3 = Range("C3").Value

-If B3 = C3 Then

-Range("D3").Value = "OK"

-Else

-Range("D3").Value = "NG"

-End If

-End Function

-

-Function test_xlAlternateArraySeparator(ByRef num)

-Range("A4").Clear

-Range("B4").Clear

-Range("C4").Clear

-Range("D4").Clear

-Range("A4").Value = "xlAlternateArraySeparator"

-Range("B4").Value = 16

-Range("C4").Value = num

-B4 = Range("B4").Value

-C4 = Range("C4").Value

-If B4 = C4 Then

-Range("D4").Value = "OK"

-Else

-Range("D4").Value = "NG"

-End If

-End Function

-

-Function test_xlColumnSeparator(ByRef num)

-Range("A5").Clear

-Range("B5").Clear

-Range("C5").Clear

-Range("D5").Clear

-Range("A5").Value = "xlColumnSeparator"

-Range("B5").Value = 14

-Range("C5").Value = num

-B5 = Range("B5").Value

-C5 = Range("C5").Value

-If B5 = C5 Then

-Range("D5").Value = "OK"

-Else

-Range("D5").Value = "NG"

-End If

-End Function

-

-Function test_xlCountryCode(ByRef num)

-Range("A6").Clear

-Range("B6").Clear

-Range("C6").Clear

-Range("D6").Clear

-Range("A6").Value = "xlCountryCode"

-Range("B6").Value = 1

-Range("C6").Value = num

-B6 = Range("B6").Value

-C6 = Range("C6").Value

-If B6 = C6 Then

-Range("D6").Value = "OK"

-Else

-Range("D6").Value = "NG"

-End If

-End Function

-

-Function test_xlCountrySetting(ByRef num)

-Range("A7").Clear

-Range("B7").Clear

-Range("C7").Clear

-Range("D7").Clear

-Range("A7").Value = "xlCountrySetting"

-Range("B7").Value = 2

-Range("C7").Value = num

-B7 = Range("B7").Value

-C7 = Range("C7").Value

-If B7 = C7 Then

-Range("D7").Value = "OK"

-Else

-Range("D7").Value = "NG"

-End If

-End Function

-

-Function test_xlCurrencyBefore(ByRef num)

-Range("A8").Clear

-Range("B8").Clear

-Range("C8").Clear

-Range("D8").Clear

-Range("A8").Value = "xlCurrencyBefore"

-Range("B8").Value = 37

-Range("C8").Value = num

-B8 = Range("B8").Value

-C8 = Range("C8").Value

-If B8 = C8 Then

-Range("D8").Value = "OK"

-Else

-Range("D8").Value = "NG"

-End If

-End Function

-

-Function test_xlCurrencyCode(ByRef num)

-Range("A9").Clear

-Range("B9").Clear

-Range("C9").Clear

-Range("D9").Clear

-Range("A9").Value = "xlCurrencyCode"

-Range("B9").Value = 25

-Range("C9").Value = num

-B9 = Range("B9").Value

-C9 = Range("C9").Value

-If B9 = C9 Then

-Range("D9").Value = "OK"

-Else

-Range("D9").Value = "NG"

-End If

-End Function

-

-Function test_xlCurrencyDigits(ByRef num)

-Range("A10").Clear

-Range("B10").Clear

-Range("C10").Clear

-Range("D10").Clear

-Range("A10").Value = "xlCurrencyDigits"

-Range("B10").Value = 27

-Range("C10").Value = num

-B10 = Range("B10").Value

-C10 = Range("C10").Value

-If B10 = C10 Then

-Range("D10").Value = "OK"

-Else

-Range("D10").Value = "NG"

-End If

-End Function

-

-Function test_xlCurrencyLeadingZeros(ByRef num)

-Range("A11").Clear

-Range("B11").Clear

-Range("C11").Clear

-Range("D11").Clear

-Range("A11").Value = "xlCurrencyLeadingZeros"

-Range("B11").Value = 40

-Range("C11").Value = num

-B11 = Range("B11").Value

-C11 = Range("C11").Value

-If B11 = C11 Then

-Range("D11").Value = "OK"

-Else

-Range("D11").Value = "NG"

-End If

-End Function

-

-Function test_xlCurrencyMinusSign(ByRef num)

-Range("A12").Clear

-Range("B12").Clear

-Range("C12").Clear

-Range("D12").Clear

-Range("A12").Value = "xlCurrencyMinusSign"

-Range("B12").Value = 38

-Range("C12").Value = num

-B12 = Range("B12").Value

-C12 = Range("C12").Value

-If B12 = C12 Then

-Range("D12").Value = "OK"

-Else

-Range("D12").Value = "NG"

-End If

-End Function

-

-Function test_xlCurrencyNegative(ByRef num)

-Range("A13").Clear

-Range("B13").Clear

-Range("C13").Clear

-Range("D13").Clear

-Range("A13").Value = "xlCurrencyNegative"

-Range("B13").Value = 28

-Range("C13").Value = num

-B13 = Range("B13").Value

-C13 = Range("C13").Value

-If B13 = C13 Then

-Range("D13").Value = "OK"

-Else

-Range("D13").Value = "NG"

-End If

-End Function

-

-Function test_xlCurrencySpaceBefore(ByRef num)

-Range("A14").Clear

-Range("B14").Clear

-Range("C14").Clear

-Range("D14").Clear

-Range("A14").Value = "xlCurrencySpaceBefore"

-Range("B14").Value = 36

-Range("C14").Value = num

-B14 = Range("B14").Value

-C14 = Range("C14").Value

-If B14 = C14 Then

-Range("D14").Value = "OK"

-Else

-Range("D14").Value = "NG"

-End If

-End Function

-

-Function test_xlCurrencyTrailingZeros(ByRef num)

-Range("A15").Clear

-Range("B15").Clear

-Range("C15").Clear

-Range("D15").Clear

-Range("A15").Value = "xlCurrencyTrailingZeros"

-Range("B15").Value = 39

-Range("C15").Value = num

-B15 = Range("B15").Value

-C15 = Range("C15").Value

-If B15 = C15 Then

-Range("D15").Value = "OK"

-Else

-Range("D15").Value = "NG"

-End If

-End Function

-

-Function test_xlDateOrder(ByRef num)

-Range("A16").Clear

-Range("B16").Clear

-Range("C16").Clear

-Range("D16").Clear

-Range("A16").Value = "xlDateOrder"

-Range("B16").Value = 32

-Range("C16").Value = num

-B16 = Range("B16").Value

-C16 = Range("C16").Value

-If B16 = C16 Then

-Range("D16").Value = "OK"

-Else

-Range("D16").Value = "NG"

-End If

-End Function

-

-Function test_xlDateSeparator(ByRef num)

-Range("A17").Clear

-Range("B17").Clear

-Range("C17").Clear

-Range("D17").Clear

-Range("A17").Value = "xlDateSeparator"

-Range("B17").Value = 17

-Range("C17").Value = num

-B17 = Range("B17").Value

-C17 = Range("C17").Value

-If B17 = C17 Then

-Range("D17").Value = "OK"

-Else

-Range("D17").Value = "NG"

-End If

-End Function

-

-Function test_xlDayCode(ByRef num)

-Range("A18").Clear

-Range("B18").Clear

-Range("C18").Clear

-Range("D18").Clear

-Range("A18").Value = "xlDayCode"

-Range("B18").Value = 21

-Range("C18").Value = num

-B18 = Range("B18").Value

-C18 = Range("C18").Value

-If B18 = C18 Then

-Range("D18").Value = "OK"

-Else

-Range("D18").Value = "NG"

-End If

-End Function

-

-Function test_xlDayLeadingZero(ByRef num)

-Range("A19").Clear

-Range("B19").Clear

-Range("C19").Clear

-Range("D19").Clear

-Range("A19").Value = "xlDayLeadingZero"

-Range("B19").Value = 42

-Range("C19").Value = num

-B19 = Range("B19").Value

-C19 = Range("C19").Value

-If B19 = C19 Then

-Range("D19").Value = "OK"

-Else

-Range("D19").Value = "NG"

-End If

-End Function

-

-Function test_xlDecimalSeparator(ByRef num)

-Range("A20").Clear

-Range("B20").Clear

-Range("C20").Clear

-Range("D20").Clear

-Range("A20").Value = "xlDecimalSeparator"

-Range("B20").Value = 3

-Range("C20").Value = num

-B20 = Range("B20").Value

-C20 = Range("C20").Value

-If B20 = C20 Then

-Range("D20").Value = "OK"

-Else

-Range("D20").Value = "NG"

-End If

-End Function

-

-Function test_xlGeneralFormatName(ByRef num)

-Range("A21").Clear

-Range("B21").Clear

-Range("C21").Clear

-Range("D21").Clear

-Range("A21").Value = "xlGeneralFormatName"

-Range("B21").Value = 26

-Range("C21").Value = num

-B21 = Range("B21").Value

-C21 = Range("C21").Value

-If B21 = C21 Then

-Range("D21").Value = "OK"

-Else

-Range("D21").Value = "NG"

-End If

-End Function

-

-Function test_xlHourCode(ByRef num)

-Range("A22").Clear

-Range("B22").Clear

-Range("C22").Clear

-Range("D22").Clear

-Range("A22").Value = "xlHourCode"

-Range("B22").Value = 22

-Range("C22").Value = num

-B22 = Range("B22").Value

-C22 = Range("C22").Value

-If B22 = C22 Then

-Range("D22").Value = "OK"

-Else

-Range("D22").Value = "NG"

-End If

-End Function

-

-Function test_xlLeftBrace(ByRef num)

-Range("A23").Clear

-Range("B23").Clear

-Range("C23").Clear

-Range("D23").Clear

-Range("A23").Value = "xlLeftBrace"

-Range("B23").Value = 12

-Range("C23").Value = num

-B23 = Range("B23").Value

-C23 = Range("C23").Value

-If B23 = C23 Then

-Range("D23").Value = "OK"

-Else

-Range("D23").Value = "NG"

-End If

-End Function

-

-Function test_xlLeftBracket(ByRef num)

-Range("A24").Clear

-Range("B24").Clear

-Range("C24").Clear

-Range("D24").Clear

-Range("A24").Value = "xlLeftBracket"

-Range("B24").Value = 10

-Range("C24").Value = num

-B24 = Range("B24").Value

-C24 = Range("C24").Value

-If B24 = C24 Then

-Range("D24").Value = "OK"

-Else

-Range("D24").Value = "NG"

-End If

-End Function

-

-Function test_xlListSeparator(ByRef num)

-Range("A25").Clear

-Range("B25").Clear

-Range("C25").Clear

-Range("D25").Clear

-Range("A25").Value = "xlListSeparator"

-Range("B25").Value = 5

-Range("C25").Value = num

-B25 = Range("B25").Value

-C25 = Range("C25").Value

-If B25 = C25 Then

-Range("D25").Value = "OK"

-Else

-Range("D25").Value = "NG"

-End If

-End Function

-

-Function test_xlLowerCaseColumnLetter(ByRef num)

-Range("A26").Clear

-Range("B26").Clear

-Range("C26").Clear

-Range("D26").Clear

-Range("A26").Value = "xlLowerCaseColumnLetter"

-Range("B26").Value = 9

-Range("C26").Value = num

-B26 = Range("B26").Value

-C26 = Range("C26").Value

-If B26 = C26 Then

-Range("D26").Value = "OK"

-Else

-Range("D26").Value = "NG"

-End If

-End Function

-

-Function test_xlLowerCaseRowLetter(ByRef num)

-Range("A27").Clear

-Range("B27").Clear

-Range("C27").Clear

-Range("D27").Clear

-Range("A27").Value = "xlLowerCaseRowLetter"

-Range("B27").Value = 8

-Range("C27").Value = num

-B27 = Range("B27").Value

-C27 = Range("C27").Value

-If B27 = C27 Then

-Range("D27").Value = "OK"

-Else

-Range("D27").Value = "NG"

-End If

-End Function

-

-Function test_xlMDY(ByRef num)

-Range("A28").Clear

-Range("B28").Clear

-Range("C28").Clear

-Range("D28").Clear

-Range("A28").Value = "xlMDY"

-Range("B28").Value = 44

-Range("C28").Value = num

-B28 = Range("B28").Value

-C28 = Range("C28").Value

-If B28 = C28 Then

-Range("D28").Value = "OK"

-Else

-Range("D28").Value = "NG"

-End If

-End Function

-

-Function test_xlMetric(ByRef num)

-Range("A29").Clear

-Range("B29").Clear

-Range("C29").Clear

-Range("D29").Clear

-Range("A29").Value = "xlMetric"

-Range("B29").Value = 35

-Range("C29").Value = num

-B29 = Range("B29").Value

-C29 = Range("C29").Value

-If B29 = C29 Then

-Range("D29").Value = "OK"

-Else

-Range("D29").Value = "NG"

-End If

-End Function

-

-Function test_xlMinuteCode(ByRef num)

-Range("A30").Clear

-Range("B30").Clear

-Range("C30").Clear

-Range("D30").Clear

-Range("A30").Value = "xlMinuteCode"

-Range("B30").Value = 23

-Range("C30").Value = num

-B30 = Range("B30").Value

-C30 = Range("C30").Value

-If B30 = C30 Then

-Range("D30").Value = "OK"

-Else

-Range("D30").Value = "NG"

-End If

-End Function

-

-Function test_xlMonthCode(ByRef num)

-Range("A31").Clear

-Range("B31").Clear

-Range("C31").Clear

-Range("D31").Clear

-Range("A31").Value = "xlMonthCode"

-Range("B31").Value = 20

-Range("C31").Value = num

-B31 = Range("B31").Value

-C31 = Range("C31").Value

-If B31 = C31 Then

-Range("D31").Value = "OK"

-Else

-Range("D31").Value = "NG"

-End If

-End Function

-

-Function test_xlMonthLeadingZero(ByRef num)

-Range("A32").Clear

-Range("B32").Clear

-Range("C32").Clear

-Range("D32").Clear

-Range("A32").Value = "xlMonthLeadingZero"

-Range("B32").Value = 41

-Range("C32").Value = num

-B32 = Range("B32").Value

-C32 = Range("C32").Value

-If B32 = C32 Then

-Range("D32").Value = "OK"

-Else

-Range("D32").Value = "NG"

-End If

-End Function

-

-Function test_xlMonthNameChars(ByRef num)

-Range("A33").Clear

-Range("B33").Clear

-Range("C33").Clear

-Range("D33").Clear

-Range("A33").Value = "xlMonthNameChars"

-Range("B33").Value = 30

-Range("C33").Value = num

-B33 = Range("B33").Value

-C33 = Range("C33").Value

-If B33 = C33 Then

-Range("D33").Value = "OK"

-Else

-Range("D33").Value = "NG"

-End If

-End Function

-

-Function test_xlNocurrencyDigits(ByRef num)

-Range("A34").Clear

-Range("B34").Clear

-Range("C34").Clear

-Range("D34").Clear

-Range("A34").Value = "xlNocurrencyDigits"

-Range("B34").Value = 29

-Range("C34").Value = num

-B34 = Range("B34").Value

-C34 = Range("C34").Value

-If B34 = C34 Then

-Range("D34").Value = "OK"

-Else

-Range("D34").Value = "NG"

-End If

-End Function

-

-Function test_xlNonEnglishFunctions(ByRef num)

-Range("A35").Clear

-Range("B35").Clear

-Range("C35").Clear

-Range("D35").Clear

-Range("A35").Value = "xlNonEnglishFunctions"

-Range("B35").Value = 34

-Range("C35").Value = num

-B35 = Range("B35").Value

-C35 = Range("C35").Value

-If B35 = C35 Then

-Range("D35").Value = "OK"

-Else

-Range("D35").Value = "NG"

-End If

-End Function

-

-Function test_xlRightBrace(ByRef num)

-Range("A36").Clear

-Range("B36").Clear

-Range("C36").Clear

-Range("D36").Clear

-Range("A36").Value = "xlRightBrace"

-Range("B36").Value = 13

-Range("C36").Value = num

-B36 = Range("B36").Value

-C36 = Range("C36").Value

-If B36 = C36 Then

-Range("D36").Value = "OK"

-Else

-Range("D36").Value = "NG"

-End If

-End Function

-

-Function test_xlRightBracket(ByRef num)

-Range("A37").Clear

-Range("B37").Clear

-Range("C37").Clear

-Range("D37").Clear

-Range("A37").Value = "xlRightBracket"

-Range("B37").Value = 11

-Range("C37").Value = num

-B37 = Range("B37").Value

-C37 = Range("C37").Value

-If B37 = C37 Then

-Range("D37").Value = "OK"

-Else

-Range("D37").Value = "NG"

-End If

-End Function

-

-Function test_xlRowSeparator(ByRef num)

-Range("A38").Clear

-Range("B38").Clear

-Range("C38").Clear

-Range("D38").Clear

-Range("A38").Value = "xlRowSeparator"

-Range("B38").Value = 15

-Range("C38").Value = num

-B38 = Range("B38").Value

-C38 = Range("C38").Value

-If B38 = C38 Then

-Range("D38").Value = "OK"

-Else

-Range("D38").Value = "NG"

-End If

-End Function

-

-Function test_xlSecondCode(ByRef num)

-Range("A39").Clear

-Range("B39").Clear

-Range("C39").Clear

-Range("D39").Clear

-Range("A39").Value = "xlSecondCode"

-Range("B39").Value = 24

-Range("C39").Value = num

-B39 = Range("B39").Value

-C39 = Range("C39").Value

-If B39 = C39 Then

-Range("D39").Value = "OK"

-Else

-Range("D39").Value = "NG"

-End If

-End Function

-

-Function test_xlThousandsSeparator(ByRef num)

-Range("A40").Clear

-Range("B40").Clear

-Range("C40").Clear

-Range("D40").Clear

-Range("A40").Value = "xlThousandsSeparator"

-Range("B40").Value = 4

-Range("C40").Value = num

-B40 = Range("B40").Value

-C40 = Range("C40").Value

-If B40 = C40 Then

-Range("D40").Value = "OK"

-Else

-Range("D40").Value = "NG"

-End If

-End Function

-

-Function test_xlTimeLeadingZero(ByRef num)

-Range("A41").Clear

-Range("B41").Clear

-Range("C41").Clear

-Range("D41").Clear

-Range("A41").Value = "xlTimeLeadingZero"

-Range("B41").Value = 45

-Range("C41").Value = num

-B41 = Range("B41").Value

-C41 = Range("C41").Value

-If B41 = C41 Then

-Range("D41").Value = "OK"

-Else

-Range("D41").Value = "NG"

-End If

-End Function

-

-Function test_xlTimeSeparator(ByRef num)

-Range("A42").Clear

-Range("B42").Clear

-Range("C42").Clear

-Range("D42").Clear

-Range("A42").Value = "xlTimeSeparator"

-Range("B42").Value = 18

-Range("C42").Value = num

-B42 = Range("B42").Value

-C42 = Range("C42").Value

-If B42 = C42 Then

-Range("D42").Value = "OK"

-Else

-Range("D42").Value = "NG"

-End If

-End Function

-

-Function test_xlUpperCaseColumnLetter(ByRef num)

-Range("A43").Clear

-Range("B43").Clear

-Range("C43").Clear

-Range("D43").Clear

-Range("A43").Value = "xlUpperCaseColumnLetter"

-Range("B43").Value = 7

-Range("C43").Value = num

-B43 = Range("B43").Value

-C43 = Range("C43").Value

-If B43 = C43 Then

-Range("D43").Value = "OK"

-Else

-Range("D43").Value = "NG"

-End If

-End Function

-

-Function test_xlUpperCaseRowLetter(ByRef num)

-Range("A44").Clear

-Range("B44").Clear

-Range("C44").Clear

-Range("D44").Clear

-Range("A44").Value = "xlUpperCaseRowLetter"

-Range("B44").Value = 6

-Range("C44").Value = num

-B44 = Range("B44").Value

-C44 = Range("C44").Value

-If B44 = C44 Then

-Range("D44").Value = "OK"

-Else

-Range("D44").Value = "NG"

-End If

-End Function

-

-Function test_xlWeekdayNameChars(ByRef num)

-Range("A45").Clear

-Range("B45").Clear

-Range("C45").Clear

-Range("D45").Clear

-Range("A45").Value = "xlWeekdayNameChars"

-Range("B45").Value = 31

-Range("C45").Value = num

-B45 = Range("B45").Value

-C45 = Range("C45").Value

-If B45 = C45 Then

-Range("D45").Value = "OK"

-Else

-Range("D45").Value = "NG"

-End If

-End Function

-

-Function test_xlYearCode(ByRef num)

-Range("A46").Clear

-Range("B46").Clear

-Range("C46").Clear

-Range("D46").Clear

-Range("A46").Value = "xlYearCode"

-Range("B46").Value = 19

-Range("C46").Value = num

-B46 = Range("B46").Value

-C46 = Range("C46").Value

-If B46 = C46 Then

-Range("D46").Value = "OK"

-Else

-Range("D46").Value = "NG"

-End If

-End Function

-

-Function test_xlColumnThenRow(ByRef num)

-Range("A47").Clear

-Range("B47").Clear

-Range("C47").Clear

-Range("D47").Clear

-Range("A47").Value = "xlColumnThenRow"

-Range("B47").Value = 2

-Range("C47").Value = num

-B47 = Range("B47").Value

-C47 = Range("C47").Value

-If B47 = C47 Then

-Range("D47").Value = "OK"

-Else

-Range("D47").Value = "NG"

-End If

-End Function

-

-Function test_xlRowThenColumn(ByRef num)

-Range("A48").Clear

-Range("B48").Clear

-Range("C48").Clear

-Range("D48").Clear

-Range("A48").Value = "xlRowThenColumn"

-Range("B48").Value = 1

-Range("C48").Value = num

-B48 = Range("B48").Value

-C48 = Range("C48").Value

-If B48 = C48 Then

-Range("D48").Value = "OK"

-Else

-Range("D48").Value = "NG"

-End If

-End Function

-

-Function test_xlArabicBothStrict(ByRef num)

-Range("A49").Clear

-Range("B49").Clear

-Range("C49").Clear

-Range("D49").Clear

-Range("A49").Value = "xlArabicBothStrict"

-Range("B49").Value = 3

-Range("C49").Value = num

-B49 = Range("B49").Value

-C49 = Range("C49").Value

-If B49 = C49 Then

-Range("D49").Value = "OK"

-Else

-Range("D49").Value = "NG"

-End If

-End Function

-

-Function test_xlArabicNone(ByRef num)

-Range("A50").Clear

-Range("B50").Clear

-Range("C50").Clear

-Range("D50").Clear

-Range("A50").Value = "xlArabicNone"

-Range("B50").Value = 0

-Range("C50").Value = num

-B50 = Range("B50").Value

-C50 = Range("C50").Value

-If B50 = C50 Then

-Range("D50").Value = "OK"

-Else

-Range("D50").Value = "NG"

-End If

-End Function

-

-Function test_xlArabicStrictAlefHamza(ByRef num)

-Range("A51").Clear

-Range("B51").Clear

-Range("C51").Clear

-Range("D51").Clear

-Range("A51").Value = "xlArabicStrictAlefHamza"

-Range("B51").Value = 1

-Range("C51").Value = num

-B51 = Range("B51").Value

-C51 = Range("C51").Value

-If B51 = C51 Then

-Range("D51").Value = "OK"

-Else

-Range("D51").Value = "NG"

-End If

-End Function

-

-Function test_xlArabicStrictFinalYaa(ByRef num)

-Range("A52").Clear

-Range("B52").Clear

-Range("C52").Clear

-Range("D52").Clear

-Range("A52").Value = "xlArabicStrictFinalYaa"

-Range("B52").Value = 2

-Range("C52").Value = num

-B52 = Range("B52").Value

-C52 = Range("C52").Value

-If B52 = C52 Then

-Range("D52").Value = "OK"

-Else

-Range("D52").Value = "NG"

-End If

-End Function

-

-Function test_xlArrangeStyleCascade(ByRef num)

-Range("A53").Clear

-Range("B53").Clear

-Range("C53").Clear

-Range("D53").Clear

-Range("A53").Value = "xlArrangeStyleCascade"

-Range("B53").Value = 7

-Range("C53").Value = num

-B53 = Range("B53").Value

-C53 = Range("C53").Value

-If B53 = C53 Then

-Range("D53").Value = "OK"

-Else

-Range("D53").Value = "NG"

-End If

-End Function

-

-Function test_xlArrangeStyleHorizontal(ByRef num)

-Range("A54").Clear

-Range("B54").Clear

-Range("C54").Clear

-Range("D54").Clear

-Range("A54").Value = "xlArrangeStyleHorizontal"

-Range("B54").Value = -4128

-Range("C54").Value = num

-B54 = Range("B54").Value

-C54 = Range("C54").Value

-If B54 = C54 Then

-Range("D54").Value = "OK"

-Else

-Range("D54").Value = "NG"

-End If

-End Function

-

-Function test_xlArrangeStyleTiled(ByRef num)

-Range("A55").Clear

-Range("B55").Clear

-Range("C55").Clear

-Range("D55").Clear

-Range("A55").Value = "xlArrangeStyleTiled"

-Range("B55").Value = 1

-Range("C55").Value = num

-B55 = Range("B55").Value

-C55 = Range("C55").Value

-If B55 = C55 Then

-Range("D55").Value = "OK"

-Else

-Range("D55").Value = "NG"

-End If

-End Function

-

-Function test_xlArrangeStyleVertical(ByRef num)

-Range("A56").Clear

-Range("B56").Clear

-Range("C56").Clear

-Range("D56").Clear

-Range("A56").Value = "xlArrangeStyleVertical"

-Range("B56").Value = -4166

-Range("C56").Value = num

-B56 = Range("B56").Value

-C56 = Range("C56").Value

-If B56 = C56 Then

-Range("D56").Value = "OK"

-Else

-Range("D56").Value = "NG"

-End If

-End Function

-

-Function test_xlArrowHeadLengthLong(ByRef num)

-Range("A57").Clear

-Range("B57").Clear

-Range("C57").Clear

-Range("D57").Clear

-Range("A57").Value = "xlArrowHeadLengthLong"

-Range("B57").Value = 3

-Range("C57").Value = num

-B57 = Range("B57").Value

-C57 = Range("C57").Value

-If B57 = C57 Then

-Range("D57").Value = "OK"

-Else

-Range("D57").Value = "NG"

-End If

-End Function

-

-Function test_xlArrowHeadLengthMedium(ByRef num)

-Range("A58").Clear

-Range("B58").Clear

-Range("C58").Clear

-Range("D58").Clear

-Range("A58").Value = "xlArrowHeadLengthMedium"

-Range("B58").Value = -4138

-Range("C58").Value = num

-B58 = Range("B58").Value

-C58 = Range("C58").Value

-If B58 = C58 Then

-Range("D58").Value = "OK"

-Else

-Range("D58").Value = "NG"

-End If

-End Function

-

-Function test_xlArrowHeadLengthShort(ByRef num)

-Range("A59").Clear

-Range("B59").Clear

-Range("C59").Clear

-Range("D59").Clear

-Range("A59").Value = "xlArrowHeadLengthShort"

-Range("B59").Value = 1

-Range("C59").Value = num

-B59 = Range("B59").Value

-C59 = Range("C59").Value

-If B59 = C59 Then

-Range("D59").Value = "OK"

-Else

-Range("D59").Value = "NG"

-End If

-End Function

-

-Function test_xlArrowHeadStyleClosed(ByRef num)

-Range("A60").Clear

-Range("B60").Clear

-Range("C60").Clear

-Range("D60").Clear

-Range("A60").Value = "xlArrowHeadStyleClosed"

-Range("B60").Value = 3

-Range("C60").Value = num

-B60 = Range("B60").Value

-C60 = Range("C60").Value

-If B60 = C60 Then

-Range("D60").Value = "OK"

-Else

-Range("D60").Value = "NG"

-End If

-End Function

-

-Function test_xlArrowHeadStyleDoubleClosed(ByRef num)

-Range("A61").Clear

-Range("B61").Clear

-Range("C61").Clear

-Range("D61").Clear

-Range("A61").Value = "xlArrowHeadStyleDoubleClosed"

-Range("B61").Value = 4

-Range("C61").Value = num

-B61 = Range("B61").Value

-C61 = Range("C61").Value

-If B61 = C61 Then

-Range("D61").Value = "OK"

-Else

-Range("D61").Value = "NG"

-End If

-End Function

-

-Function test_xlArrowHeadStyleDoubleOpen(ByRef num)

-Range("A62").Clear

-Range("B62").Clear

-Range("C62").Clear

-Range("D62").Clear

-Range("A62").Value = "xlArrowHeadStyleDoubleOpen"

-Range("B62").Value = 5

-Range("C62").Value = num

-B62 = Range("B62").Value

-C62 = Range("C62").Value

-If B62 = C62 Then

-Range("D62").Value = "OK"

-Else

-Range("D62").Value = "NG"

-End If

-End Function

-

-Function test_xlArrowHeadStyleNone(ByRef num)

-Range("A63").Clear

-Range("B63").Clear

-Range("C63").Clear

-Range("D63").Clear

-Range("A63").Value = "xlArrowHeadStyleNone"

-Range("B63").Value = -4142

-Range("C63").Value = num

-B63 = Range("B63").Value

-C63 = Range("C63").Value

-If B63 = C63 Then

-Range("D63").Value = "OK"

-Else

-Range("D63").Value = "NG"

-End If

-End Function

-

-Function test_xlArrowHeadStyleOpen(ByRef num)

-Range("A64").Clear

-Range("B64").Clear

-Range("C64").Clear

-Range("D64").Clear

-Range("A64").Value = "xlArrowHeadStyleOpen"

-Range("B64").Value = 2

-Range("C64").Value = num

-B64 = Range("B64").Value

-C64 = Range("C64").Value

-If B64 = C64 Then

-Range("D64").Value = "OK"

-Else

-Range("D64").Value = "NG"

-End If

-End Function

-

-Function test_xlArrowHeadWidthMedium(ByRef num)

-Range("A65").Clear

-Range("B65").Clear

-Range("C65").Clear

-Range("D65").Clear

-Range("A65").Value = "xlArrowHeadWidthMedium"

-Range("B65").Value = -4138

-Range("C65").Value = num

-B65 = Range("B65").Value

-C65 = Range("C65").Value

-If B65 = C65 Then

-Range("D65").Value = "OK"

-Else

-Range("D65").Value = "NG"

-End If

-End Function

-

-Function test_xlArrowHeadWidthNarrow(ByRef num)

-Range("A66").Clear

-Range("B66").Clear

-Range("C66").Clear

-Range("D66").Clear

-Range("A66").Value = "xlArrowHeadWidthNarrow"

-Range("B66").Value = 1

-Range("C66").Value = num

-B66 = Range("B66").Value

-C66 = Range("C66").Value

-If B66 = C66 Then

-Range("D66").Value = "OK"

-Else

-Range("D66").Value = "NG"

-End If

-End Function

-

-Function test_xlArrowHeadWidthWide(ByRef num)

-Range("A67").Clear

-Range("B67").Clear

-Range("C67").Clear

-Range("D67").Clear

-Range("A67").Value = "xlArrowHeadWidthWide"

-Range("B67").Value = 3

-Range("C67").Value = num

-B67 = Range("B67").Value

-C67 = Range("C67").Value

-If B67 = C67 Then

-Range("D67").Value = "OK"

-Else

-Range("D67").Value = "NG"

-End If

-End Function

-

-Function test_xlFillCopy(ByRef num)

-Range("A68").Clear

-Range("B68").Clear

-Range("C68").Clear

-Range("D68").Clear

-Range("A68").Value = "xlFillCopy"

-Range("B68").Value = 1

-Range("C68").Value = num

-B68 = Range("B68").Value

-C68 = Range("C68").Value

-If B68 = C68 Then

-Range("D68").Value = "OK"

-Else

-Range("D68").Value = "NG"

-End If

-End Function

-

-Function test_xlFillDays(ByRef num)

-Range("A69").Clear

-Range("B69").Clear

-Range("C69").Clear

-Range("D69").Clear

-Range("A69").Value = "xlFillDays"

-Range("B69").Value = 5

-Range("C69").Value = num

-B69 = Range("B69").Value

-C69 = Range("C69").Value

-If B69 = C69 Then

-Range("D69").Value = "OK"

-Else

-Range("D69").Value = "NG"

-End If

-End Function

-

-Function test_xlFillDefault(ByRef num)

-Range("A70").Clear

-Range("B70").Clear

-Range("C70").Clear

-Range("D70").Clear

-Range("A70").Value = "xlFillDefault"

-Range("B70").Value = 0

-Range("C70").Value = num

-B70 = Range("B70").Value

-C70 = Range("C70").Value

-If B70 = C70 Then

-Range("D70").Value = "OK"

-Else

-Range("D70").Value = "NG"

-End If

-End Function

-

-Function test_xlFillFormats(ByRef num)

-Range("A71").Clear

-Range("B71").Clear

-Range("C71").Clear

-Range("D71").Clear

-Range("A71").Value = "xlFillFormats"

-Range("B71").Value = 3

-Range("C71").Value = num

-B71 = Range("B71").Value

-C71 = Range("C71").Value

-If B71 = C71 Then

-Range("D71").Value = "OK"

-Else

-Range("D71").Value = "NG"

-End If

-End Function

-

-Function test_xlFillMonths(ByRef num)

-Range("A72").Clear

-Range("B72").Clear

-Range("C72").Clear

-Range("D72").Clear

-Range("A72").Value = "xlFillMonths"

-Range("B72").Value = 7

-Range("C72").Value = num

-B72 = Range("B72").Value

-C72 = Range("C72").Value

-If B72 = C72 Then

-Range("D72").Value = "OK"

-Else

-Range("D72").Value = "NG"

-End If

-End Function

-

-Function test_xlFillSeries(ByRef num)

-Range("A73").Clear

-Range("B73").Clear

-Range("C73").Clear

-Range("D73").Clear

-Range("A73").Value = "xlFillSeries"

-Range("B73").Value = 2

-Range("C73").Value = num

-B73 = Range("B73").Value

-C73 = Range("C73").Value

-If B73 = C73 Then

-Range("D73").Value = "OK"

-Else

-Range("D73").Value = "NG"

-End If

-End Function

-

-Function test_xlFillValues(ByRef num)

-Range("A74").Clear

-Range("B74").Clear

-Range("C74").Clear

-Range("D74").Clear

-Range("A74").Value = "xlFillValues"

-Range("B74").Value = 4

-Range("C74").Value = num

-B74 = Range("B74").Value

-C74 = Range("C74").Value

-If B74 = C74 Then

-Range("D74").Value = "OK"

-Else

-Range("D74").Value = "NG"

-End If

-End Function

-

-Function test_xlFillWeekdays(ByRef num)

-Range("A75").Clear

-Range("B75").Clear

-Range("C75").Clear

-Range("D75").Clear

-Range("A75").Value = "xlFillWeekdays"

-Range("B75").Value = 6

-Range("C75").Value = num

-B75 = Range("B75").Value

-C75 = Range("C75").Value

-If B75 = C75 Then

-Range("D75").Value = "OK"

-Else

-Range("D75").Value = "NG"

-End If

-End Function

-

-Function test_xlFillYears(ByRef num)

-Range("A76").Clear

-Range("B76").Clear

-Range("C76").Clear

-Range("D76").Clear

-Range("A76").Value = "xlFillYears"

-Range("B76").Value = 8

-Range("C76").Value = num

-B76 = Range("B76").Value

-C76 = Range("C76").Value

-If B76 = C76 Then

-Range("D76").Value = "OK"

-Else

-Range("D76").Value = "NG"

-End If

-End Function

-

-Function test_xlGrowthTrend(ByRef num)

-Range("A77").Clear

-Range("B77").Clear

-Range("C77").Clear

-Range("D77").Clear

-Range("A77").Value = "xlGrowthTrend"

-Range("B77").Value = 10

-Range("C77").Value = num

-B77 = Range("B77").Value

-C77 = Range("C77").Value

-If B77 = C77 Then

-Range("D77").Value = "OK"

-Else

-Range("D77").Value = "NG"

-End If

-End Function

-

-Function test_xlLinearTrend(ByRef num)

-Range("A78").Clear

-Range("B78").Clear

-Range("C78").Clear

-Range("D78").Clear

-Range("A78").Value = "xlLinearTrend"

-Range("B78").Value = 9

-Range("C78").Value = num

-B78 = Range("B78").Value

-C78 = Range("C78").Value

-If B78 = C78 Then

-Range("D78").Value = "OK"

-Else

-Range("D78").Value = "NG"

-End If

-End Function

-

-Function test_xlAnd(ByRef num)

-Range("A79").Clear

-Range("B79").Clear

-Range("C79").Clear

-Range("D79").Clear

-Range("A79").Value = "xlAnd"

-Range("B79").Value = 1

-Range("C79").Value = num

-B79 = Range("B79").Value

-C79 = Range("C79").Value

-If B79 = C79 Then

-Range("D79").Value = "OK"

-Else

-Range("D79").Value = "NG"

-End If

-End Function

-

-Function test_xlBottom10Items(ByRef num)

-Range("A80").Clear

-Range("B80").Clear

-Range("C80").Clear

-Range("D80").Clear

-Range("A80").Value = "xlBottom10Items"

-Range("B80").Value = 4

-Range("C80").Value = num

-B80 = Range("B80").Value

-C80 = Range("C80").Value

-If B80 = C80 Then

-Range("D80").Value = "OK"

-Else

-Range("D80").Value = "NG"

-End If

-End Function

-

-Function test_xlBottom10Percent(ByRef num)

-Range("A81").Clear

-Range("B81").Clear

-Range("C81").Clear

-Range("D81").Clear

-Range("A81").Value = "xlBottom10Percent"

-Range("B81").Value = 6

-Range("C81").Value = num

-B81 = Range("B81").Value

-C81 = Range("C81").Value

-If B81 = C81 Then

-Range("D81").Value = "OK"

-Else

-Range("D81").Value = "NG"

-End If

-End Function

-

-Function test_xlOr(ByRef num)

-Range("A82").Clear

-Range("B82").Clear

-Range("C82").Clear

-Range("D82").Clear

-Range("A82").Value = "xlOr"

-Range("B82").Value = 2

-Range("C82").Value = num

-B82 = Range("B82").Value

-C82 = Range("C82").Value

-If B82 = C82 Then

-Range("D82").Value = "OK"

-Else

-Range("D82").Value = "NG"

-End If

-End Function

-

-Function test_xlTop10Items(ByRef num)

-Range("A83").Clear

-Range("B83").Clear

-Range("C83").Clear

-Range("D83").Clear

-Range("A83").Value = "xlTop10Items"

-Range("B83").Value = 3

-Range("C83").Value = num

-B83 = Range("B83").Value

-C83 = Range("C83").Value

-If B83 = C83 Then

-Range("D83").Value = "OK"

-Else

-Range("D83").Value = "NG"

-End If

-End Function

-

-Function test_xlTop10Percent(ByRef num)

-Range("A84").Clear

-Range("B84").Clear

-Range("C84").Clear

-Range("D84").Clear

-Range("A84").Value = "xlTop10Percent"

-Range("B84").Value = 5

-Range("C84").Value = num

-B84 = Range("B84").Value

-C84 = Range("C84").Value

-If B84 = C84 Then

-Range("D84").Value = "OK"

-Else

-Range("D84").Value = "NG"

-End If

-End Function

-

-Function test_xlAxisCrossesAutomatic(ByRef num)

-Range("A85").Clear

-Range("B85").Clear

-Range("C85").Clear

-Range("D85").Clear

-Range("A85").Value = "xlAxisCrossesAutomatic"

-Range("B85").Value = -4105

-Range("C85").Value = num

-B85 = Range("B85").Value

-C85 = Range("C85").Value

-If B85 = C85 Then

-Range("D85").Value = "OK"

-Else

-Range("D85").Value = "NG"

-End If

-End Function

-

-Function test_xlAxisCrossesCustom(ByRef num)

-Range("A86").Clear

-Range("B86").Clear

-Range("C86").Clear

-Range("D86").Clear

-Range("A86").Value = "xlAxisCrossesCustom"

-Range("B86").Value = -4114

-Range("C86").Value = num

-B86 = Range("B86").Value

-C86 = Range("C86").Value

-If B86 = C86 Then

-Range("D86").Value = "OK"

-Else

-Range("D86").Value = "NG"

-End If

-End Function

-

-Function test_xlAxisCrossesMaximum(ByRef num)

-Range("A87").Clear

-Range("B87").Clear

-Range("C87").Clear

-Range("D87").Clear

-Range("A87").Value = "xlAxisCrossesMaximum"

-Range("B87").Value = 2

-Range("C87").Value = num

-B87 = Range("B87").Value

-C87 = Range("C87").Value

-If B87 = C87 Then

-Range("D87").Value = "OK"

-Else

-Range("D87").Value = "NG"

-End If

-End Function

-

-Function test_xlAxisCrossesMinimum(ByRef num)

-Range("A88").Clear

-Range("B88").Clear

-Range("C88").Clear

-Range("D88").Clear

-Range("A88").Value = "xlAxisCrossesMinimum"

-Range("B88").Value = 4

-Range("C88").Value = num

-B88 = Range("B88").Value

-C88 = Range("C88").Value

-If B88 = C88 Then

-Range("D88").Value = "OK"

-Else

-Range("D88").Value = "NG"

-End If

-End Function

-

-Function test_xlPrimary(ByRef num)

-Range("A89").Clear

-Range("B89").Clear

-Range("C89").Clear

-Range("D89").Clear

-Range("A89").Value = "xlPrimary"

-Range("B89").Value = 1

-Range("C89").Value = num

-B89 = Range("B89").Value

-C89 = Range("C89").Value

-If B89 = C89 Then

-Range("D89").Value = "OK"

-Else

-Range("D89").Value = "NG"

-End If

-End Function

-

-Function test_xlSecondary(ByRef num)

-Range("A90").Clear

-Range("B90").Clear

-Range("C90").Clear

-Range("D90").Clear

-Range("A90").Value = "xlSecondary"

-Range("B90").Value = 2

-Range("C90").Value = num

-B90 = Range("B90").Value

-C90 = Range("C90").Value

-If B90 = C90 Then

-Range("D90").Value = "OK"

-Else

-Range("D90").Value = "NG"

-End If

-End Function

-

-Function test_xlCategory(ByRef num)

-Range("A91").Clear

-Range("B91").Clear

-Range("C91").Clear

-Range("D91").Clear

-Range("A91").Value = "xlCategory"

-Range("B91").Value = 1

-Range("C91").Value = num

-B91 = Range("B91").Value

-C91 = Range("C91").Value

-If B91 = C91 Then

-Range("D91").Value = "OK"

-Else

-Range("D91").Value = "NG"

-End If

-End Function

-

-Function test_xlSeriesAxis(ByRef num)

-Range("A92").Clear

-Range("B92").Clear

-Range("C92").Clear

-Range("D92").Clear

-Range("A92").Value = "xlSeriesAxis"

-Range("B92").Value = 3

-Range("C92").Value = num

-B92 = Range("B92").Value

-C92 = Range("C92").Value

-If B92 = C92 Then

-Range("D92").Value = "OK"

-Else

-Range("D92").Value = "NG"

-End If

-End Function

-

-Function test_xlValue(ByRef num)

-Range("A93").Clear

-Range("B93").Clear

-Range("C93").Clear

-Range("D93").Clear

-Range("A93").Value = "xlValue"

-Range("B93").Value = 2

-Range("C93").Value = num

-B93 = Range("B93").Value

-C93 = Range("C93").Value

-If B93 = C93 Then

-Range("D93").Value = "OK"

-Else

-Range("D93").Value = "NG"

-End If

-End Function

-

-<<<<<<
-======================
-Module2
->>>>>>
-Attribute VB_Name = "Module2"

-

-Sub main_2()

-test_xlBackgroundAutomatic (xlBackgroundAutomatic)

-test_xlBackgroundOpaque (xlBackgroundOpaque)

-test_xlBackgroundTransparent (xlBackgroundTransparent)

-test_xlHairline (xlHairline)

-test_xlMedium (xlMedium)

-test_xlThick (xlThick)

-test_xlThin (xlThin)

-test_xlBox (xlBox)

-test_xlConeToMax (xlConeToMax)

-test_xlConeToPoint (xlConeToPoint)

-test_xlCylinder (xlCylinder)

-test_xlPyramidToMax (xlPyramidToMax)

-test_xlPyramidToPoint (xlPyramidToPoint)

-Range("A1").Value = "constant name"

-Range("B1").Value = "OOo result"

-Range("C1").Value = "Excel result"

-Range("D1").Value = "Correct?"

-End Sub

-

-Function test_xlBackgroundAutomatic(ByRef num)

-Range("A2").Clear

-Range("B2").Clear

-Range("C2").Clear

-Range("D2").Clear

-Range("A2").Value = "xlBackgroundAutomatic"

-Range("B2").Value = -4105

-Range("C2").Value = num

-B2 = Range("B2").Value

-C2 = Range("C2").Value

-If B2 = C2 Then

-Range("D2").Value = "OK"

-Else

-Range("D2").Value = "NG"

-End If

-End Function

-

-Function test_xlBackgroundOpaque(ByRef num)

-Range("A3").Clear

-Range("B3").Clear

-Range("C3").Clear

-Range("D3").Clear

-Range("A3").Value = "xlBackgroundOpaque"

-Range("B3").Value = 3

-Range("C3").Value = num

-B3 = Range("B3").Value

-C3 = Range("C3").Value

-If B3 = C3 Then

-Range("D3").Value = "OK"

-Else

-Range("D3").Value = "NG"

-End If

-End Function

-

-Function test_xlBackgroundTransparent(ByRef num)

-Range("A4").Clear

-Range("B4").Clear

-Range("C4").Clear

-Range("D4").Clear

-Range("A4").Value = "xlBackgroundTransparent"

-Range("B4").Value = 2

-Range("C4").Value = num

-B4 = Range("B4").Value

-C4 = Range("C4").Value

-If B4 = C4 Then

-Range("D4").Value = "OK"

-Else

-Range("D4").Value = "NG"

-End If

-End Function

-

-Function test_xlHairline(ByRef num)

-Range("A5").Clear

-Range("B5").Clear

-Range("C5").Clear

-Range("D5").Clear

-Range("A5").Value = "xlHairline"

-Range("B5").Value = 1

-Range("C5").Value = num

-B5 = Range("B5").Value

-C5 = Range("C5").Value

-If B5 = C5 Then

-Range("D5").Value = "OK"

-Else

-Range("D5").Value = "NG"

-End If

-End Function

-

-Function test_xlMedium(ByRef num)

-Range("A6").Clear

-Range("B6").Clear

-Range("C6").Clear

-Range("D6").Clear

-Range("A6").Value = "xlMedium"

-Range("B6").Value = -4138

-Range("C6").Value = num

-B6 = Range("B6").Value

-C6 = Range("C6").Value

-If B6 = C6 Then

-Range("D6").Value = "OK"

-Else

-Range("D6").Value = "NG"

-End If

-End Function

-

-Function test_xlThick(ByRef num)

-Range("A7").Clear

-Range("B7").Clear

-Range("C7").Clear

-Range("D7").Clear

-Range("A7").Value = "xlThick"

-Range("B7").Value = 4

-Range("C7").Value = num

-B7 = Range("B7").Value

-C7 = Range("C7").Value

-If B7 = C7 Then

-Range("D7").Value = "OK"

-Else

-Range("D7").Value = "NG"

-End If

-End Function

-

-Function test_xlThin(ByRef num)

-Range("A8").Clear

-Range("B8").Clear

-Range("C8").Clear

-Range("D8").Clear

-Range("A8").Value = "xlThin"

-Range("B8").Value = 2

-Range("C8").Value = num

-B8 = Range("B8").Value

-C8 = Range("C8").Value

-If B8 = C8 Then

-Range("D8").Value = "OK"

-Else

-Range("D8").Value = "NG"

-End If

-End Function

-

-Function test_xlBox(ByRef num)

-Range("A9").Clear

-Range("B9").Clear

-Range("C9").Clear

-Range("D9").Clear

-Range("A9").Value = "xlBox"

-Range("B9").Value = 0

-Range("C9").Value = num

-B9 = Range("B9").Value

-C9 = Range("C9").Value

-If B9 = C9 Then

-Range("D9").Value = "OK"

-Else

-Range("D9").Value = "NG"

-End If

-End Function

-

-Function test_xlConeToMax(ByRef num)

-Range("A10").Clear

-Range("B10").Clear

-Range("C10").Clear

-Range("D10").Clear

-Range("A10").Value = "xlConeToMax"

-Range("B10").Value = 5

-Range("C10").Value = num

-B10 = Range("B10").Value

-C10 = Range("C10").Value

-If B10 = C10 Then

-Range("D10").Value = "OK"

-Else

-Range("D10").Value = "NG"

-End If

-End Function

-

-Function test_xlConeToPoint(ByRef num)

-Range("A11").Clear

-Range("B11").Clear

-Range("C11").Clear

-Range("D11").Clear

-Range("A11").Value = "xlConeToPoint"

-Range("B11").Value = 4

-Range("C11").Value = num

-B11 = Range("B11").Value

-C11 = Range("C11").Value

-If B11 = C11 Then

-Range("D11").Value = "OK"

-Else

-Range("D11").Value = "NG"

-End If

-End Function

-

-Function test_xlCylinder(ByRef num)

-Range("A12").Clear

-Range("B12").Clear

-Range("C12").Clear

-Range("D12").Clear

-Range("A12").Value = "xlCylinder"

-Range("B12").Value = 3

-Range("C12").Value = num

-B12 = Range("B12").Value

-C12 = Range("C12").Value

-If B12 = C12 Then

-Range("D12").Value = "OK"

-Else

-Range("D12").Value = "NG"

-End If

-End Function

-

-Function test_xlPyramidToMax(ByRef num)

-Range("A13").Clear

-Range("B13").Clear

-Range("C13").Clear

-Range("D13").Clear

-Range("A13").Value = "xlPyramidToMax"

-Range("B13").Value = 2

-Range("C13").Value = num

-B13 = Range("B13").Value

-C13 = Range("C13").Value

-If B13 = C13 Then

-Range("D13").Value = "OK"

-Else

-Range("D13").Value = "NG"

-End If

-End Function

-

-Function test_xlPyramidToPoint(ByRef num)

-Range("A14").Clear

-Range("B14").Clear

-Range("C14").Clear

-Range("D14").Clear

-Range("A14").Value = "xlPyramidToPoint"

-Range("B14").Value = 1

-Range("C14").Value = num

-B14 = Range("B14").Value

-C14 = Range("C14").Value

-If B14 = C14 Then

-Range("D14").Value = "OK"

-Else

-Range("D14").Value = "NG"

-End If

-End Function

-

-<<<<<<
-======================
-Module3
->>>>>>
-Attribute VB_Name = "Module3"

-Sub main_3()

-test_xlDialogActivate (xlDialogActivate)

-test_xlDialogActiveCellFont (xlDialogActiveCellFont)

-test_xlDialogAddChartAutoformat (xlDialogAddChartAutoformat)

-test_xlDialogAddinManager (xlDialogAddinManager)

-test_xlDialogAlignment (xlDialogAlignment)

-test_xlDialogApplyNames (xlDialogApplyNames)

-test_xlDialogApplyStyle (xlDialogApplyStyle)

-test_xlDialogAppMove (xlDialogAppMove)

-test_xlDialogAppSize (xlDialogAppSize)

-test_xlDialogArrangeAll (xlDialogArrangeAll)

-test_xlDialogAssignToObject (xlDialogAssignToObject)

-test_xlDialogAssignToTool (xlDialogAssignToTool)

-test_xlDialogAttachText (xlDialogAttachText)

-test_xlDialogAttachToolbars (xlDialogAttachToolbars)

-test_xlDialogAutoCorrect (xlDialogAutoCorrect)

-test_xlDialogAxes (xlDialogAxes)

-test_xlDialogBorder (xlDialogBorder)

-test_xlDialogCalculation (xlDialogCalculation)

-test_xlDialogCellProtection (xlDialogCellProtection)

-test_xlDialogChangeLink (xlDialogChangeLink)

-test_xlDialogChartAddData (xlDialogChartAddData)

-test_xlDialogChartLocation (xlDialogChartLocation)

-test_xlDialogChartOptionDataLabelMultiple (xlDialogChartOptionDataLabelMultiple)

-test_xlDialogChartOptionDataLabels (xlDialogChartOptionDataLabels)

-test_xlDialogChartOptionDataTable (xlDialogChartOptionDataTable)

-test_xlDialogChartSourceData (xlDialogChartSourceData)

-test_xlDialogChartTrend (xlDialogChartTrend)

-test_xlDialogChartType (xlDialogChartType)

-test_xlDialogChartWizard (xlDialogChartWizard)

-test_xlDialogChechboxProperties (xlDialogChechboxProperties)

-test_xlDialogClear (xlDialogClear)

-test_xlDialogColorPalette (xlDialogColorPalette)

-test_xlDialogColumnWidth (xlDialogColumnWidth)

-test_xlDialogCombination (xlDialogCombination)

-test_xlDialogConditionalFormatting (xlDialogConditionalFormatting)

-test_xlDialogConsolidate (xlDialogConsolidate)

-test_xlDialogCopyChart (xlDialogCopyChart)

-test_xlDialogCopyPicture (xlDialogCopyPicture)

-test_xlDialogCreateList (xlDialogCreateList)

-test_xlDialogCreateNames (xlDialogCreateNames)

-test_xlDialogCreatePublisher (xlDialogCreatePublisher)

-test_xlDialogCustomizeToolbar (xlDialogCustomizeToolbar)

-test_xlDialogCustomViews (xlDialogCustomViews)

-test_xlDialogDataDelete (xlDialogDataDelete)

-test_xlDialogDataLabel (xlDialogDataLabel)

-test_xlDialogDataLabelMultiple (xlDialogDataLabelMultiple)

-test_xlDialogDataSeries (xlDialogDataSeries)

-test_xlDialogDataValidation (xlDialogDataValidation)

-test_xlDialogDefineName (xlDialogDefineName)

-test_xlDialogDefineStyle (xlDialogDefineStyle)

-test_xlDialogDeleteFormat (xlDialogDeleteFormat)

-test_xlDialogDeleteName (xlDialogDeleteName)

-test_xlDialogDemote (xlDialogDemote)

-test_xlDialogDisplay (xlDialogDisplay)

-test_xlDialogEditboxProperties (xlDialogEditboxProperties)

-test_xlDialogEditColor (xlDialogEditColor)

-test_xlDialogEditDelete (xlDialogEditDelete)

-test_xlDialogEditionOptions (xlDialogEditionOptions)

-test_xlDialogEditSeries (xlDialogEditSeries)

-test_xlDialogErrorbarX (xlDialogErrorbarX)

-test_xlDialogErrorbarY (xlDialogErrorbarY)

-test_xlDialogErrorChecking (xlDialogErrorChecking)

-test_xlDialogEvaluateFormula (xlDialogEvaluateFormula)

-test_xlDialogExternalDataProperties (xlDialogExternalDataProperties)

-test_xlDialogExtract (xlDialogExtract)

-test_xlDialogFileDelete (xlDialogFileDelete)

-test_xlDialogFileSharing (xlDialogFileSharing)

-test_xlDialogFillGroup (xlDialogFillGroup)

-test_xlDialogFillWorkGroup (xlDialogFillWorkGroup)

-test_xlDialogFilter (xlDialogFilter)

-test_xlDialogFilterAdvanced (xlDialogFilterAdvanced)

-test_xlDialogFindFile (xlDialogFindFile)

-test_xlDialogFont (xlDialogFont)

-test_xlDialogFontProperties (xlDialogFontProperties)

-test_xlDialogFormatAuto (xlDialogFormatAuto)

-test_xlDialogFormatChart (xlDialogFormatChart)

-test_xlDialogFormatCharttype (xlDialogFormatCharttype)

-test_xlDialogFormatFont (xlDialogFormatFont)

-test_xlDialogFormatLegend (xlDialogFormatLegend)

-test_xlDialogFormatMain (xlDialogFormatMain)

-test_xlDialogFormatMove (xlDialogFormatMove)

-test_xlDialogFormatNumber (xlDialogFormatNumber)

-test_xlDialogFormatOverlay (xlDialogFormatOverlay)

-test_xlDialogFormatSize (xlDialogFormatSize)

-test_xlDialogFormatText (xlDialogFormatText)

-test_xlDialogFormulaFind (xlDialogFormulaFind)

-test_xlDialogFormulaGoto (xlDialogFormulaGoto)

-test_xlDialogFormulaReplace (xlDialogFormulaReplace)

-test_xlDialogFunctionWizard (xlDialogFunctionWizard)

-test_xlDialogGallery3dArea (xlDialogGallery3dArea)

-test_xlDialogGallery3dBar (xlDialogGallery3dBar)

-test_xlDialogGallery3dColumn (xlDialogGallery3dColumn)

-test_xlDialogGallery3dLine (xlDialogGallery3dLine)

-test_xlDialogGallery3dPie (xlDialogGallery3dPie)

-test_xlDialogGallery3dSurface (xlDialogGallery3dSurface)

-test_xlDialogGalleryArea (xlDialogGalleryArea)

-test_xlDialogGalleryBar (xlDialogGalleryBar)

-test_xlDialogGalleryColumn (xlDialogGalleryColumn)

-test_xlDialogGalleryCustom (xlDialogGalleryCustom)

-test_xlDialogGalleryDoughnut (xlDialogGalleryDoughnut)

-test_xlDialogGalleryLine (xlDialogGalleryLine)

-test_xlDialogGalleryPie (xlDialogGalleryPie)

-test_xlDialogGalleryRader (xlDialogGalleryRader)

-test_xlDialogGalleryScatter (xlDialogGalleryScatter)

-test_xlDialogGoalSeek (xlDialogGoalSeek)

-test_xlDialogGridlines (xlDialogGridlines)

-test_xlDialogImportTextFile (xlDialogImportTextFile)

-test_xlDialogInsert (xlDialogInsert)

-test_xlDialogInsertHyperlink (xlDialogInsertHyperlink)

-test_xlDialogInsertNameLabel (xlDialogInsertNameLabel)

-test_xlDialogInsertObject (xlDialogInsertObject)

-test_xlDialogInsertPicture (xlDialogInsertPicture)

-test_xlDialogInsertTitle (xlDialogInsertTitle)

-test_xlDialogLabelProperties (xlDialogLabelProperties)

-test_xlDialogListboxProperties (xlDialogListboxProperties)

-test_xlDialogMacroOptions (xlDialogMacroOptions)

-test_xlDialogMailEditMailer (xlDialogMailEditMailer)

-test_xlDialogMailLogon (xlDialogMailLogon)

-test_xlDialogMailNextLetter (xlDialogMailNextLetter)

-test_xlDialogMainChart (xlDialogMainChart)

-test_xlDialogMainChartType (xlDialogMainChartType)

-test_xlDialogMenuEditor (xlDialogMenuEditor)

-test_xlDialogMove (xlDialogMove)

-test_xlDialogMyPermission (xlDialogMyPermission)

-test_xlDialogNew (xlDialogNew)

-test_xlDialogNewWebQuery (xlDialogNewWebQuery)

-test_xlDialogNote (xlDialogNote)

-test_xlDialogObjectProperties (xlDialogObjectProperties)

-test_xlDialogObjectProtection (xlDialogObjectProtection)

-test_xlDialogOpen (xlDialogOpen)

-test_xlDialogOpenLinks (xlDialogOpenLinks)

-test_xlDialogOpenMail (xlDialogOpenMail)

-test_xlDialogOpenText (xlDialogOpenText)

-test_xlDialogOptionsCalculation (xlDialogOptionsCalculation)

-test_xlDialogOptionsChart (xlDialogOptionsChart)

-test_xlDialogOptionsEdit (xlDialogOptionsEdit)

-test_xlDialogOptionsGeneral (xlDialogOptionsGeneral)

-test_xlDialogOptionsListAdd (xlDialogOptionsListAdd)

-test_xlDialogOptionsME (xlDialogOptionsME)

-test_xlDialogOptionsTransition (xlDialogOptionsTransition)

-test_xlDialogOptionsView (xlDialogOptionsView)

-test_xlDialogOutline (xlDialogOutline)

-test_xlDialogOverlay (xlDialogOverlay)

-test_xlDialogOverlayChartType (xlDialogOverlayChartType)

-test_xlDialogPageSetup (xlDialogPageSetup)

-test_xlDialogParse (xlDialogParse)

-test_xlDialogPasteNames (xlDialogPasteNames)

-test_xlDialogPasteSpecial (xlDialogPasteSpecial)

-test_xlDialogPatterns (xlDialogPatterns)

-test_xlDialogPermission (xlDialogPermission)

-test_xlDialogPhonetic (xlDialogPhonetic)

-test_xlDialogPivotCalculatedField (xlDialogPivotCalculatedField)

-test_xlDialogPivotCalculatedItem (xlDialogPivotCalculatedItem)

-test_xlDialogPivotClientServerSet (xlDialogPivotClientServerSet)

-test_xlDialogPivotFieldGroup (xlDialogPivotFieldGroup)

-test_xlDialogPivotFieldProperties (xlDialogPivotFieldProperties)

-test_xlDialogPivotFieldUngroup (xlDialogPivotFieldUngroup)

-test_xlDialogPivotShowPages (xlDialogPivotShowPages)

-test_xlDialogPivotSolveOrder (xlDialogPivotSolveOrder)

-test_xlDialogPivotTableOptions (xlDialogPivotTableOptions)

-test_xlDialogPivotTableWizard (xlDialogPivotTableWizard)

-test_xlDialogPlacement (xlDialogPlacement)

-test_xlDialogPrint (xlDialogPrint)

-test_xlDialogPrintSetup (xlDialogPrintSetup)

-test_xlDialogPrintPreview (xlDialogPrintPreview)

-test_xlDialogPromote (xlDialogPromote)

-test_xlDialogProperties (xlDialogProperties)

-test_xlDialogPropertyFields (xlDialogPropertyFields)

-test_xlDialogProtectDocument (xlDialogProtectDocument)

-test_xlDialogProtectSharing (xlDialogProtectSharing)

-test_xlDialogPublishAsWebPage (xlDialogPublishAsWebPage)

-test_xlDialogPushbuttonProperties (xlDialogPushbuttonProperties)

-test_xlDialogReplaceFont (xlDialogReplaceFont)

-test_xlDialogRoutingSlip (xlDialogRoutingSlip)

-test_xlDialogRowHeight (xlDialogRowHeight)

-test_xlDialogRun (xlDialogRun)

-test_xlDialogSaveAs (xlDialogSaveAs)

-test_xlDialogSaveCopyAs (xlDialogSaveCopyAs)

-test_xlDialogSaveNewObject (xlDialogSaveNewObject)

-test_xlDialogSaveWorkbook (xlDialogSaveWorkbook)

-test_xlDialogSaveWorkspace (xlDialogSaveWorkspace)

-test_xlDialogScale (xlDialogScale)

-test_xlDialogScenarioAdd (xlDialogScenarioAdd)

-test_xlDialogScenarioCells (xlDialogScenarioCells)

-test_xlDialogScenarioEdit (xlDialogScenarioEdit)

-test_xlDialogScenarioMerge (xlDialogScenarioMerge)

-test_xlDialogScenarioSummary (xlDialogScenarioSummary)

-test_xlDialogScrollbarProperties (xlDialogScrollbarProperties)

-test_xlDialogSearch (xlDialogSearch)

-test_xlDialogSelectSpecial (xlDialogSelectSpecial)

-test_xlDialogSendMail (xlDialogSendMail)

-test_xlDialogSeriesAxes (xlDialogSeriesAxes)

-test_xlDialogSeriesOptions (xlDialogSeriesOptions)

-test_xlDialogSeriesOrder (xlDialogSeriesOrder)

-test_xlDialogSeriesShape (xlDialogSeriesShape)

-test_xlDialogSeriesX (xlDialogSeriesX)

-test_xlDialogSeriesY (xlDialogSeriesY)

-test_xlDialogSetBackgroundPicture (xlDialogSetBackgroundPicture)

-test_xlDialogSetPrintTitles (xlDialogSetPrintTitles)

-test_xlDialogSetUpdateStatus (xlDialogSetUpdateStatus)

-test_xlDialogShowDetail (xlDialogShowDetail)

-test_xlDialogShowToolbar (xlDialogShowToolbar)

-test_xlDialogSize (xlDialogSize)

-test_xlDialogSort (xlDialogSort)

-test_xlDialogSortSpecial (xlDialogSortSpecial)

-test_xlDialogSplit (xlDialogSplit)

-test_xlDialogStandardFont (xlDialogStandardFont)

-test_xlDialogStandardWidth (xlDialogStandardWidth)

-test_xlDialogStyle (xlDialogStyle)

-test_xlDialogSubscribeTo (xlDialogSubscribeTo)

-test_xlDialogSubtotalCreate (xlDialogSubtotalCreate)

-test_xlDialogSummaryInfo (xlDialogSummaryInfo)

-test_xlDialogTable (xlDialogTable)

-test_xlDialogTabOrder (xlDialogTabOrder)

-test_xlDialogTextToColumns (xlDialogTextToColumns)

-test_xlDialogUnhide (xlDialogUnhide)

-test_xlDialogUpdateLink (xlDialogUpdateLink)

-test_xlDialogVbaInsertFile (xlDialogVbaInsertFile)

-test_xlDialogVbaMakeAddin (xlDialogVbaMakeAddin)

-test_xlDialogVbaProcedureDefinition (xlDialogVbaProcedureDefinition)

-test_xlDialogView3d (xlDialogView3d)

-test_xlDialogWebOptionsBrowsers (xlDialogWebOptionsBrowsers)

-test_xlDialogWebOptionsEncoding (xlDialogWebOptionsEncoding)

-test_xlDialogWebOptionsFiles (xlDialogWebOptionsFiles)

-test_xlDialogWebOptionsFonts (xlDialogWebOptionsFonts)

-test_xlDialogWebOptionsGeneral (xlDialogWebOptionsGeneral)

-test_xlDialogWebOptionsPictures (xlDialogWebOptionsPictures)

-test_xlDialogWindowMove (xlDialogWindowMove)

-test_xlDialogWindowSize (xlDialogWindowSize)

-test_xlDialogWorkbookAdd (xlDialogWorkbookAdd)

-test_xlDialogWorkbookCopy (xlDialogWorkbookCopy)

-test_xlDialogWorkbookInsert (xlDialogWorkbookInsert)

-test_xlDialogWorkbookMove (xlDialogWorkbookMove)

-test_xlDialogWorkbookName (xlDialogWorkbookName)

-test_xlDialogWorkbookNew (xlDialogWorkbookNew)

-test_xlDialogWorkbookOptions (xlDialogWorkbookOptions)

-test_xlDialogWorkbookProtect (xlDialogWorkbookProtect)

-test_xlDialogWorkbookTabSplit (xlDialogWorkbookTabSplit)

-test_xlDialogWorkbookUnhide (xlDialogWorkbookUnhide)

-test_xlDialogWorkgroup (xlDialogWorkgroup)

-test_xlDialogWorkspace (xlDialogWorkspace)

-test_xlDialogZoom (xlDialogZoom)

-Range("A1").Value = "constant name"

-Range("B1").Value = "OOo result"

-Range("C1").Value = "Excel result"

-Range("D1").Value = "Correct?"

-End Sub

-

-Function test_xlDialogActivate(ByRef num)

-Range("A2").Clear

-Range("B2").Clear

-Range("C2").Clear

-Range("D2").Clear

-Range("A2").Value = "xlDialogActivate"

-Range("B2").Value = 103

-Range("C2").Value = num

-B2 = Range("B2").Value

-C2 = Range("C2").Value

-If B2 = C2 Then

-Range("D2").Value = "OK"

-Else

-Range("D2").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogActiveCellFont(ByRef num)

-Range("A3").Clear

-Range("B3").Clear

-Range("C3").Clear

-Range("D3").Clear

-Range("A3").Value = "xlDialogActiveCellFont"

-Range("B3").Value = 476

-Range("C3").Value = num

-B3 = Range("B3").Value

-C3 = Range("C3").Value

-If B3 = C3 Then

-Range("D3").Value = "OK"

-Else

-Range("D3").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogAddChartAutoformat(ByRef num)

-Range("A4").Clear

-Range("B4").Clear

-Range("C4").Clear

-Range("D4").Clear

-Range("A4").Value = "xlDialogAddChartAutoformat"

-Range("B4").Value = 390

-Range("C4").Value = num

-B4 = Range("B4").Value

-C4 = Range("C4").Value

-If B4 = C4 Then

-Range("D4").Value = "OK"

-Else

-Range("D4").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogAddinManager(ByRef num)

-Range("A5").Clear

-Range("B5").Clear

-Range("C5").Clear

-Range("D5").Clear

-Range("A5").Value = "xlDialogAddinManager"

-Range("B5").Value = 321

-Range("C5").Value = num

-B5 = Range("B5").Value

-C5 = Range("C5").Value

-If B5 = C5 Then

-Range("D5").Value = "OK"

-Else

-Range("D5").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogAlignment(ByRef num)

-Range("A6").Clear

-Range("B6").Clear

-Range("C6").Clear

-Range("D6").Clear

-Range("A6").Value = "xlDialogAlignment"

-Range("B6").Value = 43

-Range("C6").Value = num

-B6 = Range("B6").Value

-C6 = Range("C6").Value

-If B6 = C6 Then

-Range("D6").Value = "OK"

-Else

-Range("D6").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogApplyNames(ByRef num)

-Range("A7").Clear

-Range("B7").Clear

-Range("C7").Clear

-Range("D7").Clear

-Range("A7").Value = "xlDialogApplyNames"

-Range("B7").Value = 133

-Range("C7").Value = num

-B7 = Range("B7").Value

-C7 = Range("C7").Value

-If B7 = C7 Then

-Range("D7").Value = "OK"

-Else

-Range("D7").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogApplyStyle(ByRef num)

-Range("A8").Clear

-Range("B8").Clear

-Range("C8").Clear

-Range("D8").Clear

-Range("A8").Value = "xlDialogApplyStyle"

-Range("B8").Value = 212

-Range("C8").Value = num

-B8 = Range("B8").Value

-C8 = Range("C8").Value

-If B8 = C8 Then

-Range("D8").Value = "OK"

-Else

-Range("D8").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogAppMove(ByRef num)

-Range("A9").Clear

-Range("B9").Clear

-Range("C9").Clear

-Range("D9").Clear

-Range("A9").Value = "xlDialogAppMove"

-Range("B9").Value = 170

-Range("C9").Value = num

-B9 = Range("B9").Value

-C9 = Range("C9").Value

-If B9 = C9 Then

-Range("D9").Value = "OK"

-Else

-Range("D9").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogAppSize(ByRef num)

-Range("A10").Clear

-Range("B10").Clear

-Range("C10").Clear

-Range("D10").Clear

-Range("A10").Value = "xlDialogAppSize"

-Range("B10").Value = 171

-Range("C10").Value = num

-B10 = Range("B10").Value

-C10 = Range("C10").Value

-If B10 = C10 Then

-Range("D10").Value = "OK"

-Else

-Range("D10").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogArrangeAll(ByRef num)

-Range("A11").Clear

-Range("B11").Clear

-Range("C11").Clear

-Range("D11").Clear

-Range("A11").Value = "xlDialogArrangeAll"

-Range("B11").Value = 12

-Range("C11").Value = num

-B11 = Range("B11").Value

-C11 = Range("C11").Value

-If B11 = C11 Then

-Range("D11").Value = "OK"

-Else

-Range("D11").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogAssignToObject(ByRef num)

-Range("A12").Clear

-Range("B12").Clear

-Range("C12").Clear

-Range("D12").Clear

-Range("A12").Value = "xlDialogAssignToObject"

-Range("B12").Value = 213

-Range("C12").Value = num

-B12 = Range("B12").Value

-C12 = Range("C12").Value

-If B12 = C12 Then

-Range("D12").Value = "OK"

-Else

-Range("D12").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogAssignToTool(ByRef num)

-Range("A13").Clear

-Range("B13").Clear

-Range("C13").Clear

-Range("D13").Clear

-Range("A13").Value = "xlDialogAssignToTool"

-Range("B13").Value = 293

-Range("C13").Value = num

-B13 = Range("B13").Value

-C13 = Range("C13").Value

-If B13 = C13 Then

-Range("D13").Value = "OK"

-Else

-Range("D13").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogAttachText(ByRef num)

-Range("A14").Clear

-Range("B14").Clear

-Range("C14").Clear

-Range("D14").Clear

-Range("A14").Value = "xlDialogAttachText"

-Range("B14").Value = 80

-Range("C14").Value = num

-B14 = Range("B14").Value

-C14 = Range("C14").Value

-If B14 = C14 Then

-Range("D14").Value = "OK"

-Else

-Range("D14").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogAttachToolbars(ByRef num)

-Range("A15").Clear

-Range("B15").Clear

-Range("C15").Clear

-Range("D15").Clear

-Range("A15").Value = "xlDialogAttachToolbars"

-Range("B15").Value = 323

-Range("C15").Value = num

-B15 = Range("B15").Value

-C15 = Range("C15").Value

-If B15 = C15 Then

-Range("D15").Value = "OK"

-Else

-Range("D15").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogAutoCorrect(ByRef num)

-Range("A16").Clear

-Range("B16").Clear

-Range("C16").Clear

-Range("D16").Clear

-Range("A16").Value = "xlDialogAutoCorrect"

-Range("B16").Value = 485

-Range("C16").Value = num

-B16 = Range("B16").Value

-C16 = Range("C16").Value

-If B16 = C16 Then

-Range("D16").Value = "OK"

-Else

-Range("D16").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogAxes(ByRef num)

-Range("A17").Clear

-Range("B17").Clear

-Range("C17").Clear

-Range("D17").Clear

-Range("A17").Value = "xlDialogAxes"

-Range("B17").Value = 78

-Range("C17").Value = num

-B17 = Range("B17").Value

-C17 = Range("C17").Value

-If B17 = C17 Then

-Range("D17").Value = "OK"

-Else

-Range("D17").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogBorder(ByRef num)

-Range("A18").Clear

-Range("B18").Clear

-Range("C18").Clear

-Range("D18").Clear

-Range("A18").Value = "xlDialogBorder"

-Range("B18").Value = 45

-Range("C18").Value = num

-B18 = Range("B18").Value

-C18 = Range("C18").Value

-If B18 = C18 Then

-Range("D18").Value = "OK"

-Else

-Range("D18").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogCalculation(ByRef num)

-Range("A19").Clear

-Range("B19").Clear

-Range("C19").Clear

-Range("D19").Clear

-Range("A19").Value = "xlDialogCalculation"

-Range("B19").Value = 32

-Range("C19").Value = num

-B19 = Range("B19").Value

-C19 = Range("C19").Value

-If B19 = C19 Then

-Range("D19").Value = "OK"

-Else

-Range("D19").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogCellProtection(ByRef num)

-Range("A20").Clear

-Range("B20").Clear

-Range("C20").Clear

-Range("D20").Clear

-Range("A20").Value = "xlDialogCellProtection"

-Range("B20").Value = 46

-Range("C20").Value = num

-B20 = Range("B20").Value

-C20 = Range("C20").Value

-If B20 = C20 Then

-Range("D20").Value = "OK"

-Else

-Range("D20").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogChangeLink(ByRef num)

-Range("A21").Clear

-Range("B21").Clear

-Range("C21").Clear

-Range("D21").Clear

-Range("A21").Value = "xlDialogChangeLink"

-Range("B21").Value = 166

-Range("C21").Value = num

-B21 = Range("B21").Value

-C21 = Range("C21").Value

-If B21 = C21 Then

-Range("D21").Value = "OK"

-Else

-Range("D21").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogChartAddData(ByRef num)

-Range("A22").Clear

-Range("B22").Clear

-Range("C22").Clear

-Range("D22").Clear

-Range("A22").Value = "xlDialogChartAddData"

-Range("B22").Value = 392

-Range("C22").Value = num

-B22 = Range("B22").Value

-C22 = Range("C22").Value

-If B22 = C22 Then

-Range("D22").Value = "OK"

-Else

-Range("D22").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogChartLocation(ByRef num)

-Range("A23").Clear

-Range("B23").Clear

-Range("C23").Clear

-Range("D23").Clear

-Range("A23").Value = "xlDialogChartLocation"

-Range("B23").Value = 527

-Range("C23").Value = num

-B23 = Range("B23").Value

-C23 = Range("C23").Value

-If B23 = C23 Then

-Range("D23").Value = "OK"

-Else

-Range("D23").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogChartOptionDataLabelMultiple(ByRef num)

-Range("A24").Clear

-Range("B24").Clear

-Range("C24").Clear

-Range("D24").Clear

-Range("A24").Value = "xlDialogChartOptionDataLabelMultiple"

-Range("B24").Value = 724

-Range("C24").Value = num

-B24 = Range("B24").Value

-C24 = Range("C24").Value

-If B24 = C24 Then

-Range("D24").Value = "OK"

-Else

-Range("D24").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogChartOptionDataLabels(ByRef num)

-Range("A25").Clear

-Range("B25").Clear

-Range("C25").Clear

-Range("D25").Clear

-Range("A25").Value = "xlDialogChartOptionDataLabels"

-Range("B25").Value = 505

-Range("C25").Value = num

-B25 = Range("B25").Value

-C25 = Range("C25").Value

-If B25 = C25 Then

-Range("D25").Value = "OK"

-Else

-Range("D25").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogChartOptionDataTable(ByRef num)

-Range("A26").Clear

-Range("B26").Clear

-Range("C26").Clear

-Range("D26").Clear

-Range("A26").Value = "xlDialogChartOptionDataTable"

-Range("B26").Value = 506

-Range("C26").Value = num

-B26 = Range("B26").Value

-C26 = Range("C26").Value

-If B26 = C26 Then

-Range("D26").Value = "OK"

-Else

-Range("D26").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogChartSourceData(ByRef num)

-Range("A27").Clear

-Range("B27").Clear

-Range("C27").Clear

-Range("D27").Clear

-Range("A27").Value = "xlDialogChartSourceData"

-Range("B27").Value = 540

-Range("C27").Value = num

-B27 = Range("B27").Value

-C27 = Range("C27").Value

-If B27 = C27 Then

-Range("D27").Value = "OK"

-Else

-Range("D27").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogChartTrend(ByRef num)

-Range("A28").Clear

-Range("B28").Clear

-Range("C28").Clear

-Range("D28").Clear

-Range("A28").Value = "xlDialogChartTrend"

-Range("B28").Value = 350

-Range("C28").Value = num

-B28 = Range("B28").Value

-C28 = Range("C28").Value

-If B28 = C28 Then

-Range("D28").Value = "OK"

-Else

-Range("D28").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogChartType(ByRef num)

-Range("A29").Clear

-Range("B29").Clear

-Range("C29").Clear

-Range("D29").Clear

-Range("A29").Value = "xlDialogChartType"

-Range("B29").Value = 526

-Range("C29").Value = num

-B29 = Range("B29").Value

-C29 = Range("C29").Value

-If B29 = C29 Then

-Range("D29").Value = "OK"

-Else

-Range("D29").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogChartWizard(ByRef num)

-Range("A30").Clear

-Range("B30").Clear

-Range("C30").Clear

-Range("D30").Clear

-Range("A30").Value = "xlDialogChartWizard"

-Range("B30").Value = 288

-Range("C30").Value = num

-B30 = Range("B30").Value

-C30 = Range("C30").Value

-If B30 = C30 Then

-Range("D30").Value = "OK"

-Else

-Range("D30").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogChechboxProperties(ByRef num)

-Range("A31").Clear

-Range("B31").Clear

-Range("C31").Clear

-Range("D31").Clear

-Range("A31").Value = "xlDialogChechboxProperties"

-Range("B31").Value = 435

-Range("C31").Value = num

-B31 = Range("B31").Value

-C31 = Range("C31").Value

-If B31 = C31 Then

-Range("D31").Value = "OK"

-Else

-Range("D31").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogClear(ByRef num)

-Range("A32").Clear

-Range("B32").Clear

-Range("C32").Clear

-Range("D32").Clear

-Range("A32").Value = "xlDialogClear"

-Range("B32").Value = 52

-Range("C32").Value = num

-B32 = Range("B32").Value

-C32 = Range("C32").Value

-If B32 = C32 Then

-Range("D32").Value = "OK"

-Else

-Range("D32").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogColorPalette(ByRef num)

-Range("A33").Clear

-Range("B33").Clear

-Range("C33").Clear

-Range("D33").Clear

-Range("A33").Value = "xlDialogColorPalette"

-Range("B33").Value = 161

-Range("C33").Value = num

-B33 = Range("B33").Value

-C33 = Range("C33").Value

-If B33 = C33 Then

-Range("D33").Value = "OK"

-Else

-Range("D33").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogColumnWidth(ByRef num)

-Range("A34").Clear

-Range("B34").Clear

-Range("C34").Clear

-Range("D34").Clear

-Range("A34").Value = "xlDialogColumnWidth"

-Range("B34").Value = 47

-Range("C34").Value = num

-B34 = Range("B34").Value

-C34 = Range("C34").Value

-If B34 = C34 Then

-Range("D34").Value = "OK"

-Else

-Range("D34").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogCombination(ByRef num)

-Range("A35").Clear

-Range("B35").Clear

-Range("C35").Clear

-Range("D35").Clear

-Range("A35").Value = "xlDialogCombination"

-Range("B35").Value = 73

-Range("C35").Value = num

-B35 = Range("B35").Value

-C35 = Range("C35").Value

-If B35 = C35 Then

-Range("D35").Value = "OK"

-Else

-Range("D35").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogConditionalFormatting(ByRef num)

-Range("A36").Clear

-Range("B36").Clear

-Range("C36").Clear

-Range("D36").Clear

-Range("A36").Value = "xlDialogConditionalFormatting"

-Range("B36").Value = 583

-Range("C36").Value = num

-B36 = Range("B36").Value

-C36 = Range("C36").Value

-If B36 = C36 Then

-Range("D36").Value = "OK"

-Else

-Range("D36").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogConsolidate(ByRef num)

-Range("A37").Clear

-Range("B37").Clear

-Range("C37").Clear

-Range("D37").Clear

-Range("A37").Value = "xlDialogConsolidate"

-Range("B37").Value = 191

-Range("C37").Value = num

-B37 = Range("B37").Value

-C37 = Range("C37").Value

-If B37 = C37 Then

-Range("D37").Value = "OK"

-Else

-Range("D37").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogCopyChart(ByRef num)

-Range("A38").Clear

-Range("B38").Clear

-Range("C38").Clear

-Range("D38").Clear

-Range("A38").Value = "xlDialogCopyChart"

-Range("B38").Value = 147

-Range("C38").Value = num

-B38 = Range("B38").Value

-C38 = Range("C38").Value

-If B38 = C38 Then

-Range("D38").Value = "OK"

-Else

-Range("D38").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogCopyPicture(ByRef num)

-Range("A39").Clear

-Range("B39").Clear

-Range("C39").Clear

-Range("D39").Clear

-Range("A39").Value = "xlDialogCopyPicture"

-Range("B39").Value = 108

-Range("C39").Value = num

-B39 = Range("B39").Value

-C39 = Range("C39").Value

-If B39 = C39 Then

-Range("D39").Value = "OK"

-Else

-Range("D39").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogCreateList(ByRef num)

-Range("A40").Clear

-Range("B40").Clear

-Range("C40").Clear

-Range("D40").Clear

-Range("A40").Value = "xlDialogCreateList"

-Range("B40").Value = 769

-Range("C40").Value = num

-B40 = Range("B40").Value

-C40 = Range("C40").Value

-If B40 = C40 Then

-Range("D40").Value = "OK"

-Else

-Range("D40").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogCreateNames(ByRef num)

-Range("A41").Clear

-Range("B41").Clear

-Range("C41").Clear

-Range("D41").Clear

-Range("A41").Value = "xlDialogCreateNames"

-Range("B41").Value = 62

-Range("C41").Value = num

-B41 = Range("B41").Value

-C41 = Range("C41").Value

-If B41 = C41 Then

-Range("D41").Value = "OK"

-Else

-Range("D41").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogCreatePublisher(ByRef num)

-Range("A42").Clear

-Range("B42").Clear

-Range("C42").Clear

-Range("D42").Clear

-Range("A42").Value = "xlDialogCreatePublisher"

-Range("B42").Value = 217

-Range("C42").Value = num

-B42 = Range("B42").Value

-C42 = Range("C42").Value

-If B42 = C42 Then

-Range("D42").Value = "OK"

-Else

-Range("D42").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogCustomizeToolbar(ByRef num)

-Range("A43").Clear

-Range("B43").Clear

-Range("C43").Clear

-Range("D43").Clear

-Range("A43").Value = "xlDialogCustomizeToolbar"

-Range("B43").Value = 276

-Range("C43").Value = num

-B43 = Range("B43").Value

-C43 = Range("C43").Value

-If B43 = C43 Then

-Range("D43").Value = "OK"

-Else

-Range("D43").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogCustomViews(ByRef num)

-Range("A44").Clear

-Range("B44").Clear

-Range("C44").Clear

-Range("D44").Clear

-Range("A44").Value = "xlDialogCustomViews"

-Range("B44").Value = 493

-Range("C44").Value = num

-B44 = Range("B44").Value

-C44 = Range("C44").Value

-If B44 = C44 Then

-Range("D44").Value = "OK"

-Else

-Range("D44").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogDataDelete(ByRef num)

-Range("A45").Clear

-Range("B45").Clear

-Range("C45").Clear

-Range("D45").Clear

-Range("A45").Value = "xlDialogDataDelete"

-Range("B45").Value = 36

-Range("C45").Value = num

-B45 = Range("B45").Value

-C45 = Range("C45").Value

-If B45 = C45 Then

-Range("D45").Value = "OK"

-Else

-Range("D45").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogDataLabel(ByRef num)

-Range("A46").Clear

-Range("B46").Clear

-Range("C46").Clear

-Range("D46").Clear

-Range("A46").Value = "xlDialogDataLabel"

-Range("B46").Value = 379

-Range("C46").Value = num

-B46 = Range("B46").Value

-C46 = Range("C46").Value

-If B46 = C46 Then

-Range("D46").Value = "OK"

-Else

-Range("D46").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogDataLabelMultiple(ByRef num)

-Range("A47").Clear

-Range("B47").Clear

-Range("C47").Clear

-Range("D47").Clear

-Range("A47").Value = "xlDialogDataLabelMultiple"

-Range("B47").Value = 723

-Range("C47").Value = num

-B47 = Range("B47").Value

-C47 = Range("C47").Value

-If B47 = C47 Then

-Range("D47").Value = "OK"

-Else

-Range("D47").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogDataSeries(ByRef num)

-Range("A48").Clear

-Range("B48").Clear

-Range("C48").Clear

-Range("D48").Clear

-Range("A48").Value = "xlDialogDataSeries"

-Range("B48").Value = 40

-Range("C48").Value = num

-B48 = Range("B48").Value

-C48 = Range("C48").Value

-If B48 = C48 Then

-Range("D48").Value = "OK"

-Else

-Range("D48").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogDataValidation(ByRef num)

-Range("A49").Clear

-Range("B49").Clear

-Range("C49").Clear

-Range("D49").Clear

-Range("A49").Value = "xlDialogDataValidation"

-Range("B49").Value = 525

-Range("C49").Value = num

-B49 = Range("B49").Value

-C49 = Range("C49").Value

-If B49 = C49 Then

-Range("D49").Value = "OK"

-Else

-Range("D49").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogDefineName(ByRef num)

-Range("A50").Clear

-Range("B50").Clear

-Range("C50").Clear

-Range("D50").Clear

-Range("A50").Value = "xlDialogDefineName"

-Range("B50").Value = 61

-Range("C50").Value = num

-B50 = Range("B50").Value

-C50 = Range("C50").Value

-If B50 = C50 Then

-Range("D50").Value = "OK"

-Else

-Range("D50").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogDefineStyle(ByRef num)

-Range("A51").Clear

-Range("B51").Clear

-Range("C51").Clear

-Range("D51").Clear

-Range("A51").Value = "xlDialogDefineStyle"

-Range("B51").Value = 229

-Range("C51").Value = num

-B51 = Range("B51").Value

-C51 = Range("C51").Value

-If B51 = C51 Then

-Range("D51").Value = "OK"

-Else

-Range("D51").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogDeleteFormat(ByRef num)

-Range("A52").Clear

-Range("B52").Clear

-Range("C52").Clear

-Range("D52").Clear

-Range("A52").Value = "xlDialogDeleteFormat"

-Range("B52").Value = 111

-Range("C52").Value = num

-B52 = Range("B52").Value

-C52 = Range("C52").Value

-If B52 = C52 Then

-Range("D52").Value = "OK"

-Else

-Range("D52").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogDeleteName(ByRef num)

-Range("A53").Clear

-Range("B53").Clear

-Range("C53").Clear

-Range("D53").Clear

-Range("A53").Value = "xlDialogDeleteName"

-Range("B53").Value = 110

-Range("C53").Value = num

-B53 = Range("B53").Value

-C53 = Range("C53").Value

-If B53 = C53 Then

-Range("D53").Value = "OK"

-Else

-Range("D53").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogDemote(ByRef num)

-Range("A54").Clear

-Range("B54").Clear

-Range("C54").Clear

-Range("D54").Clear

-Range("A54").Value = "xlDialogDemote"

-Range("B54").Value = 203

-Range("C54").Value = num

-B54 = Range("B54").Value

-C54 = Range("C54").Value

-If B54 = C54 Then

-Range("D54").Value = "OK"

-Else

-Range("D54").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogDisplay(ByRef num)

-Range("A55").Clear

-Range("B55").Clear

-Range("C55").Clear

-Range("D55").Clear

-Range("A55").Value = "xlDialogDisplay"

-Range("B55").Value = 27

-Range("C55").Value = num

-B55 = Range("B55").Value

-C55 = Range("C55").Value

-If B55 = C55 Then

-Range("D55").Value = "OK"

-Else

-Range("D55").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogEditboxProperties(ByRef num)

-Range("A56").Clear

-Range("B56").Clear

-Range("C56").Clear

-Range("D56").Clear

-Range("A56").Value = "xlDialogEditboxProperties"

-Range("B56").Value = 438

-Range("C56").Value = num

-B56 = Range("B56").Value

-C56 = Range("C56").Value

-If B56 = C56 Then

-Range("D56").Value = "OK"

-Else

-Range("D56").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogEditColor(ByRef num)

-Range("A57").Clear

-Range("B57").Clear

-Range("C57").Clear

-Range("D57").Clear

-Range("A57").Value = "xlDialogEditColor"

-Range("B57").Value = 223

-Range("C57").Value = num

-B57 = Range("B57").Value

-C57 = Range("C57").Value

-If B57 = C57 Then

-Range("D57").Value = "OK"

-Else

-Range("D57").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogEditDelete(ByRef num)

-Range("A58").Clear

-Range("B58").Clear

-Range("C58").Clear

-Range("D58").Clear

-Range("A58").Value = "xlDialogEditDelete"

-Range("B58").Value = 54

-Range("C58").Value = num

-B58 = Range("B58").Value

-C58 = Range("C58").Value

-If B58 = C58 Then

-Range("D58").Value = "OK"

-Else

-Range("D58").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogEditionOptions(ByRef num)

-Range("A59").Clear

-Range("B59").Clear

-Range("C59").Clear

-Range("D59").Clear

-Range("A59").Value = "xlDialogEditionOptions"

-Range("B59").Value = 251

-Range("C59").Value = num

-B59 = Range("B59").Value

-C59 = Range("C59").Value

-If B59 = C59 Then

-Range("D59").Value = "OK"

-Else

-Range("D59").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogEditSeries(ByRef num)

-Range("A60").Clear

-Range("B60").Clear

-Range("C60").Clear

-Range("D60").Clear

-Range("A60").Value = "xlDialogEditSeries"

-Range("B60").Value = 228

-Range("C60").Value = num

-B60 = Range("B60").Value

-C60 = Range("C60").Value

-If B60 = C60 Then

-Range("D60").Value = "OK"

-Else

-Range("D60").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogErrorbarX(ByRef num)

-Range("A61").Clear

-Range("B61").Clear

-Range("C61").Clear

-Range("D61").Clear

-Range("A61").Value = "xlDialogErrorbarX"

-Range("B61").Value = 463

-Range("C61").Value = num

-B61 = Range("B61").Value

-C61 = Range("C61").Value

-If B61 = C61 Then

-Range("D61").Value = "OK"

-Else

-Range("D61").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogErrorbarY(ByRef num)

-Range("A62").Clear

-Range("B62").Clear

-Range("C62").Clear

-Range("D62").Clear

-Range("A62").Value = "xlDialogErrorbarY"

-Range("B62").Value = 464

-Range("C62").Value = num

-B62 = Range("B62").Value

-C62 = Range("C62").Value

-If B62 = C62 Then

-Range("D62").Value = "OK"

-Else

-Range("D62").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogErrorChecking(ByRef num)

-Range("A63").Clear

-Range("B63").Clear

-Range("C63").Clear

-Range("D63").Clear

-Range("A63").Value = "xlDialogErrorChecking"

-Range("B63").Value = 732

-Range("C63").Value = num

-B63 = Range("B63").Value

-C63 = Range("C63").Value

-If B63 = C63 Then

-Range("D63").Value = "OK"

-Else

-Range("D63").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogEvaluateFormula(ByRef num)

-Range("A64").Clear

-Range("B64").Clear

-Range("C64").Clear

-Range("D64").Clear

-Range("A64").Value = "xlDialogEvaluateFormula"

-Range("B64").Value = 709

-Range("C64").Value = num

-B64 = Range("B64").Value

-C64 = Range("C64").Value

-If B64 = C64 Then

-Range("D64").Value = "OK"

-Else

-Range("D64").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogExternalDataProperties(ByRef num)

-Range("A65").Clear

-Range("B65").Clear

-Range("C65").Clear

-Range("D65").Clear

-Range("A65").Value = "xlDialogExternalDataProperties"

-Range("B65").Value = 530

-Range("C65").Value = num

-B65 = Range("B65").Value

-C65 = Range("C65").Value

-If B65 = C65 Then

-Range("D65").Value = "OK"

-Else

-Range("D65").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogExtract(ByRef num)

-Range("A66").Clear

-Range("B66").Clear

-Range("C66").Clear

-Range("D66").Clear

-Range("A66").Value = "xlDialogExtract"

-Range("B66").Value = 35

-Range("C66").Value = num

-B66 = Range("B66").Value

-C66 = Range("C66").Value

-If B66 = C66 Then

-Range("D66").Value = "OK"

-Else

-Range("D66").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFileDelete(ByRef num)

-Range("A67").Clear

-Range("B67").Clear

-Range("C67").Clear

-Range("D67").Clear

-Range("A67").Value = "xlDialogFileDelete"

-Range("B67").Value = 6

-Range("C67").Value = num

-B67 = Range("B67").Value

-C67 = Range("C67").Value

-If B67 = C67 Then

-Range("D67").Value = "OK"

-Else

-Range("D67").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFileSharing(ByRef num)

-Range("A68").Clear

-Range("B68").Clear

-Range("C68").Clear

-Range("D68").Clear

-Range("A68").Value = "xlDialogFileSharing"

-Range("B68").Value = 481

-Range("C68").Value = num

-B68 = Range("B68").Value

-C68 = Range("C68").Value

-If B68 = C68 Then

-Range("D68").Value = "OK"

-Else

-Range("D68").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFillGroup(ByRef num)

-Range("A69").Clear

-Range("B69").Clear

-Range("C69").Clear

-Range("D69").Clear

-Range("A69").Value = "xlDialogFillGroup"

-Range("B69").Value = 200

-Range("C69").Value = num

-B69 = Range("B69").Value

-C69 = Range("C69").Value

-If B69 = C69 Then

-Range("D69").Value = "OK"

-Else

-Range("D69").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFillWorkGroup(ByRef num)

-Range("A70").Clear

-Range("B70").Clear

-Range("C70").Clear

-Range("D70").Clear

-Range("A70").Value = "xlDialogFillWorkGroup"

-Range("B70").Value = 301

-Range("C70").Value = num

-B70 = Range("B70").Value

-C70 = Range("C70").Value

-If B70 = C70 Then

-Range("D70").Value = "OK"

-Else

-Range("D70").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFilter(ByRef num)

-Range("A71").Clear

-Range("B71").Clear

-Range("C71").Clear

-Range("D71").Clear

-Range("A71").Value = "xlDialogFilter"

-Range("B71").Value = 447

-Range("C71").Value = num

-B71 = Range("B71").Value

-C71 = Range("C71").Value

-If B71 = C71 Then

-Range("D71").Value = "OK"

-Else

-Range("D71").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFilterAdvanced(ByRef num)

-Range("A72").Clear

-Range("B72").Clear

-Range("C72").Clear

-Range("D72").Clear

-Range("A72").Value = "xlDialogFilterAdvanced"

-Range("B72").Value = 370

-Range("C72").Value = num

-B72 = Range("B72").Value

-C72 = Range("C72").Value

-If B72 = C72 Then

-Range("D72").Value = "OK"

-Else

-Range("D72").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFindFile(ByRef num)

-Range("A73").Clear

-Range("B73").Clear

-Range("C73").Clear

-Range("D73").Clear

-Range("A73").Value = "xlDialogFindFile"

-Range("B73").Value = 475

-Range("C73").Value = num

-B73 = Range("B73").Value

-C73 = Range("C73").Value

-If B73 = C73 Then

-Range("D73").Value = "OK"

-Else

-Range("D73").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFont(ByRef num)

-Range("A74").Clear

-Range("B74").Clear

-Range("C74").Clear

-Range("D74").Clear

-Range("A74").Value = "xlDialogFont"

-Range("B74").Value = 26

-Range("C74").Value = num

-B74 = Range("B74").Value

-C74 = Range("C74").Value

-If B74 = C74 Then

-Range("D74").Value = "OK"

-Else

-Range("D74").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFontProperties(ByRef num)

-Range("A75").Clear

-Range("B75").Clear

-Range("C75").Clear

-Range("D75").Clear

-Range("A75").Value = "xlDialogFontProperties"

-Range("B75").Value = 381

-Range("C75").Value = num

-B75 = Range("B75").Value

-C75 = Range("C75").Value

-If B75 = C75 Then

-Range("D75").Value = "OK"

-Else

-Range("D75").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFormatAuto(ByRef num)

-Range("A76").Clear

-Range("B76").Clear

-Range("C76").Clear

-Range("D76").Clear

-Range("A76").Value = "xlDialogFormatAuto"

-Range("B76").Value = 269

-Range("C76").Value = num

-B76 = Range("B76").Value

-C76 = Range("C76").Value

-If B76 = C76 Then

-Range("D76").Value = "OK"

-Else

-Range("D76").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFormatChart(ByRef num)

-Range("A77").Clear

-Range("B77").Clear

-Range("C77").Clear

-Range("D77").Clear

-Range("A77").Value = "xlDialogFormatChart"

-Range("B77").Value = 465

-Range("C77").Value = num

-B77 = Range("B77").Value

-C77 = Range("C77").Value

-If B77 = C77 Then

-Range("D77").Value = "OK"

-Else

-Range("D77").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFormatCharttype(ByRef num)

-Range("A78").Clear

-Range("B78").Clear

-Range("C78").Clear

-Range("D78").Clear

-Range("A78").Value = "xlDialogFormatCharttype"

-Range("B78").Value = 423

-Range("C78").Value = num

-B78 = Range("B78").Value

-C78 = Range("C78").Value

-If B78 = C78 Then

-Range("D78").Value = "OK"

-Else

-Range("D78").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFormatFont(ByRef num)

-Range("A79").Clear

-Range("B79").Clear

-Range("C79").Clear

-Range("D79").Clear

-Range("A79").Value = "xlDialogFormatFont"

-Range("B79").Value = 150

-Range("C79").Value = num

-B79 = Range("B79").Value

-C79 = Range("C79").Value

-If B79 = C79 Then

-Range("D79").Value = "OK"

-Else

-Range("D79").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFormatLegend(ByRef num)

-Range("A80").Clear

-Range("B80").Clear

-Range("C80").Clear

-Range("D80").Clear

-Range("A80").Value = "xlDialogFormatLegend"

-Range("B80").Value = 88

-Range("C80").Value = num

-B80 = Range("B80").Value

-C80 = Range("C80").Value

-If B80 = C80 Then

-Range("D80").Value = "OK"

-Else

-Range("D80").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFormatMain(ByRef num)

-Range("A81").Clear

-Range("B81").Clear

-Range("C81").Clear

-Range("D81").Clear

-Range("A81").Value = "xlDialogFormatMain"

-Range("B81").Value = 225

-Range("C81").Value = num

-B81 = Range("B81").Value

-C81 = Range("C81").Value

-If B81 = C81 Then

-Range("D81").Value = "OK"

-Else

-Range("D81").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFormatMove(ByRef num)

-Range("A82").Clear

-Range("B82").Clear

-Range("C82").Clear

-Range("D82").Clear

-Range("A82").Value = "xlDialogFormatMove"

-Range("B82").Value = 128

-Range("C82").Value = num

-B82 = Range("B82").Value

-C82 = Range("C82").Value

-If B82 = C82 Then

-Range("D82").Value = "OK"

-Else

-Range("D82").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFormatNumber(ByRef num)

-Range("A83").Clear

-Range("B83").Clear

-Range("C83").Clear

-Range("D83").Clear

-Range("A83").Value = "xlDialogFormatNumber"

-Range("B83").Value = 42

-Range("C83").Value = num

-B83 = Range("B83").Value

-C83 = Range("C83").Value

-If B83 = C83 Then

-Range("D83").Value = "OK"

-Else

-Range("D83").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFormatOverlay(ByRef num)

-Range("A84").Clear

-Range("B84").Clear

-Range("C84").Clear

-Range("D84").Clear

-Range("A84").Value = "xlDialogFormatOverlay"

-Range("B84").Value = 226

-Range("C84").Value = num

-B84 = Range("B84").Value

-C84 = Range("C84").Value

-If B84 = C84 Then

-Range("D84").Value = "OK"

-Else

-Range("D84").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFormatSize(ByRef num)

-Range("A85").Clear

-Range("B85").Clear

-Range("C85").Clear

-Range("D85").Clear

-Range("A85").Value = "xlDialogFormatSize"

-Range("B85").Value = 129

-Range("C85").Value = num

-B85 = Range("B85").Value

-C85 = Range("C85").Value

-If B85 = C85 Then

-Range("D85").Value = "OK"

-Else

-Range("D85").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFormatText(ByRef num)

-Range("A86").Clear

-Range("B86").Clear

-Range("C86").Clear

-Range("D86").Clear

-Range("A86").Value = "xlDialogFormatText"

-Range("B86").Value = 89

-Range("C86").Value = num

-B86 = Range("B86").Value

-C86 = Range("C86").Value

-If B86 = C86 Then

-Range("D86").Value = "OK"

-Else

-Range("D86").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFormulaFind(ByRef num)

-Range("A87").Clear

-Range("B87").Clear

-Range("C87").Clear

-Range("D87").Clear

-Range("A87").Value = "xlDialogFormulaFind"

-Range("B87").Value = 64

-Range("C87").Value = num

-B87 = Range("B87").Value

-C87 = Range("C87").Value

-If B87 = C87 Then

-Range("D87").Value = "OK"

-Else

-Range("D87").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFormulaGoto(ByRef num)

-Range("A88").Clear

-Range("B88").Clear

-Range("C88").Clear

-Range("D88").Clear

-Range("A88").Value = "xlDialogFormulaGoto"

-Range("B88").Value = 63

-Range("C88").Value = num

-B88 = Range("B88").Value

-C88 = Range("C88").Value

-If B88 = C88 Then

-Range("D88").Value = "OK"

-Else

-Range("D88").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFormulaReplace(ByRef num)

-Range("A89").Clear

-Range("B89").Clear

-Range("C89").Clear

-Range("D89").Clear

-Range("A89").Value = "xlDialogFormulaReplace"

-Range("B89").Value = 130

-Range("C89").Value = num

-B89 = Range("B89").Value

-C89 = Range("C89").Value

-If B89 = C89 Then

-Range("D89").Value = "OK"

-Else

-Range("D89").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogFunctionWizard(ByRef num)

-Range("A90").Clear

-Range("B90").Clear

-Range("C90").Clear

-Range("D90").Clear

-Range("A90").Value = "xlDialogFunctionWizard"

-Range("B90").Value = 450

-Range("C90").Value = num

-B90 = Range("B90").Value

-C90 = Range("C90").Value

-If B90 = C90 Then

-Range("D90").Value = "OK"

-Else

-Range("D90").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGallery3dArea(ByRef num)

-Range("A91").Clear

-Range("B91").Clear

-Range("C91").Clear

-Range("D91").Clear

-Range("A91").Value = "xlDialogGallery3dArea"

-Range("B91").Value = 193

-Range("C91").Value = num

-B91 = Range("B91").Value

-C91 = Range("C91").Value

-If B91 = C91 Then

-Range("D91").Value = "OK"

-Else

-Range("D91").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGallery3dBar(ByRef num)

-Range("A92").Clear

-Range("B92").Clear

-Range("C92").Clear

-Range("D92").Clear

-Range("A92").Value = "xlDialogGallery3dBar"

-Range("B92").Value = 272

-Range("C92").Value = num

-B92 = Range("B92").Value

-C92 = Range("C92").Value

-If B92 = C92 Then

-Range("D92").Value = "OK"

-Else

-Range("D92").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGallery3dColumn(ByRef num)

-Range("A93").Clear

-Range("B93").Clear

-Range("C93").Clear

-Range("D93").Clear

-Range("A93").Value = "xlDialogGallery3dColumn"

-Range("B93").Value = 194

-Range("C93").Value = num

-B93 = Range("B93").Value

-C93 = Range("C93").Value

-If B93 = C93 Then

-Range("D93").Value = "OK"

-Else

-Range("D93").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGallery3dLine(ByRef num)

-Range("A94").Clear

-Range("B94").Clear

-Range("C94").Clear

-Range("D94").Clear

-Range("A94").Value = "xlDialogGallery3dLine"

-Range("B94").Value = 195

-Range("C94").Value = num

-B94 = Range("B94").Value

-C94 = Range("C94").Value

-If B94 = C94 Then

-Range("D94").Value = "OK"

-Else

-Range("D94").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGallery3dPie(ByRef num)

-Range("A95").Clear

-Range("B95").Clear

-Range("C95").Clear

-Range("D95").Clear

-Range("A95").Value = "xlDialogGallery3dPie"

-Range("B95").Value = 196

-Range("C95").Value = num

-B95 = Range("B95").Value

-C95 = Range("C95").Value

-If B95 = C95 Then

-Range("D95").Value = "OK"

-Else

-Range("D95").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGallery3dSurface(ByRef num)

-Range("A96").Clear

-Range("B96").Clear

-Range("C96").Clear

-Range("D96").Clear

-Range("A96").Value = "xlDialogGallery3dSurface"

-Range("B96").Value = 273

-Range("C96").Value = num

-B96 = Range("B96").Value

-C96 = Range("C96").Value

-If B96 = C96 Then

-Range("D96").Value = "OK"

-Else

-Range("D96").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGalleryArea(ByRef num)

-Range("A97").Clear

-Range("B97").Clear

-Range("C97").Clear

-Range("D97").Clear

-Range("A97").Value = "xlDialogGalleryArea"

-Range("B97").Value = 67

-Range("C97").Value = num

-B97 = Range("B97").Value

-C97 = Range("C97").Value

-If B97 = C97 Then

-Range("D97").Value = "OK"

-Else

-Range("D97").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGalleryBar(ByRef num)

-Range("A98").Clear

-Range("B98").Clear

-Range("C98").Clear

-Range("D98").Clear

-Range("A98").Value = "xlDialogGalleryBar"

-Range("B98").Value = 68

-Range("C98").Value = num

-B98 = Range("B98").Value

-C98 = Range("C98").Value

-If B98 = C98 Then

-Range("D98").Value = "OK"

-Else

-Range("D98").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGalleryColumn(ByRef num)

-Range("A99").Clear

-Range("B99").Clear

-Range("C99").Clear

-Range("D99").Clear

-Range("A99").Value = "xlDialogGalleryColumn"

-Range("B99").Value = 69

-Range("C99").Value = num

-B99 = Range("B99").Value

-C99 = Range("C99").Value

-If B99 = C99 Then

-Range("D99").Value = "OK"

-Else

-Range("D99").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGalleryCustom(ByRef num)

-Range("A100").Clear

-Range("B100").Clear

-Range("C100").Clear

-Range("D100").Clear

-Range("A100").Value = "xlDialogGalleryCustom"

-Range("B100").Value = 388

-Range("C100").Value = num

-B100 = Range("B100").Value

-C100 = Range("C100").Value

-If B100 = C100 Then

-Range("D100").Value = "OK"

-Else

-Range("D100").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGalleryDoughnut(ByRef num)

-Range("A101").Clear

-Range("B101").Clear

-Range("C101").Clear

-Range("D101").Clear

-Range("A101").Value = "xlDialogGalleryDoughnut"

-Range("B101").Value = 344

-Range("C101").Value = num

-B101 = Range("B101").Value

-C101 = Range("C101").Value

-If B101 = C101 Then

-Range("D101").Value = "OK"

-Else

-Range("D101").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGalleryLine(ByRef num)

-Range("A102").Clear

-Range("B102").Clear

-Range("C102").Clear

-Range("D102").Clear

-Range("A102").Value = "xlDialogGalleryLine"

-Range("B102").Value = 70

-Range("C102").Value = num

-B102 = Range("B102").Value

-C102 = Range("C102").Value

-If B102 = C102 Then

-Range("D102").Value = "OK"

-Else

-Range("D102").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGalleryPie(ByRef num)

-Range("A103").Clear

-Range("B103").Clear

-Range("C103").Clear

-Range("D103").Clear

-Range("A103").Value = "xlDialogGalleryPie"

-Range("B103").Value = 71

-Range("C103").Value = num

-B103 = Range("B103").Value

-C103 = Range("C103").Value

-If B103 = C103 Then

-Range("D103").Value = "OK"

-Else

-Range("D103").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGalleryRader(ByRef num)

-Range("A104").Clear

-Range("B104").Clear

-Range("C104").Clear

-Range("D104").Clear

-Range("A104").Value = "xlDialogGalleryRader"

-Range("B104").Value = 249

-Range("C104").Value = num

-B104 = Range("B104").Value

-C104 = Range("C104").Value

-If B104 = C104 Then

-Range("D104").Value = "OK"

-Else

-Range("D104").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGalleryScatter(ByRef num)

-Range("A105").Clear

-Range("B105").Clear

-Range("C105").Clear

-Range("D105").Clear

-Range("A105").Value = "xlDialogGalleryScatter"

-Range("B105").Value = 72

-Range("C105").Value = num

-B105 = Range("B105").Value

-C105 = Range("C105").Value

-If B105 = C105 Then

-Range("D105").Value = "OK"

-Else

-Range("D105").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGoalSeek(ByRef num)

-Range("A106").Clear

-Range("B106").Clear

-Range("C106").Clear

-Range("D106").Clear

-Range("A106").Value = "xlDialogGoalSeek"

-Range("B106").Value = 198

-Range("C106").Value = num

-B106 = Range("B106").Value

-C106 = Range("C106").Value

-If B106 = C106 Then

-Range("D106").Value = "OK"

-Else

-Range("D106").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogGridlines(ByRef num)

-Range("A107").Clear

-Range("B107").Clear

-Range("C107").Clear

-Range("D107").Clear

-Range("A107").Value = "xlDialogGridlines"

-Range("B107").Value = 76

-Range("C107").Value = num

-B107 = Range("B107").Value

-C107 = Range("C107").Value

-If B107 = C107 Then

-Range("D107").Value = "OK"

-Else

-Range("D107").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogImportTextFile(ByRef num)

-Range("A108").Clear

-Range("B108").Clear

-Range("C108").Clear

-Range("D108").Clear

-Range("A108").Value = "xlDialogImportTextFile"

-Range("B108").Value = 666

-Range("C108").Value = num

-B108 = Range("B108").Value

-C108 = Range("C108").Value

-If B108 = C108 Then

-Range("D108").Value = "OK"

-Else

-Range("D108").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogInsert(ByRef num)

-Range("A109").Clear

-Range("B109").Clear

-Range("C109").Clear

-Range("D109").Clear

-Range("A109").Value = "xlDialogInsert"

-Range("B109").Value = 55

-Range("C109").Value = num

-B109 = Range("B109").Value

-C109 = Range("C109").Value

-If B109 = C109 Then

-Range("D109").Value = "OK"

-Else

-Range("D109").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogInsertHyperlink(ByRef num)

-Range("A110").Clear

-Range("B110").Clear

-Range("C110").Clear

-Range("D110").Clear

-Range("A110").Value = "xlDialogInsertHyperlink"

-Range("B110").Value = 596

-Range("C110").Value = num

-B110 = Range("B110").Value

-C110 = Range("C110").Value

-If B110 = C110 Then

-Range("D110").Value = "OK"

-Else

-Range("D110").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogInsertNameLabel(ByRef num)

-Range("A111").Clear

-Range("B111").Clear

-Range("C111").Clear

-Range("D111").Clear

-Range("A111").Value = "xlDialogInsertNameLabel"

-Range("B111").Value = 496

-Range("C111").Value = num

-B111 = Range("B111").Value

-C111 = Range("C111").Value

-If B111 = C111 Then

-Range("D111").Value = "OK"

-Else

-Range("D111").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogInsertObject(ByRef num)

-Range("A112").Clear

-Range("B112").Clear

-Range("C112").Clear

-Range("D112").Clear

-Range("A112").Value = "xlDialogInsertObject"

-Range("B112").Value = 259

-Range("C112").Value = num

-B112 = Range("B112").Value

-C112 = Range("C112").Value

-If B112 = C112 Then

-Range("D112").Value = "OK"

-Else

-Range("D112").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogInsertPicture(ByRef num)

-Range("A113").Clear

-Range("B113").Clear

-Range("C113").Clear

-Range("D113").Clear

-Range("A113").Value = "xlDialogInsertPicture"

-Range("B113").Value = 342

-Range("C113").Value = num

-B113 = Range("B113").Value

-C113 = Range("C113").Value

-If B113 = C113 Then

-Range("D113").Value = "OK"

-Else

-Range("D113").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogInsertTitle(ByRef num)

-Range("A114").Clear

-Range("B114").Clear

-Range("C114").Clear

-Range("D114").Clear

-Range("A114").Value = "xlDialogInsertTitle"

-Range("B114").Value = 380

-Range("C114").Value = num

-B114 = Range("B114").Value

-C114 = Range("C114").Value

-If B114 = C114 Then

-Range("D114").Value = "OK"

-Else

-Range("D114").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogLabelProperties(ByRef num)

-Range("A115").Clear

-Range("B115").Clear

-Range("C115").Clear

-Range("D115").Clear

-Range("A115").Value = "xlDialogLabelProperties"

-Range("B115").Value = 436

-Range("C115").Value = num

-B115 = Range("B115").Value

-C115 = Range("C115").Value

-If B115 = C115 Then

-Range("D115").Value = "OK"

-Else

-Range("D115").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogListboxProperties(ByRef num)

-Range("A116").Clear

-Range("B116").Clear

-Range("C116").Clear

-Range("D116").Clear

-Range("A116").Value = "xlDialogListboxProperties"

-Range("B116").Value = 437

-Range("C116").Value = num

-B116 = Range("B116").Value

-C116 = Range("C116").Value

-If B116 = C116 Then

-Range("D116").Value = "OK"

-Else

-Range("D116").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogMacroOptions(ByRef num)

-Range("A117").Clear

-Range("B117").Clear

-Range("C117").Clear

-Range("D117").Clear

-Range("A117").Value = "xlDialogMacroOptions"

-Range("B117").Value = 382

-Range("C117").Value = num

-B117 = Range("B117").Value

-C117 = Range("C117").Value

-If B117 = C117 Then

-Range("D117").Value = "OK"

-Else

-Range("D117").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogMailEditMailer(ByRef num)

-Range("A118").Clear

-Range("B118").Clear

-Range("C118").Clear

-Range("D118").Clear

-Range("A118").Value = "xlDialogMailEditMailer"

-Range("B118").Value = 470

-Range("C118").Value = num

-B118 = Range("B118").Value

-C118 = Range("C118").Value

-If B118 = C118 Then

-Range("D118").Value = "OK"

-Else

-Range("D118").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogMailLogon(ByRef num)

-Range("A119").Clear

-Range("B119").Clear

-Range("C119").Clear

-Range("D119").Clear

-Range("A119").Value = "xlDialogMailLogon"

-Range("B119").Value = 339

-Range("C119").Value = num

-B119 = Range("B119").Value

-C119 = Range("C119").Value

-If B119 = C119 Then

-Range("D119").Value = "OK"

-Else

-Range("D119").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogMailNextLetter(ByRef num)

-Range("A120").Clear

-Range("B120").Clear

-Range("C120").Clear

-Range("D120").Clear

-Range("A120").Value = "xlDialogMailNextLetter"

-Range("B120").Value = 378

-Range("C120").Value = num

-B120 = Range("B120").Value

-C120 = Range("C120").Value

-If B120 = C120 Then

-Range("D120").Value = "OK"

-Else

-Range("D120").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogMainChart(ByRef num)

-Range("A121").Clear

-Range("B121").Clear

-Range("C121").Clear

-Range("D121").Clear

-Range("A121").Value = "xlDialogMainChart"

-Range("B121").Value = 85

-Range("C121").Value = num

-B121 = Range("B121").Value

-C121 = Range("C121").Value

-If B121 = C121 Then

-Range("D121").Value = "OK"

-Else

-Range("D121").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogMainChartType(ByRef num)

-Range("A122").Clear

-Range("B122").Clear

-Range("C122").Clear

-Range("D122").Clear

-Range("A122").Value = "xlDialogMainChartType"

-Range("B122").Value = 185

-Range("C122").Value = num

-B122 = Range("B122").Value

-C122 = Range("C122").Value

-If B122 = C122 Then

-Range("D122").Value = "OK"

-Else

-Range("D122").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogMenuEditor(ByRef num)

-Range("A123").Clear

-Range("B123").Clear

-Range("C123").Clear

-Range("D123").Clear

-Range("A123").Value = "xlDialogMenuEditor"

-Range("B123").Value = 322

-Range("C123").Value = num

-B123 = Range("B123").Value

-C123 = Range("C123").Value

-If B123 = C123 Then

-Range("D123").Value = "OK"

-Else

-Range("D123").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogMove(ByRef num)

-Range("A124").Clear

-Range("B124").Clear

-Range("C124").Clear

-Range("D124").Clear

-Range("A124").Value = "xlDialogMove"

-Range("B124").Value = 262

-Range("C124").Value = num

-B124 = Range("B124").Value

-C124 = Range("C124").Value

-If B124 = C124 Then

-Range("D124").Value = "OK"

-Else

-Range("D124").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogMyPermission(ByRef num)

-Range("A125").Clear

-Range("B125").Clear

-Range("C125").Clear

-Range("D125").Clear

-Range("A125").Value = "xlDialogMyPermission"

-Range("B125").Value = 834

-Range("C125").Value = num

-B125 = Range("B125").Value

-C125 = Range("C125").Value

-If B125 = C125 Then

-Range("D125").Value = "OK"

-Else

-Range("D125").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogNew(ByRef num)

-Range("A126").Clear

-Range("B126").Clear

-Range("C126").Clear

-Range("D126").Clear

-Range("A126").Value = "xlDialogNew"

-Range("B126").Value = 119

-Range("C126").Value = num

-B126 = Range("B126").Value

-C126 = Range("C126").Value

-If B126 = C126 Then

-Range("D126").Value = "OK"

-Else

-Range("D126").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogNewWebQuery(ByRef num)

-Range("A127").Clear

-Range("B127").Clear

-Range("C127").Clear

-Range("D127").Clear

-Range("A127").Value = "xlDialogNewWebQuery"

-Range("B127").Value = 667

-Range("C127").Value = num

-B127 = Range("B127").Value

-C127 = Range("C127").Value

-If B127 = C127 Then

-Range("D127").Value = "OK"

-Else

-Range("D127").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogNote(ByRef num)

-Range("A128").Clear

-Range("B128").Clear

-Range("C128").Clear

-Range("D128").Clear

-Range("A128").Value = "xlDialogNote"

-Range("B128").Value = 154

-Range("C128").Value = num

-B128 = Range("B128").Value

-C128 = Range("C128").Value

-If B128 = C128 Then

-Range("D128").Value = "OK"

-Else

-Range("D128").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogObjectProperties(ByRef num)

-Range("A129").Clear

-Range("B129").Clear

-Range("C129").Clear

-Range("D129").Clear

-Range("A129").Value = "xlDialogObjectProperties"

-Range("B129").Value = 207

-Range("C129").Value = num

-B129 = Range("B129").Value

-C129 = Range("C129").Value

-If B129 = C129 Then

-Range("D129").Value = "OK"

-Else

-Range("D129").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogObjectProtection(ByRef num)

-Range("A130").Clear

-Range("B130").Clear

-Range("C130").Clear

-Range("D130").Clear

-Range("A130").Value = "xlDialogObjectProtection"

-Range("B130").Value = 214

-Range("C130").Value = num

-B130 = Range("B130").Value

-C130 = Range("C130").Value

-If B130 = C130 Then

-Range("D130").Value = "OK"

-Else

-Range("D130").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOpen(ByRef num)

-Range("A131").Clear

-Range("B131").Clear

-Range("C131").Clear

-Range("D131").Clear

-Range("A131").Value = "xlDialogOpen"

-Range("B131").Value = 1

-Range("C131").Value = num

-B131 = Range("B131").Value

-C131 = Range("C131").Value

-If B131 = C131 Then

-Range("D131").Value = "OK"

-Else

-Range("D131").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOpenLinks(ByRef num)

-Range("A132").Clear

-Range("B132").Clear

-Range("C132").Clear

-Range("D132").Clear

-Range("A132").Value = "xlDialogOpenLinks"

-Range("B132").Value = 2

-Range("C132").Value = num

-B132 = Range("B132").Value

-C132 = Range("C132").Value

-If B132 = C132 Then

-Range("D132").Value = "OK"

-Else

-Range("D132").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOpenMail(ByRef num)

-Range("A133").Clear

-Range("B133").Clear

-Range("C133").Clear

-Range("D133").Clear

-Range("A133").Value = "xlDialogOpenMail"

-Range("B133").Value = 188

-Range("C133").Value = num

-B133 = Range("B133").Value

-C133 = Range("C133").Value

-If B133 = C133 Then

-Range("D133").Value = "OK"

-Else

-Range("D133").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOpenText(ByRef num)

-Range("A134").Clear

-Range("B134").Clear

-Range("C134").Clear

-Range("D134").Clear

-Range("A134").Value = "xlDialogOpenText"

-Range("B134").Value = 441

-Range("C134").Value = num

-B134 = Range("B134").Value

-C134 = Range("C134").Value

-If B134 = C134 Then

-Range("D134").Value = "OK"

-Else

-Range("D134").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOptionsCalculation(ByRef num)

-Range("A135").Clear

-Range("B135").Clear

-Range("C135").Clear

-Range("D135").Clear

-Range("A135").Value = "xlDialogOptionsCalculation"

-Range("B135").Value = 318

-Range("C135").Value = num

-B135 = Range("B135").Value

-C135 = Range("C135").Value

-If B135 = C135 Then

-Range("D135").Value = "OK"

-Else

-Range("D135").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOptionsChart(ByRef num)

-Range("A136").Clear

-Range("B136").Clear

-Range("C136").Clear

-Range("D136").Clear

-Range("A136").Value = "xlDialogOptionsChart"

-Range("B136").Value = 325

-Range("C136").Value = num

-B136 = Range("B136").Value

-C136 = Range("C136").Value

-If B136 = C136 Then

-Range("D136").Value = "OK"

-Else

-Range("D136").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOptionsEdit(ByRef num)

-Range("A137").Clear

-Range("B137").Clear

-Range("C137").Clear

-Range("D137").Clear

-Range("A137").Value = "xlDialogOptionsEdit"

-Range("B137").Value = 319

-Range("C137").Value = num

-B137 = Range("B137").Value

-C137 = Range("C137").Value

-If B137 = C137 Then

-Range("D137").Value = "OK"

-Else

-Range("D137").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOptionsGeneral(ByRef num)

-Range("A138").Clear

-Range("B138").Clear

-Range("C138").Clear

-Range("D138").Clear

-Range("A138").Value = "xlDialogOptionsGeneral"

-Range("B138").Value = 356

-Range("C138").Value = num

-B138 = Range("B138").Value

-C138 = Range("C138").Value

-If B138 = C138 Then

-Range("D138").Value = "OK"

-Else

-Range("D138").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOptionsListAdd(ByRef num)

-Range("A139").Clear

-Range("B139").Clear

-Range("C139").Clear

-Range("D139").Clear

-Range("A139").Value = "xlDialogOptionsListAdd"

-Range("B139").Value = 458

-Range("C139").Value = num

-B139 = Range("B139").Value

-C139 = Range("C139").Value

-If B139 = C139 Then

-Range("D139").Value = "OK"

-Else

-Range("D139").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOptionsME(ByRef num)

-Range("A140").Clear

-Range("B140").Clear

-Range("C140").Clear

-Range("D140").Clear

-Range("A140").Value = "xlDialogOptionsME"

-Range("B140").Value = 647

-Range("C140").Value = num

-B140 = Range("B140").Value

-C140 = Range("C140").Value

-If B140 = C140 Then

-Range("D140").Value = "OK"

-Else

-Range("D140").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOptionsTransition(ByRef num)

-Range("A141").Clear

-Range("B141").Clear

-Range("C141").Clear

-Range("D141").Clear

-Range("A141").Value = "xlDialogOptionsTransition"

-Range("B141").Value = 355

-Range("C141").Value = num

-B141 = Range("B141").Value

-C141 = Range("C141").Value

-If B141 = C141 Then

-Range("D141").Value = "OK"

-Else

-Range("D141").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOptionsView(ByRef num)

-Range("A142").Clear

-Range("B142").Clear

-Range("C142").Clear

-Range("D142").Clear

-Range("A142").Value = "xlDialogOptionsView"

-Range("B142").Value = 320

-Range("C142").Value = num

-B142 = Range("B142").Value

-C142 = Range("C142").Value

-If B142 = C142 Then

-Range("D142").Value = "OK"

-Else

-Range("D142").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOutline(ByRef num)

-Range("A143").Clear

-Range("B143").Clear

-Range("C143").Clear

-Range("D143").Clear

-Range("A143").Value = "xlDialogOutline"

-Range("B143").Value = 142

-Range("C143").Value = num

-B143 = Range("B143").Value

-C143 = Range("C143").Value

-If B143 = C143 Then

-Range("D143").Value = "OK"

-Else

-Range("D143").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOverlay(ByRef num)

-Range("A144").Clear

-Range("B144").Clear

-Range("C144").Clear

-Range("D144").Clear

-Range("A144").Value = "xlDialogOverlay"

-Range("B144").Value = 86

-Range("C144").Value = num

-B144 = Range("B144").Value

-C144 = Range("C144").Value

-If B144 = C144 Then

-Range("D144").Value = "OK"

-Else

-Range("D144").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogOverlayChartType(ByRef num)

-Range("A145").Clear

-Range("B145").Clear

-Range("C145").Clear

-Range("D145").Clear

-Range("A145").Value = "xlDialogOverlayChartType"

-Range("B145").Value = 186

-Range("C145").Value = num

-B145 = Range("B145").Value

-C145 = Range("C145").Value

-If B145 = C145 Then

-Range("D145").Value = "OK"

-Else

-Range("D145").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPageSetup(ByRef num)

-Range("A146").Clear

-Range("B146").Clear

-Range("C146").Clear

-Range("D146").Clear

-Range("A146").Value = "xlDialogPageSetup"

-Range("B146").Value = 7

-Range("C146").Value = num

-B146 = Range("B146").Value

-C146 = Range("C146").Value

-If B146 = C146 Then

-Range("D146").Value = "OK"

-Else

-Range("D146").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogParse(ByRef num)

-Range("A147").Clear

-Range("B147").Clear

-Range("C147").Clear

-Range("D147").Clear

-Range("A147").Value = "xlDialogParse"

-Range("B147").Value = 91

-Range("C147").Value = num

-B147 = Range("B147").Value

-C147 = Range("C147").Value

-If B147 = C147 Then

-Range("D147").Value = "OK"

-Else

-Range("D147").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPasteNames(ByRef num)

-Range("A148").Clear

-Range("B148").Clear

-Range("C148").Clear

-Range("D148").Clear

-Range("A148").Value = "xlDialogPasteNames"

-Range("B148").Value = 58

-Range("C148").Value = num

-B148 = Range("B148").Value

-C148 = Range("C148").Value

-If B148 = C148 Then

-Range("D148").Value = "OK"

-Else

-Range("D148").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPasteSpecial(ByRef num)

-Range("A149").Clear

-Range("B149").Clear

-Range("C149").Clear

-Range("D149").Clear

-Range("A149").Value = "xlDialogPasteSpecial"

-Range("B149").Value = 53

-Range("C149").Value = num

-B149 = Range("B149").Value

-C149 = Range("C149").Value

-If B149 = C149 Then

-Range("D149").Value = "OK"

-Else

-Range("D149").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPatterns(ByRef num)

-Range("A150").Clear

-Range("B150").Clear

-Range("C150").Clear

-Range("D150").Clear

-Range("A150").Value = "xlDialogPatterns"

-Range("B150").Value = 84

-Range("C150").Value = num

-B150 = Range("B150").Value

-C150 = Range("C150").Value

-If B150 = C150 Then

-Range("D150").Value = "OK"

-Else

-Range("D150").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPermission(ByRef num)

-Range("A151").Clear

-Range("B151").Clear

-Range("C151").Clear

-Range("D151").Clear

-Range("A151").Value = "xlDialogPermission"

-Range("B151").Value = 832

-Range("C151").Value = num

-B151 = Range("B151").Value

-C151 = Range("C151").Value

-If B151 = C151 Then

-Range("D151").Value = "OK"

-Else

-Range("D151").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPhonetic(ByRef num)

-Range("A152").Clear

-Range("B152").Clear

-Range("C152").Clear

-Range("D152").Clear

-Range("A152").Value = "xlDialogPhonetic"

-Range("B152").Value = 656

-Range("C152").Value = num

-B152 = Range("B152").Value

-C152 = Range("C152").Value

-If B152 = C152 Then

-Range("D152").Value = "OK"

-Else

-Range("D152").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPivotCalculatedField(ByRef num)

-Range("A153").Clear

-Range("B153").Clear

-Range("C153").Clear

-Range("D153").Clear

-Range("A153").Value = "xlDialogPivotCalculatedField"

-Range("B153").Value = 570

-Range("C153").Value = num

-B153 = Range("B153").Value

-C153 = Range("C153").Value

-If B153 = C153 Then

-Range("D153").Value = "OK"

-Else

-Range("D153").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPivotCalculatedItem(ByRef num)

-Range("A154").Clear

-Range("B154").Clear

-Range("C154").Clear

-Range("D154").Clear

-Range("A154").Value = "xlDialogPivotCalculatedItem"

-Range("B154").Value = 572

-Range("C154").Value = num

-B154 = Range("B154").Value

-C154 = Range("C154").Value

-If B154 = C154 Then

-Range("D154").Value = "OK"

-Else

-Range("D154").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPivotClientServerSet(ByRef num)

-Range("A155").Clear

-Range("B155").Clear

-Range("C155").Clear

-Range("D155").Clear

-Range("A155").Value = "xlDialogPivotClientServerSet"

-Range("B155").Value = 689

-Range("C155").Value = num

-B155 = Range("B155").Value

-C155 = Range("C155").Value

-If B155 = C155 Then

-Range("D155").Value = "OK"

-Else

-Range("D155").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPivotFieldGroup(ByRef num)

-Range("A156").Clear

-Range("B156").Clear

-Range("C156").Clear

-Range("D156").Clear

-Range("A156").Value = "xlDialogPivotFieldGroup"

-Range("B156").Value = 433

-Range("C156").Value = num

-B156 = Range("B156").Value

-C156 = Range("C156").Value

-If B156 = C156 Then

-Range("D156").Value = "OK"

-Else

-Range("D156").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPivotFieldProperties(ByRef num)

-Range("A157").Clear

-Range("B157").Clear

-Range("C157").Clear

-Range("D157").Clear

-Range("A157").Value = "xlDialogPivotFieldProperties"

-Range("B157").Value = 313

-Range("C157").Value = num

-B157 = Range("B157").Value

-C157 = Range("C157").Value

-If B157 = C157 Then

-Range("D157").Value = "OK"

-Else

-Range("D157").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPivotFieldUngroup(ByRef num)

-Range("A158").Clear

-Range("B158").Clear

-Range("C158").Clear

-Range("D158").Clear

-Range("A158").Value = "xlDialogPivotFieldUngroup"

-Range("B158").Value = 434

-Range("C158").Value = num

-B158 = Range("B158").Value

-C158 = Range("C158").Value

-If B158 = C158 Then

-Range("D158").Value = "OK"

-Else

-Range("D158").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPivotShowPages(ByRef num)

-Range("A159").Clear

-Range("B159").Clear

-Range("C159").Clear

-Range("D159").Clear

-Range("A159").Value = "xlDialogPivotShowPages"

-Range("B159").Value = 421

-Range("C159").Value = num

-B159 = Range("B159").Value

-C159 = Range("C159").Value

-If B159 = C159 Then

-Range("D159").Value = "OK"

-Else

-Range("D159").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPivotSolveOrder(ByRef num)

-Range("A160").Clear

-Range("B160").Clear

-Range("C160").Clear

-Range("D160").Clear

-Range("A160").Value = "xlDialogPivotSolveOrder"

-Range("B160").Value = 568

-Range("C160").Value = num

-B160 = Range("B160").Value

-C160 = Range("C160").Value

-If B160 = C160 Then

-Range("D160").Value = "OK"

-Else

-Range("D160").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPivotTableOptions(ByRef num)

-Range("A161").Clear

-Range("B161").Clear

-Range("C161").Clear

-Range("D161").Clear

-Range("A161").Value = "xlDialogPivotTableOptions"

-Range("B161").Value = 567

-Range("C161").Value = num

-B161 = Range("B161").Value

-C161 = Range("C161").Value

-If B161 = C161 Then

-Range("D161").Value = "OK"

-Else

-Range("D161").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPivotTableWizard(ByRef num)

-Range("A162").Clear

-Range("B162").Clear

-Range("C162").Clear

-Range("D162").Clear

-Range("A162").Value = "xlDialogPivotTableWizard"

-Range("B162").Value = 321

-Range("C162").Value = num

-B162 = Range("B162").Value

-C162 = Range("C162").Value

-If B162 = C162 Then

-Range("D162").Value = "OK"

-Else

-Range("D162").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPlacement(ByRef num)

-Range("A163").Clear

-Range("B163").Clear

-Range("C163").Clear

-Range("D163").Clear

-Range("A163").Value = "xlDialogPlacement"

-Range("B163").Value = 300

-Range("C163").Value = num

-B163 = Range("B163").Value

-C163 = Range("C163").Value

-If B163 = C163 Then

-Range("D163").Value = "OK"

-Else

-Range("D163").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPrint(ByRef num)

-Range("A164").Clear

-Range("B164").Clear

-Range("C164").Clear

-Range("D164").Clear

-Range("A164").Value = "xlDialogPrint"

-Range("B164").Value = 8

-Range("C164").Value = num

-B164 = Range("B164").Value

-C164 = Range("C164").Value

-If B164 = C164 Then

-Range("D164").Value = "OK"

-Else

-Range("D164").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPrintSetup(ByRef num)

-Range("A165").Clear

-Range("B165").Clear

-Range("C165").Clear

-Range("D165").Clear

-Range("A165").Value = "xlDialogPrintSetup"

-Range("B165").Value = 9

-Range("C165").Value = num

-B165 = Range("B165").Value

-C165 = Range("C165").Value

-If B165 = C165 Then

-Range("D165").Value = "OK"

-Else

-Range("D165").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPrintPreview(ByRef num)

-Range("A166").Clear

-Range("B166").Clear

-Range("C166").Clear

-Range("D166").Clear

-Range("A166").Value = "xlDialogPrintPreview"

-Range("B166").Value = 222

-Range("C166").Value = num

-B166 = Range("B166").Value

-C166 = Range("C166").Value

-If B166 = C166 Then

-Range("D166").Value = "OK"

-Else

-Range("D166").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPromote(ByRef num)

-Range("A167").Clear

-Range("B167").Clear

-Range("C167").Clear

-Range("D167").Clear

-Range("A167").Value = "xlDialogPromote"

-Range("B167").Value = 202

-Range("C167").Value = num

-B167 = Range("B167").Value

-C167 = Range("C167").Value

-If B167 = C167 Then

-Range("D167").Value = "OK"

-Else

-Range("D167").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogProperties(ByRef num)

-Range("A168").Clear

-Range("B168").Clear

-Range("C168").Clear

-Range("D168").Clear

-Range("A168").Value = "xlDialogProperties"

-Range("B168").Value = 474

-Range("C168").Value = num

-B168 = Range("B168").Value

-C168 = Range("C168").Value

-If B168 = C168 Then

-Range("D168").Value = "OK"

-Else

-Range("D168").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPropertyFields(ByRef num)

-Range("A169").Clear

-Range("B169").Clear

-Range("C169").Clear

-Range("D169").Clear

-Range("A169").Value = "xlDialogPropertyFields"

-Range("B169").Value = 754

-Range("C169").Value = num

-B169 = Range("B169").Value

-C169 = Range("C169").Value

-If B169 = C169 Then

-Range("D169").Value = "OK"

-Else

-Range("D169").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogProtectDocument(ByRef num)

-Range("A170").Clear

-Range("B170").Clear

-Range("C170").Clear

-Range("D170").Clear

-Range("A170").Value = "xlDialogProtectDocument"

-Range("B170").Value = 28

-Range("C170").Value = num

-B170 = Range("B170").Value

-C170 = Range("C170").Value

-If B170 = C170 Then

-Range("D170").Value = "OK"

-Else

-Range("D170").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogProtectSharing(ByRef num)

-Range("A171").Clear

-Range("B171").Clear

-Range("C171").Clear

-Range("D171").Clear

-Range("A171").Value = "xlDialogProtectSharing"

-Range("B171").Value = 620

-Range("C171").Value = num

-B171 = Range("B171").Value

-C171 = Range("C171").Value

-If B171 = C171 Then

-Range("D171").Value = "OK"

-Else

-Range("D171").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPublishAsWebPage(ByRef num)

-Range("A172").Clear

-Range("B172").Clear

-Range("C172").Clear

-Range("D172").Clear

-Range("A172").Value = "xlDialogPublishAsWebPage"

-Range("B172").Value = 653

-Range("C172").Value = num

-B172 = Range("B172").Value

-C172 = Range("C172").Value

-If B172 = C172 Then

-Range("D172").Value = "OK"

-Else

-Range("D172").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogPushbuttonProperties(ByRef num)

-Range("A173").Clear

-Range("B173").Clear

-Range("C173").Clear

-Range("D173").Clear

-Range("A173").Value = "xlDialogPushbuttonProperties"

-Range("B173").Value = 445

-Range("C173").Value = num

-B173 = Range("B173").Value

-C173 = Range("C173").Value

-If B173 = C173 Then

-Range("D173").Value = "OK"

-Else

-Range("D173").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogReplaceFont(ByRef num)

-Range("A174").Clear

-Range("B174").Clear

-Range("C174").Clear

-Range("D174").Clear

-Range("A174").Value = "xlDialogReplaceFont"

-Range("B174").Value = 134

-Range("C174").Value = num

-B174 = Range("B174").Value

-C174 = Range("C174").Value

-If B174 = C174 Then

-Range("D174").Value = "OK"

-Else

-Range("D174").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogRoutingSlip(ByRef num)

-Range("A175").Clear

-Range("B175").Clear

-Range("C175").Clear

-Range("D175").Clear

-Range("A175").Value = "xlDialogRoutingSlip"

-Range("B175").Value = 336

-Range("C175").Value = num

-B175 = Range("B175").Value

-C175 = Range("C175").Value

-If B175 = C175 Then

-Range("D175").Value = "OK"

-Else

-Range("D175").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogRowHeight(ByRef num)

-Range("A176").Clear

-Range("B176").Clear

-Range("C176").Clear

-Range("D176").Clear

-Range("A176").Value = "xlDialogRowHeight"

-Range("B176").Value = 127

-Range("C176").Value = num

-B176 = Range("B176").Value

-C176 = Range("C176").Value

-If B176 = C176 Then

-Range("D176").Value = "OK"

-Else

-Range("D176").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogRun(ByRef num)

-Range("A177").Clear

-Range("B177").Clear

-Range("C177").Clear

-Range("D177").Clear

-Range("A177").Value = "xlDialogRun"

-Range("B177").Value = 17

-Range("C177").Value = num

-B177 = Range("B177").Value

-C177 = Range("C177").Value

-If B177 = C177 Then

-Range("D177").Value = "OK"

-Else

-Range("D177").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSaveAs(ByRef num)

-Range("A178").Clear

-Range("B178").Clear

-Range("C178").Clear

-Range("D178").Clear

-Range("A178").Value = "xlDialogSaveAs"

-Range("B178").Value = 5

-Range("C178").Value = num

-B178 = Range("B178").Value

-C178 = Range("C178").Value

-If B178 = C178 Then

-Range("D178").Value = "OK"

-Else

-Range("D178").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSaveCopyAs(ByRef num)

-Range("A179").Clear

-Range("B179").Clear

-Range("C179").Clear

-Range("D179").Clear

-Range("A179").Value = "xlDialogSaveCopyAs"

-Range("B179").Value = 456

-Range("C179").Value = num

-B179 = Range("B179").Value

-C179 = Range("C179").Value

-If B179 = C179 Then

-Range("D179").Value = "OK"

-Else

-Range("D179").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSaveNewObject(ByRef num)

-Range("A180").Clear

-Range("B180").Clear

-Range("C180").Clear

-Range("D180").Clear

-Range("A180").Value = "xlDialogSaveNewObject"

-Range("B180").Value = 208

-Range("C180").Value = num

-B180 = Range("B180").Value

-C180 = Range("C180").Value

-If B180 = C180 Then

-Range("D180").Value = "OK"

-Else

-Range("D180").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSaveWorkbook(ByRef num)

-Range("A181").Clear

-Range("B181").Clear

-Range("C181").Clear

-Range("D181").Clear

-Range("A181").Value = "xlDialogSaveWorkbook"

-Range("B181").Value = 145

-Range("C181").Value = num

-B181 = Range("B181").Value

-C181 = Range("C181").Value

-If B181 = C181 Then

-Range("D181").Value = "OK"

-Else

-Range("D181").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSaveWorkspace(ByRef num)

-Range("A182").Clear

-Range("B182").Clear

-Range("C182").Clear

-Range("D182").Clear

-Range("A182").Value = "xlDialogSaveWorkspace"

-Range("B182").Value = 285

-Range("C182").Value = num

-B182 = Range("B182").Value

-C182 = Range("C182").Value

-If B182 = C182 Then

-Range("D182").Value = "OK"

-Else

-Range("D182").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogScale(ByRef num)

-Range("A183").Clear

-Range("B183").Clear

-Range("C183").Clear

-Range("D183").Clear

-Range("A183").Value = "xlDialogScale"

-Range("B183").Value = 87

-Range("C183").Value = num

-B183 = Range("B183").Value

-C183 = Range("C183").Value

-If B183 = C183 Then

-Range("D183").Value = "OK"

-Else

-Range("D183").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogScenarioAdd(ByRef num)

-Range("A184").Clear

-Range("B184").Clear

-Range("C184").Clear

-Range("D184").Clear

-Range("A184").Value = "xlDialogScenarioAdd"

-Range("B184").Value = 307

-Range("C184").Value = num

-B184 = Range("B184").Value

-C184 = Range("C184").Value

-If B184 = C184 Then

-Range("D184").Value = "OK"

-Else

-Range("D184").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogScenarioCells(ByRef num)

-Range("A185").Clear

-Range("B185").Clear

-Range("C185").Clear

-Range("D185").Clear

-Range("A185").Value = "xlDialogScenarioCells"

-Range("B185").Value = 305

-Range("C185").Value = num

-B185 = Range("B185").Value

-C185 = Range("C185").Value

-If B185 = C185 Then

-Range("D185").Value = "OK"

-Else

-Range("D185").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogScenarioEdit(ByRef num)

-Range("A186").Clear

-Range("B186").Clear

-Range("C186").Clear

-Range("D186").Clear

-Range("A186").Value = "xlDialogScenarioEdit"

-Range("B186").Value = 308

-Range("C186").Value = num

-B186 = Range("B186").Value

-C186 = Range("C186").Value

-If B186 = C186 Then

-Range("D186").Value = "OK"

-Else

-Range("D186").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogScenarioMerge(ByRef num)

-Range("A187").Clear

-Range("B187").Clear

-Range("C187").Clear

-Range("D187").Clear

-Range("A187").Value = "xlDialogScenarioMerge"

-Range("B187").Value = 473

-Range("C187").Value = num

-B187 = Range("B187").Value

-C187 = Range("C187").Value

-If B187 = C187 Then

-Range("D187").Value = "OK"

-Else

-Range("D187").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogScenarioSummary(ByRef num)

-Range("A188").Clear

-Range("B188").Clear

-Range("C188").Clear

-Range("D188").Clear

-Range("A188").Value = "xlDialogScenarioSummary"

-Range("B188").Value = 311

-Range("C188").Value = num

-B188 = Range("B188").Value

-C188 = Range("C188").Value

-If B188 = C188 Then

-Range("D188").Value = "OK"

-Else

-Range("D188").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogScrollbarProperties(ByRef num)

-Range("A189").Clear

-Range("B189").Clear

-Range("C189").Clear

-Range("D189").Clear

-Range("A189").Value = "xlDialogScrollbarProperties"

-Range("B189").Value = 420

-Range("C189").Value = num

-B189 = Range("B189").Value

-C189 = Range("C189").Value

-If B189 = C189 Then

-Range("D189").Value = "OK"

-Else

-Range("D189").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSearch(ByRef num)

-Range("A190").Clear

-Range("B190").Clear

-Range("C190").Clear

-Range("D190").Clear

-Range("A190").Value = "xlDialogSearch"

-Range("B190").Value = 731

-Range("C190").Value = num

-B190 = Range("B190").Value

-C190 = Range("C190").Value

-If B190 = C190 Then

-Range("D190").Value = "OK"

-Else

-Range("D190").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSelectSpecial(ByRef num)

-Range("A191").Clear

-Range("B191").Clear

-Range("C191").Clear

-Range("D191").Clear

-Range("A191").Value = "xlDialogSelectSpecial"

-Range("B191").Value = 132

-Range("C191").Value = num

-B191 = Range("B191").Value

-C191 = Range("C191").Value

-If B191 = C191 Then

-Range("D191").Value = "OK"

-Else

-Range("D191").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSendMail(ByRef num)

-Range("A192").Clear

-Range("B192").Clear

-Range("C192").Clear

-Range("D192").Clear

-Range("A192").Value = "xlDialogSendMail"

-Range("B192").Value = 189

-Range("C192").Value = num

-B192 = Range("B192").Value

-C192 = Range("C192").Value

-If B192 = C192 Then

-Range("D192").Value = "OK"

-Else

-Range("D192").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSeriesAxes(ByRef num)

-Range("A193").Clear

-Range("B193").Clear

-Range("C193").Clear

-Range("D193").Clear

-Range("A193").Value = "xlDialogSeriesAxes"

-Range("B193").Value = 450

-Range("C193").Value = num

-B193 = Range("B193").Value

-C193 = Range("C193").Value

-If B193 = C193 Then

-Range("D193").Value = "OK"

-Else

-Range("D193").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSeriesOptions(ByRef num)

-Range("A194").Clear

-Range("B194").Clear

-Range("C194").Clear

-Range("D194").Clear

-Range("A194").Value = "xlDialogSeriesOptions"

-Range("B194").Value = 557

-Range("C194").Value = num

-B194 = Range("B194").Value

-C194 = Range("C194").Value

-If B194 = C194 Then

-Range("D194").Value = "OK"

-Else

-Range("D194").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSeriesOrder(ByRef num)

-Range("A195").Clear

-Range("B195").Clear

-Range("C195").Clear

-Range("D195").Clear

-Range("A195").Value = "xlDialogSeriesOrder"

-Range("B195").Value = 466

-Range("C195").Value = num

-B195 = Range("B195").Value

-C195 = Range("C195").Value

-If B195 = C195 Then

-Range("D195").Value = "OK"

-Else

-Range("D195").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSeriesShape(ByRef num)

-Range("A196").Clear

-Range("B196").Clear

-Range("C196").Clear

-Range("D196").Clear

-Range("A196").Value = "xlDialogSeriesShape"

-Range("B196").Value = 504

-Range("C196").Value = num

-B196 = Range("B196").Value

-C196 = Range("C196").Value

-If B196 = C196 Then

-Range("D196").Value = "OK"

-Else

-Range("D196").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSeriesX(ByRef num)

-Range("A197").Clear

-Range("B197").Clear

-Range("C197").Clear

-Range("D197").Clear

-Range("A197").Value = "xlDialogSeriesX"

-Range("B197").Value = 461

-Range("C197").Value = num

-B197 = Range("B197").Value

-C197 = Range("C197").Value

-If B197 = C197 Then

-Range("D197").Value = "OK"

-Else

-Range("D197").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSeriesY(ByRef num)

-Range("A198").Clear

-Range("B198").Clear

-Range("C198").Clear

-Range("D198").Clear

-Range("A198").Value = "xlDialogSeriesY"

-Range("B198").Value = 462

-Range("C198").Value = num

-B198 = Range("B198").Value

-C198 = Range("C198").Value

-If B198 = C198 Then

-Range("D198").Value = "OK"

-Else

-Range("D198").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSetBackgroundPicture(ByRef num)

-Range("A199").Clear

-Range("B199").Clear

-Range("C199").Clear

-Range("D199").Clear

-Range("A199").Value = "xlDialogSetBackgroundPicture"

-Range("B199").Value = 509

-Range("C199").Value = num

-B199 = Range("B199").Value

-C199 = Range("C199").Value

-If B199 = C199 Then

-Range("D199").Value = "OK"

-Else

-Range("D199").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSetPrintTitles(ByRef num)

-Range("A200").Clear

-Range("B200").Clear

-Range("C200").Clear

-Range("D200").Clear

-Range("A200").Value = "xlDialogSetPrintTitles"

-Range("B200").Value = 23

-Range("C200").Value = num

-B200 = Range("B200").Value

-C200 = Range("C200").Value

-If B200 = C200 Then

-Range("D200").Value = "OK"

-Else

-Range("D200").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSetUpdateStatus(ByRef num)

-Range("A201").Clear

-Range("B201").Clear

-Range("C201").Clear

-Range("D201").Clear

-Range("A201").Value = "xlDialogSetUpdateStatus"

-Range("B201").Value = 159

-Range("C201").Value = num

-B201 = Range("B201").Value

-C201 = Range("C201").Value

-If B201 = C201 Then

-Range("D201").Value = "OK"

-Else

-Range("D201").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogShowDetail(ByRef num)

-Range("A202").Clear

-Range("B202").Clear

-Range("C202").Clear

-Range("D202").Clear

-Range("A202").Value = "xlDialogShowDetail"

-Range("B202").Value = 204

-Range("C202").Value = num

-B202 = Range("B202").Value

-C202 = Range("C202").Value

-If B202 = C202 Then

-Range("D202").Value = "OK"

-Else

-Range("D202").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogShowToolbar(ByRef num)

-Range("A203").Clear

-Range("B203").Clear

-Range("C203").Clear

-Range("D203").Clear

-Range("A203").Value = "xlDialogShowToolbar"

-Range("B203").Value = 220

-Range("C203").Value = num

-B203 = Range("B203").Value

-C203 = Range("C203").Value

-If B203 = C203 Then

-Range("D203").Value = "OK"

-Else

-Range("D203").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSize(ByRef num)

-Range("A204").Clear

-Range("B204").Clear

-Range("C204").Clear

-Range("D204").Clear

-Range("A204").Value = "xlDialogSize"

-Range("B204").Value = 261

-Range("C204").Value = num

-B204 = Range("B204").Value

-C204 = Range("C204").Value

-If B204 = C204 Then

-Range("D204").Value = "OK"

-Else

-Range("D204").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSort(ByRef num)

-Range("A205").Clear

-Range("B205").Clear

-Range("C205").Clear

-Range("D205").Clear

-Range("A205").Value = "xlDialogSort"

-Range("B205").Value = 39

-Range("C205").Value = num

-B205 = Range("B205").Value

-C205 = Range("C205").Value

-If B205 = C205 Then

-Range("D205").Value = "OK"

-Else

-Range("D205").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSortSpecial(ByRef num)

-Range("A206").Clear

-Range("B206").Clear

-Range("C206").Clear

-Range("D206").Clear

-Range("A206").Value = "xlDialogSortSpecial"

-Range("B206").Value = 192

-Range("C206").Value = num

-B206 = Range("B206").Value

-C206 = Range("C206").Value

-If B206 = C206 Then

-Range("D206").Value = "OK"

-Else

-Range("D206").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSplit(ByRef num)

-Range("A207").Clear

-Range("B207").Clear

-Range("C207").Clear

-Range("D207").Clear

-Range("A207").Value = "xlDialogSplit"

-Range("B207").Value = 137

-Range("C207").Value = num

-B207 = Range("B207").Value

-C207 = Range("C207").Value

-If B207 = C207 Then

-Range("D207").Value = "OK"

-Else

-Range("D207").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogStandardFont(ByRef num)

-Range("A208").Clear

-Range("B208").Clear

-Range("C208").Clear

-Range("D208").Clear

-Range("A208").Value = "xlDialogStandardFont"

-Range("B208").Value = 190

-Range("C208").Value = num

-B208 = Range("B208").Value

-C208 = Range("C208").Value

-If B208 = C208 Then

-Range("D208").Value = "OK"

-Else

-Range("D208").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogStandardWidth(ByRef num)

-Range("A209").Clear

-Range("B209").Clear

-Range("C209").Clear

-Range("D209").Clear

-Range("A209").Value = "xlDialogStandardWidth"

-Range("B209").Value = 472

-Range("C209").Value = num

-B209 = Range("B209").Value

-C209 = Range("C209").Value

-If B209 = C209 Then

-Range("D209").Value = "OK"

-Else

-Range("D209").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogStyle(ByRef num)

-Range("A210").Clear

-Range("B210").Clear

-Range("C210").Clear

-Range("D210").Clear

-Range("A210").Value = "xlDialogStyle"

-Range("B210").Value = 44

-Range("C210").Value = num

-B210 = Range("B210").Value

-C210 = Range("C210").Value

-If B210 = C210 Then

-Range("D210").Value = "OK"

-Else

-Range("D210").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSubscribeTo(ByRef num)

-Range("A211").Clear

-Range("B211").Clear

-Range("C211").Clear

-Range("D211").Clear

-Range("A211").Value = "xlDialogSubscribeTo"

-Range("B211").Value = 218

-Range("C211").Value = num

-B211 = Range("B211").Value

-C211 = Range("C211").Value

-If B211 = C211 Then

-Range("D211").Value = "OK"

-Else

-Range("D211").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSubtotalCreate(ByRef num)

-Range("A212").Clear

-Range("B212").Clear

-Range("C212").Clear

-Range("D212").Clear

-Range("A212").Value = "xlDialogSubtotalCreate"

-Range("B212").Value = 398

-Range("C212").Value = num

-B212 = Range("B212").Value

-C212 = Range("C212").Value

-If B212 = C212 Then

-Range("D212").Value = "OK"

-Else

-Range("D212").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSummaryInfo(ByRef num)

-Range("A213").Clear

-Range("B213").Clear

-Range("C213").Clear

-Range("D213").Clear

-Range("A213").Value = "xlDialogSummaryInfo"

-Range("B213").Value = 474

-Range("C213").Value = num

-B213 = Range("B213").Value

-C213 = Range("C213").Value

-If B213 = C213 Then

-Range("D213").Value = "OK"

-Else

-Range("D213").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogTable(ByRef num)

-Range("A214").Clear

-Range("B214").Clear

-Range("C214").Clear

-Range("D214").Clear

-Range("A214").Value = "xlDialogTable"

-Range("B214").Value = 41

-Range("C214").Value = num

-B214 = Range("B214").Value

-C214 = Range("C214").Value

-If B214 = C214 Then

-Range("D214").Value = "OK"

-Else

-Range("D214").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogTabOrder(ByRef num)

-Range("A215").Clear

-Range("B215").Clear

-Range("C215").Clear

-Range("D215").Clear

-Range("A215").Value = "xlDialogTabOrder"

-Range("B215").Value = 394

-Range("C215").Value = num

-B215 = Range("B215").Value

-C215 = Range("C215").Value

-If B215 = C215 Then

-Range("D215").Value = "OK"

-Else

-Range("D215").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogTextToColumns(ByRef num)

-Range("A216").Clear

-Range("B216").Clear

-Range("C216").Clear

-Range("D216").Clear

-Range("A216").Value = "xlDialogTextToColumns"

-Range("B216").Value = 422

-Range("C216").Value = num

-B216 = Range("B216").Value

-C216 = Range("C216").Value

-If B216 = C216 Then

-Range("D216").Value = "OK"

-Else

-Range("D216").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogUnhide(ByRef num)

-Range("A217").Clear

-Range("B217").Clear

-Range("C217").Clear

-Range("D217").Clear

-Range("A217").Value = "xlDialogUnhide"

-Range("B217").Value = 94

-Range("C217").Value = num

-B217 = Range("B217").Value

-C217 = Range("C217").Value

-If B217 = C217 Then

-Range("D217").Value = "OK"

-Else

-Range("D217").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogUpdateLink(ByRef num)

-Range("A218").Clear

-Range("B218").Clear

-Range("C218").Clear

-Range("D218").Clear

-Range("A218").Value = "xlDialogUpdateLink"

-Range("B218").Value = 201

-Range("C218").Value = num

-B218 = Range("B218").Value

-C218 = Range("C218").Value

-If B218 = C218 Then

-Range("D218").Value = "OK"

-Else

-Range("D218").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogVbaInsertFile(ByRef num)

-Range("A219").Clear

-Range("B219").Clear

-Range("C219").Clear

-Range("D219").Clear

-Range("A219").Value = "xlDialogVbaInsertFile"

-Range("B219").Value = 328

-Range("C219").Value = num

-B219 = Range("B219").Value

-C219 = Range("C219").Value

-If B219 = C219 Then

-Range("D219").Value = "OK"

-Else

-Range("D219").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogVbaMakeAddin(ByRef num)

-Range("A220").Clear

-Range("B220").Clear

-Range("C220").Clear

-Range("D220").Clear

-Range("A220").Value = "xlDialogVbaMakeAddin"

-Range("B220").Value = 478

-Range("C220").Value = num

-B220 = Range("B220").Value

-C220 = Range("C220").Value

-If B220 = C220 Then

-Range("D220").Value = "OK"

-Else

-Range("D220").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogVbaProcedureDefinition(ByRef num)

-Range("A221").Clear

-Range("B221").Clear

-Range("C221").Clear

-Range("D221").Clear

-Range("A221").Value = "xlDialogVbaProcedureDefinition"

-Range("B221").Value = 330

-Range("C221").Value = num

-B221 = Range("B221").Value

-C221 = Range("C221").Value

-If B221 = C221 Then

-Range("D221").Value = "OK"

-Else

-Range("D221").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogView3d(ByRef num)

-Range("A222").Clear

-Range("B222").Clear

-Range("C222").Clear

-Range("D222").Clear

-Range("A222").Value = "xlDialogView3d"

-Range("B222").Value = 197

-Range("C222").Value = num

-B222 = Range("B222").Value

-C222 = Range("C222").Value

-If B222 = C222 Then

-Range("D222").Value = "OK"

-Else

-Range("D222").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWebOptionsBrowsers(ByRef num)

-Range("A223").Clear

-Range("B223").Clear

-Range("C223").Clear

-Range("D223").Clear

-Range("A223").Value = "xlDialogWebOptionsBrowsers"

-Range("B223").Value = 773

-Range("C223").Value = num

-B223 = Range("B223").Value

-C223 = Range("C223").Value

-If B223 = C223 Then

-Range("D223").Value = "OK"

-Else

-Range("D223").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWebOptionsEncoding(ByRef num)

-Range("A224").Clear

-Range("B224").Clear

-Range("C224").Clear

-Range("D224").Clear

-Range("A224").Value = "xlDialogWebOptionsEncoding"

-Range("B224").Value = 686

-Range("C224").Value = num

-B224 = Range("B224").Value

-C224 = Range("C224").Value

-If B224 = C224 Then

-Range("D224").Value = "OK"

-Else

-Range("D224").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWebOptionsFiles(ByRef num)

-Range("A225").Clear

-Range("B225").Clear

-Range("C225").Clear

-Range("D225").Clear

-Range("A225").Value = "xlDialogWebOptionsFiles"

-Range("B225").Value = 684

-Range("C225").Value = num

-B225 = Range("B225").Value

-C225 = Range("C225").Value

-If B225 = C225 Then

-Range("D225").Value = "OK"

-Else

-Range("D225").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWebOptionsFonts(ByRef num)

-Range("A226").Clear

-Range("B226").Clear

-Range("C226").Clear

-Range("D226").Clear

-Range("A226").Value = "xlDialogWebOptionsFonts"

-Range("B226").Value = 687

-Range("C226").Value = num

-B226 = Range("B226").Value

-C226 = Range("C226").Value

-If B226 = C226 Then

-Range("D226").Value = "OK"

-Else

-Range("D226").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWebOptionsGeneral(ByRef num)

-Range("A227").Clear

-Range("B227").Clear

-Range("C227").Clear

-Range("D227").Clear

-Range("A227").Value = "xlDialogWebOptionsGeneral"

-Range("B227").Value = 683

-Range("C227").Value = num

-B227 = Range("B227").Value

-C227 = Range("C227").Value

-If B227 = C227 Then

-Range("D227").Value = "OK"

-Else

-Range("D227").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWebOptionsPictures(ByRef num)

-Range("A228").Clear

-Range("B228").Clear

-Range("C228").Clear

-Range("D228").Clear

-Range("A228").Value = "xlDialogWebOptionsPictures"

-Range("B228").Value = 685

-Range("C228").Value = num

-B228 = Range("B228").Value

-C228 = Range("C228").Value

-If B228 = C228 Then

-Range("D228").Value = "OK"

-Else

-Range("D228").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWindowMove(ByRef num)

-Range("A229").Clear

-Range("B229").Clear

-Range("C229").Clear

-Range("D229").Clear

-Range("A229").Value = "xlDialogWindowMove"

-Range("B229").Value = 14

-Range("C229").Value = num

-B229 = Range("B229").Value

-C229 = Range("C229").Value

-If B229 = C229 Then

-Range("D229").Value = "OK"

-Else

-Range("D229").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWindowSize(ByRef num)

-Range("A230").Clear

-Range("B230").Clear

-Range("C230").Clear

-Range("D230").Clear

-Range("A230").Value = "xlDialogWindowSize"

-Range("B230").Value = 13

-Range("C230").Value = num

-B230 = Range("B230").Value

-C230 = Range("C230").Value

-If B230 = C230 Then

-Range("D230").Value = "OK"

-Else

-Range("D230").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWorkbookAdd(ByRef num)

-Range("A231").Clear

-Range("B231").Clear

-Range("C231").Clear

-Range("D231").Clear

-Range("A231").Value = "xlDialogWorkbookAdd"

-Range("B231").Value = 281

-Range("C231").Value = num

-B231 = Range("B231").Value

-C231 = Range("C231").Value

-If B231 = C231 Then

-Range("D231").Value = "OK"

-Else

-Range("D231").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWorkbookCopy(ByRef num)

-Range("A232").Clear

-Range("B232").Clear

-Range("C232").Clear

-Range("D232").Clear

-Range("A232").Value = "xlDialogWorkbookCopy"

-Range("B232").Value = 283

-Range("C232").Value = num

-B232 = Range("B232").Value

-C232 = Range("C232").Value

-If B232 = C232 Then

-Range("D232").Value = "OK"

-Else

-Range("D232").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWorkbookInsert(ByRef num)

-Range("A233").Clear

-Range("B233").Clear

-Range("C233").Clear

-Range("D233").Clear

-Range("A233").Value = "xlDialogWorkbookInsert"

-Range("B233").Value = 354

-Range("C233").Value = num

-B233 = Range("B233").Value

-C233 = Range("C233").Value

-If B233 = C233 Then

-Range("D233").Value = "OK"

-Else

-Range("D233").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWorkbookMove(ByRef num)

-Range("A234").Clear

-Range("B234").Clear

-Range("C234").Clear

-Range("D234").Clear

-Range("A234").Value = "xlDialogWorkbookMove"

-Range("B234").Value = 282

-Range("C234").Value = num

-B234 = Range("B234").Value

-C234 = Range("C234").Value

-If B234 = C234 Then

-Range("D234").Value = "OK"

-Else

-Range("D234").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWorkbookName(ByRef num)

-Range("A235").Clear

-Range("B235").Clear

-Range("C235").Clear

-Range("D235").Clear

-Range("A235").Value = "xlDialogWorkbookName"

-Range("B235").Value = 386

-Range("C235").Value = num

-B235 = Range("B235").Value

-C235 = Range("C235").Value

-If B235 = C235 Then

-Range("D235").Value = "OK"

-Else

-Range("D235").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWorkbookNew(ByRef num)

-Range("A236").Clear

-Range("B236").Clear

-Range("C236").Clear

-Range("D236").Clear

-Range("A236").Value = "xlDialogWorkbookNew"

-Range("B236").Value = 302

-Range("C236").Value = num

-B236 = Range("B236").Value

-C236 = Range("C236").Value

-If B236 = C236 Then

-Range("D236").Value = "OK"

-Else

-Range("D236").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWorkbookOptions(ByRef num)

-Range("A237").Clear

-Range("B237").Clear

-Range("C237").Clear

-Range("D237").Clear

-Range("A237").Value = "xlDialogWorkbookOptions"

-Range("B237").Value = 284

-Range("C237").Value = num

-B237 = Range("B237").Value

-C237 = Range("C237").Value

-If B237 = C237 Then

-Range("D237").Value = "OK"

-Else

-Range("D237").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWorkbookProtect(ByRef num)

-Range("A238").Clear

-Range("B238").Clear

-Range("C238").Clear

-Range("D238").Clear

-Range("A238").Value = "xlDialogWorkbookProtect"

-Range("B238").Value = 417

-Range("C238").Value = num

-B238 = Range("B238").Value

-C238 = Range("C238").Value

-If B238 = C238 Then

-Range("D238").Value = "OK"

-Else

-Range("D238").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWorkbookTabSplit(ByRef num)

-Range("A239").Clear

-Range("B239").Clear

-Range("C239").Clear

-Range("D239").Clear

-Range("A239").Value = "xlDialogWorkbookTabSplit"

-Range("B239").Value = 415

-Range("C239").Value = num

-B239 = Range("B239").Value

-C239 = Range("C239").Value

-If B239 = C239 Then

-Range("D239").Value = "OK"

-Else

-Range("D239").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWorkbookUnhide(ByRef num)

-Range("A240").Clear

-Range("B240").Clear

-Range("C240").Clear

-Range("D240").Clear

-Range("A240").Value = "xlDialogWorkbookUnhide"

-Range("B240").Value = 384

-Range("C240").Value = num

-B240 = Range("B240").Value

-C240 = Range("C240").Value

-If B240 = C240 Then

-Range("D240").Value = "OK"

-Else

-Range("D240").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWorkgroup(ByRef num)

-Range("A241").Clear

-Range("B241").Clear

-Range("C241").Clear

-Range("D241").Clear

-Range("A241").Value = "xlDialogWorkgroup"

-Range("B241").Value = 199

-Range("C241").Value = num

-B241 = Range("B241").Value

-C241 = Range("C241").Value

-If B241 = C241 Then

-Range("D241").Value = "OK"

-Else

-Range("D241").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogWorkspace(ByRef num)

-Range("A242").Clear

-Range("B242").Clear

-Range("C242").Clear

-Range("D242").Clear

-Range("A242").Value = "xlDialogWorkspace"

-Range("B242").Value = 95

-Range("C242").Value = num

-B242 = Range("B242").Value

-C242 = Range("C242").Value

-If B242 = C242 Then

-Range("D242").Value = "OK"

-Else

-Range("D242").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogZoom(ByRef num)

-Range("A243").Clear

-Range("B243").Clear

-Range("C243").Clear

-Range("D243").Clear

-Range("A243").Value = "xlDialogZoom"

-Range("B243").Value = 256

-Range("C243").Value = num

-B243 = Range("B243").Value

-C243 = Range("C243").Value

-If B243 = C243 Then

-Range("D243").Value = "OK"

-Else

-Range("D243").Value = "NG"

-End If

-End Function

-

-<<<<<<
-======================
-Module4
->>>>>>
-Attribute VB_Name = "Module4"

-

-Sub main_4()

-test_xlErrDiv0 (xlErrDiv0)

-test_xlErrNA (xlErrNA)

-test_xlErrName (xlErrName)

-test_xlErrNull (xlErrNull)

-test_xlErrNum (xlErrNum)

-test_xlErrRef (xlErrRef)

-test_xlErrValue (xlErrValue)

-test_xlCalculatedMember (xlCalculatedMember)

-test_xlCalculatedSet (xlCalculatedSet)

-test_xlCalculationAutomatic (xlCalculationAutomatic)

-test_xlCalculationManual (xlCalculationManual)

-test_xlCalculationSemiautomatic (xlCalculationSemiautomatic)

-test_xlAnyKey (xlAnyKey)

-test_xlEscKey (xlEscKey)

-test_xlNoKey (xlNoKey)

-test_xlCalculating (xlCalculating)

-test_xlDone (xlDone)

-test_xlPending (xlPending)

-test_xlAutomaticScale (xlAutomaticScale)

-test_xlCategoryScale (xlCategoryScale)

-test_xlTimeScale (xlTimeScale)

-test_xlInsertDeleteCells (xlInsertDeleteCells)

-test_xlInsertEntireRows (xlInsertEntireRows)

-test_xlOverwriteCells (xlOverwriteCells)

-test_xlCellTypeAllFormatConditions (xlCellTypeAllFormatConditions)

-test_xlCellTypeAllValidation (xlCellTypeAllValidation)

-test_xlCellTypeBlanks (xlCellTypeBlanks)

-test_xlCellTypeComments (xlCellTypeComments)

-test_xlCellTypeConstants (xlCellTypeConstants)

-test_xlCellTypeFormulas (xlCellTypeFormulas)

-test_xlCellTypeLastCell (xlCellTypeLastCell)

-test_xlCellTypeSameFormatConditions (xlCellTypeSameFormatConditions)

-test_xlCellTypeSameValidation (xlCellTypeSameValidation)

-test_xlCellTypeVisible (xlCellTypeVisible)

-test_xlAnyGallery (xlAnyGallery)

-test_xlBuildIn (xlBuildIn)

-test_xlUserDefined (xlUserDefined)

-test_xlAxis (xlAxis)

-test_xlAxisTitle (xlAxisTitle)

-test_xlChartTitle (xlChartTitle)

-test_xlCorners (xlCorners)

-test_xlDataLabel (xlDataLabel)

-test_xlDataTable (xlDataTable)

-test_xlDisplayUnitLabel (xlDisplayUnitLabel)

-test_xlDownBars (xlDownBars)

-test_xlDropLines (xlDropLines)

-test_xlErrorBars (xlErrorBars)

-test_xlFloor (xlFloor)

-test_xlHiLoLines (xlHiLoLines)

-test_xlLeaderLines (xlLeaderLines)

-test_xlLegend (xlLegend)

-test_xlLegendEntry (xlLegendEntry)

-test_xlLegendKey (xlLegendKey)

-test_xlMajorGridlines (xlMajorGridlines)

-test_xlMinorGridlines (xlMinorGridlines)

-test_xlNothing (xlNothing)

-test_xlPivotChartDropZone (xlPivotChartDropZone)

-test_xlPivotChartFieldButton (xlPivotChartFieldButton)

-test_xlPlotArea (xlPlotArea)

-test_xlRaderAxisLabels (xlRaderAxisLabels)

-test_xlSeries (xlSeries)

-test_xlSeriesLines (xlSeriesLines)

-test_xlShape (xlShape)

-test_xlTrendline (xlTrendline)

-test_xlUpBars (xlUpBars)

-test_xlWalls (xlWalls)

-test_xlXErrorBars (xlXErrorBars)

-test_xlYErrorBars (xlYErrorBars)

-test_xlLocationAsNewSheet (xlLocationAsNewSheet)

-test_xlLocationAsObject (xlLocationAsObject)

-test_xlLocationAutomatic (xlLocationAutomatic)

-test_xlAllFaces (xlAllFaces)

-test_xlEnd (xlEnd)

-test_xlEndSides (xlEndSides)

-test_xlFront (xlFront)

-test_xlFrontEnd (xlFrontEnd)

-test_xlFrontSides (xlFrontSides)

-test_xlSlides (xlSlides)

-test_xlStack (xlStack)

-test_xlStackScale (xlStackScale)

-test_xlStretch (xlStretch)

-test_xlSplitByCustomSplit (xlSplitByCustomSplit)

-test_xlSplitByPercentValue (xlSplitByPercentValue)

-test_xlSplitByPercentPosition (xlSplitByPercentPosition)

-test_xlSplitByValue (xlSplitByValue)

-test_xl3DArea (xl3DArea)

-test_xl3DAreaStacked (xl3DAreaStacked)

-test_xl3DAreaStacked100 (xl3DAreaStacked100)

-test_xl3DBarClustered (xl3DBarClustered)

-test_xl3DBarStacked (xl3DBarStacked)

-test_xl3DBarStacked100 (xl3DBarStacked100)

-test_xl3DColumn (xl3DColumn)

-test_xl3DColumnClustered (xl3DColumnClustered)

-test_xl3DColumnStacked (xl3DColumnStacked)

-test_xl3DColumnStacked100 (xl3DColumnStacked100)

-test_xl3DLine (xl3DLine)

-test_xl3DPie (xl3DPie)

-test_xl3DPieExploded (xl3DPieExploded)

-test_xlArea (xlArea)

-test_xlAreaStacked (xlAreaStacked)

-test_xlAreaStacked100 (xlAreaStacked100)

-test_xlBarClustered (xlBarClustered)

-test_xlBarOfPie (xlBarOfPie)

-test_xlBarStacked (xlBarStacked)

-test_xlBarStacked100 (xlBarStacked100)

-test_xlBubble (xlBubble)

-test_xlBubble3DEffect (xlBubble3DEffect)

-test_xlColumnClustered (xlColumnClustered)

-test_xlColumnStacked (xlColumnStacked)

-test_xlColumnStacked100 (xlColumnStacked100)

-test_xlConeBarClustered (xlConeBarClustered)

-test_xlConeBarStacked (xlConeBarStacked)

-test_xlConeBarStacked100 (xlConeBarStacked100)

-test_xlConeCol (xlConeCol)

-test_xlConeColClustered (xlConeColClustered)

-test_xlConeColStacked (xlConeColStacked)

-test_xlConeColStacked100 (xlConeColStacked100)

-test_xlCylinderBarClustered (xlCylinderBarClustered)

-test_xlCylinderBarStacked (xlCylinderBarStacked)

-test_xlCylinderBarStacked100 (xlCylinderBarStacked100)

-test_xlCylinderCol (xlCylinderCol)

-test_xlCylinderColClustered (xlCylinderColClustered)

-test_xlCylinderColStacked (xlCylinderColStacked)

-test_xlCylinderColStacked100 (xlCylinderColStacked100)

-test_xlDoughnut (xlDoughnut)

-test_xlDoughnutExploded (xlDoughnutExploded)

-test_xlLine (xlLine)

-test_xlLineMarkers (xlLineMarkers)

-test_xlLineMarkersStacked (xlLineMarkersStacked)

-test_xlLineMarkersStacked100 (xlLineMarkersStacked100)

-test_xlLineStacked (xlLineStacked)

-test_xlLineStacked100 (xlLineStacked100)

-test_xlPie (xlPie)

-test_xlPieExploded (xlPieExploded)

-test_xlPieOfPie (xlPieOfPie)

-test_xlPyramidBarClustered (xlPyramidBarClustered)

-test_xlPyramidBarStacked (xlPyramidBarStacked)

-test_xlPyramidBarStacked100 (xlPyramidBarStacked100)

-test_xlPyramidCol (xlPyramidCol)

-test_xlPyramidColClustered (xlPyramidColClustered)

-test_xlPyramidColStacked (xlPyramidColStacked)

-test_xlPyramidColStacked100 (xlPyramidColStacked100)

-test_xlRader (xlRader)

-test_xlRaderFilled (xlRaderFilled)

-test_xlRaderMarkers (xlRaderMarkers)

-test_xlStockHLC (xlStockHLC)

-test_xlStockOHLC (xlStockOHLC)

-test_xlStockVHLC (xlStockVHLC)

-test_xlStockVOHLC (xlStockVOHLC)

-test_xlSurface (xlSurface)

-test_xlSurfaceTopView (xlSurfaceTopView)

-test_xlSurfaceTopViewWireframe (xlSurfaceTopViewWireframe)

-test_xlSurfaceWireframe (xlSurfaceWireframe)

-test_xlXYScatter (xlXYScatter)

-test_xlXYScatterLines (xlXYScatterLines)

-test_xlXYScatterLinesNoMarkers (xlXYScatterLinesNoMarkers)

-test_xlXYScatterSmooth (xlXYScatterSmooth)

-test_xlXYScatterSmoothNoMarkers (xlXYScatterSmoothNoMarkers)

-test_xlClipboardFormatBIFF (xlClipboardFormatBIFF)

-test_xlClipboardFormatBIFF2 (xlClipboardFormatBIFF2)

-test_xlClipboardFormatBIFF3 (xlClipboardFormatBIFF3)

-test_xlClipboardFormatBIFF4 (xlClipboardFormatBIFF4)

-test_xlClipboardFormatBinary (xlClipboardFormatBinary)

-test_xlClipboardFormatBitmap (xlClipboardFormatBitmap)

-test_xlClipboardFormatCGM (xlClipboardFormatCGM)

-test_xlClipboardFormatCSV (xlClipboardFormatCSV)

-test_xlClipboardFormatDIF (xlClipboardFormatDIF)

-test_xlClipboardFormatDspText (xlClipboardFormatDspText)

-test_xlClipboardFormatEmbeddedObject (xlClipboardFormatEmbeddedObject)

-test_xlClipboardFormatEmbedSource (xlClipboardFormatEmbedSource)

-test_xlClipboardFormatLink (xlClipboardFormatLink)

-test_xlClipboardFormatLinkSource (xlClipboardFormatLinkSource)

-test_xlClipboardFormatLinkSourceDesc (xlClipboardFormatLinkSourceDesc)

-test_xlClipboardFormatMovie (xlClipboardFormatMovie)

-test_xlClipboardFormatNative (xlClipboardFormatNative)

-test_xlClipboardFormatObjectDesc (xlClipboardFormatObjectDesc)

-test_xlClipboardFormatObjectLink (xlClipboardFormatObjectLink)

-test_xlClipboardFormatOwnerLink (xlClipboardFormatOwnerLink)

-test_xlClipboardFormatPICT (xlClipboardFormatPICT)

-test_xlClipboardFormatPrintPICT (xlClipboardFormatPrintPICT)

-test_xlClipboardFormatRTF (xlClipboardFormatRTF)

-test_xlClipboardFormatScreenPICT (xlClipboardFormatScreenPICT)

-test_xlClipboardFormatStandardFont (xlClipboardFormatStandardFont)

-test_xlClipboardFormatStandardScale (xlClipboardFormatStandardScale)

-test_xlClipboardFormatSYLK (xlClipboardFormatSYLK)

-test_xlClipboardFormatTable (xlClipboardFormatTable)

-test_xlClipboardFormatText (xlClipboardFormatText)

-test_xlClipboardFormatToolFace (xlClipboardFormatToolFace)

-test_xlClipboardFormatToolFacePICT (xlClipboardFormatToolFacePICT)

-test_xlClipboardFormatToolVALU (xlClipboardFormatToolVALU)

-test_xlClipboardFormatToolWK1 (xlClipboardFormatToolWK1)

-test_xlCmdCube (xlCmdCube)

-test_xlCmdDefault (xlCmdDefault)

-test_xlCmdList (xlCmdList)

-test_xlCmdSql (xlCmdSql)

-test_xlCmdTable (xlCmdTable)

-test_xlColorIndexAutomatic (xlColorIndexAutomatic)

-test_xlColorIndexNone (xlColorIndexNone)

-test_xlDMYFormat (xlDMYFormat)

-test_xlDYMFormat (xlDYMFormat)

-test_xlEMDFormat (xlEMDFormat)

-test_xlGeneralFormat (xlGeneralFormat)

-test_xlMDYFormat (xlMDYFormat)

-test_xlMYDFormat (xlMYDFormat)

-test_xlSkipColumn (xlSkipColumn)

-test_xlTextFormat (xlTextFormat)

-test_xlYDMFormat (xlYDMFormat)

-test_xlYMDFormat (xlYMDFormat)

-test_xlCommandUnderlinesAutomatic (xlCommandUnderlinesAutomatic)

-test_xlCommandUnderlinesOff (xlCommandUnderlinesOff)

-test_xlCommandUnderlinesOn (xlCommandUnderlinesOn)

-test_xlCommentAndIndicator (xlCommentAndIndicator)

-test_xlCommentIndicatorOnly (xlCommentIndicatorOnly)

-test_xlNoIndicator (xlNoIndicator)

-test_xlAverage (xlAverage)

-test_xlCount (xlCount)

-test_xlCountNums (xlCountNums)

-test_xlMax (xlMax)

-test_xlMin (xlMin)

-test_xlProduct (xlProduct)

-test_xlStDev (xlStDev)

-test_xlStDevP (xlStDevP)

-test_xlSum (xlSum)

-test_xlUnknown (xlUnknown)

-test_xlVar (xlVar)

-test_xlVarP (xlVarP)

-test_xlBitmap (xlBitmap)

-test_xlPicture (xlPicture)

-test_xlExtractData (xlExtractData)

-test_xlNormalLoad (xlNormalLoad)

-test_xlRepairFile (xlRepairFile)

-test_xlCreatorCode (xlCreatorCode)

-test_xlHierarchy (xlHierarchy)

-test_xlMeasure (xlMeasure)

-test_xlSet (xlSet)

-test_xlCopy (xlCopy)

-test_xlCut (xlCut)

-test_xlValidAlterInformation (xlValidAlterInformation)

-test_xlValidAlterStop (xlValidAlterStop)

-test_xlValidAlterWarning (xlValidAlterWarning)

-test_xlValidateCustom (xlValidateCustom)

-test_xlValidateDate (xlValidateDate)

-test_xlValidateDecimal (xlValidateDecimal)

-test_xlValidateInputOnly (xlValidateInputOnly)

-test_xlValidateList (xlValidateList)

-test_xlValidateTextLength (xlValidateTextLength)

-test_xlValidateTime (xlValidateTime)

-test_xlValidateWholeNumber (xlValidateWholeNumber)

-test_xlLabelPositionAbove (xlLabelPositionAbove)

-test_xlLabelPositionBelow (xlLabelPositionBelow)

-test_xlLabelPositionBestFit (xlLabelPositionBestFit)

-test_xlLabelPositionBestCenter (xlLabelPositionBestCenter)

-test_xlLabelPositionBestCustom (xlLabelPositionBestCustom)

-test_xlLabelPositionInsideBase (xlLabelPositionInsideBase)

-test_xlLabelPositionInsideEnd (xlLabelPositionInsideEnd)

-test_xlLabelPositionInsideLeft (xlLabelPositionInsideLeft)

-test_xlLabelPositionMixed (xlLabelPositionMixed)

-test_xlLabelPositionOutsideEnd (xlLabelPositionOutsideEnd)

-test_xlLabelPositionRight (xlLabelPositionRight)

-test_xlDataLabelSeparatorDefault (xlDataLabelSeparatorDefault)

-test_xlDataLabelsShowBubbleSizes (xlDataLabelsShowBubbleSizes)

-test_xlDataLabelsShowLabel (xlDataLabelsShowLabel)

-test_xlDataLabelsShowLabelAndPercent (xlDataLabelsShowLabelAndPercent)

-test_xlDataLabelsShowNone (xlDataLabelsShowNone)

-test_xlDataLabelsShowPercent (xlDataLabelsShowPercent)

-test_xlDataLabelsShowValue (xlDataLabelsShowValue)

-test_xlDay (xlDay)

-test_xlMonth (xlMonth)

-test_xlWeekday (xlWeekday)

-test_xlYear (xlYear)

-test_xlAutoFill (xlAutoFill)

-test_xlChronological (xlChronological)

-test_xlDataSeriesLinear (xlDataSeriesLinear)

-test_xlGrowth (xlGrowth)

-test_xlShiftToLeft (xlShiftToLeft)

-test_xlShiftUp (xlShiftUp)

-test_xlDown (xlDown)

-test_xlToLeft (xlToLeft)

-test_xlToRight (xlToRight)

-test_xlUp (xlUp)

-test_xlInterpolated (xlInterpolated)

-test_xlNotPlotted (xlNotPlotted)

-test_xlZero (xlZero)

-test_xlDisplayShapes (xlDisplayShapes)

-test_xlHide (xlHide)

-test_xlPlaceholders (xlPlaceholders)

-test_xlHundredMillions (xlHundredMillions)

-test_xlHundreds (xlHundreds)

-test_xlHundredThousands (xlHundredThousands)

-test_xlMillionMillons (xlMillionMillons)

-test_xlMillions (xlMillions)

-test_xlTenMillions (xlTenMillions)

-test_xlTenThousands (xlTenThousands)

-test_xlThousandMillions (xlThousandMillions)

-test_xlThousands (xlThousands)

-Range("A1").Value = "constant name"

-Range("B1").Value = "OOo result"

-Range("C1").Value = "Excel result"

-Range("D1").Value = "Correct?"

-End Sub

-

-Function test_xlErrDiv0(ByRef num)

-Range("A2").Clear

-Range("B2").Clear

-Range("C2").Clear

-Range("D2").Clear

-Range("A2").Value = "xlErrDiv0"

-Range("B2").Value = 2007

-Range("C2").Value = num

-B2 = Range("B2").Value

-C2 = Range("C2").Value

-If B2 = C2 Then

-Range("D2").Value = "OK"

-Else

-Range("D2").Value = "NG"

-End If

-End Function

-

-Function test_xlErrNA(ByRef num)

-Range("A3").Clear

-Range("B3").Clear

-Range("C3").Clear

-Range("D3").Clear

-Range("A3").Value = "xlErrNA"

-Range("B3").Value = 2042

-Range("C3").Value = num

-B3 = Range("B3").Value

-C3 = Range("C3").Value

-If B3 = C3 Then

-Range("D3").Value = "OK"

-Else

-Range("D3").Value = "NG"

-End If

-End Function

-

-Function test_xlErrName(ByRef num)

-Range("A4").Clear

-Range("B4").Clear

-Range("C4").Clear

-Range("D4").Clear

-Range("A4").Value = "xlErrName"

-Range("B4").Value = 2029

-Range("C4").Value = num

-B4 = Range("B4").Value

-C4 = Range("C4").Value

-If B4 = C4 Then

-Range("D4").Value = "OK"

-Else

-Range("D4").Value = "NG"

-End If

-End Function

-

-Function test_xlErrNull(ByRef num)

-Range("A5").Clear

-Range("B5").Clear

-Range("C5").Clear

-Range("D5").Clear

-Range("A5").Value = "xlErrNull"

-Range("B5").Value = 2000

-Range("C5").Value = num

-B5 = Range("B5").Value

-C5 = Range("C5").Value

-If B5 = C5 Then

-Range("D5").Value = "OK"

-Else

-Range("D5").Value = "NG"

-End If

-End Function

-

-Function test_xlErrNum(ByRef num)

-Range("A6").Clear

-Range("B6").Clear

-Range("C6").Clear

-Range("D6").Clear

-Range("A6").Value = "xlErrNum"

-Range("B6").Value = 2036

-Range("C6").Value = num

-B6 = Range("B6").Value

-C6 = Range("C6").Value

-If B6 = C6 Then

-Range("D6").Value = "OK"

-Else

-Range("D6").Value = "NG"

-End If

-End Function

-

-Function test_xlErrRef(ByRef num)

-Range("A7").Clear

-Range("B7").Clear

-Range("C7").Clear

-Range("D7").Clear

-Range("A7").Value = "xlErrRef"

-Range("B7").Value = 2023

-Range("C7").Value = num

-B7 = Range("B7").Value

-C7 = Range("C7").Value

-If B7 = C7 Then

-Range("D7").Value = "OK"

-Else

-Range("D7").Value = "NG"

-End If

-End Function

-

-Function test_xlErrValue(ByRef num)

-Range("A8").Clear

-Range("B8").Clear

-Range("C8").Clear

-Range("D8").Clear

-Range("A8").Value = "xlErrValue"

-Range("B8").Value = 2015

-Range("C8").Value = num

-B8 = Range("B8").Value

-C8 = Range("C8").Value

-If B8 = C8 Then

-Range("D8").Value = "OK"

-Else

-Range("D8").Value = "NG"

-End If

-End Function

-

-Function test_xlCalculatedMember(ByRef num)

-Range("A9").Clear

-Range("B9").Clear

-Range("C9").Clear

-Range("D9").Clear

-Range("A9").Value = "xlCalculatedMember"

-Range("B9").Value = 0

-Range("C9").Value = num

-B9 = Range("B9").Value

-C9 = Range("C9").Value

-If B9 = C9 Then

-Range("D9").Value = "OK"

-Else

-Range("D9").Value = "NG"

-End If

-End Function

-

-Function test_xlCalculatedSet(ByRef num)

-Range("A10").Clear

-Range("B10").Clear

-Range("C10").Clear

-Range("D10").Clear

-Range("A10").Value = "xlCalculatedSet"

-Range("B10").Value = 1

-Range("C10").Value = num

-B10 = Range("B10").Value

-C10 = Range("C10").Value

-If B10 = C10 Then

-Range("D10").Value = "OK"

-Else

-Range("D10").Value = "NG"

-End If

-End Function

-

-Function test_xlCalculationAutomatic(ByRef num)

-Range("A11").Clear

-Range("B11").Clear

-Range("C11").Clear

-Range("D11").Clear

-Range("A11").Value = "xlCalculationAutomatic"

-Range("B11").Value = -4105

-Range("C11").Value = num

-B11 = Range("B11").Value

-C11 = Range("C11").Value

-If B11 = C11 Then

-Range("D11").Value = "OK"

-Else

-Range("D11").Value = "NG"

-End If

-End Function

-

-Function test_xlCalculationManual(ByRef num)

-Range("A12").Clear

-Range("B12").Clear

-Range("C12").Clear

-Range("D12").Clear

-Range("A12").Value = "xlCalculationManual"

-Range("B12").Value = -4135

-Range("C12").Value = num

-B12 = Range("B12").Value

-C12 = Range("C12").Value

-If B12 = C12 Then

-Range("D12").Value = "OK"

-Else

-Range("D12").Value = "NG"

-End If

-End Function

-

-Function test_xlCalculationSemiautomatic(ByRef num)

-Range("A13").Clear

-Range("B13").Clear

-Range("C13").Clear

-Range("D13").Clear

-Range("A13").Value = "xlCalculationSemiautomatic"

-Range("B13").Value = 2

-Range("C13").Value = num

-B13 = Range("B13").Value

-C13 = Range("C13").Value

-If B13 = C13 Then

-Range("D13").Value = "OK"

-Else

-Range("D13").Value = "NG"

-End If

-End Function

-

-Function test_xlAnyKey(ByRef num)

-Range("A14").Clear

-Range("B14").Clear

-Range("C14").Clear

-Range("D14").Clear

-Range("A14").Value = "xlAnyKey"

-Range("B14").Value = 2

-Range("C14").Value = num

-B14 = Range("B14").Value

-C14 = Range("C14").Value

-If B14 = C14 Then

-Range("D14").Value = "OK"

-Else

-Range("D14").Value = "NG"

-End If

-End Function

-

-Function test_xlEscKey(ByRef num)

-Range("A15").Clear

-Range("B15").Clear

-Range("C15").Clear

-Range("D15").Clear

-Range("A15").Value = "xlEscKey"

-Range("B15").Value = 1

-Range("C15").Value = num

-B15 = Range("B15").Value

-C15 = Range("C15").Value

-If B15 = C15 Then

-Range("D15").Value = "OK"

-Else

-Range("D15").Value = "NG"

-End If

-End Function

-

-Function test_xlNoKey(ByRef num)

-Range("A16").Clear

-Range("B16").Clear

-Range("C16").Clear

-Range("D16").Clear

-Range("A16").Value = "xlNoKey"

-Range("B16").Value = 0

-Range("C16").Value = num

-B16 = Range("B16").Value

-C16 = Range("C16").Value

-If B16 = C16 Then

-Range("D16").Value = "OK"

-Else

-Range("D16").Value = "NG"

-End If

-End Function

-

-Function test_xlCalculating(ByRef num)

-Range("A17").Clear

-Range("B17").Clear

-Range("C17").Clear

-Range("D17").Clear

-Range("A17").Value = "xlCalculating"

-Range("B17").Value = 1

-Range("C17").Value = num

-B17 = Range("B17").Value

-C17 = Range("C17").Value

-If B17 = C17 Then

-Range("D17").Value = "OK"

-Else

-Range("D17").Value = "NG"

-End If

-End Function

-

-Function test_xlDone(ByRef num)

-Range("A18").Clear

-Range("B18").Clear

-Range("C18").Clear

-Range("D18").Clear

-Range("A18").Value = "xlDone"

-Range("B18").Value = 0

-Range("C18").Value = num

-B18 = Range("B18").Value

-C18 = Range("C18").Value

-If B18 = C18 Then

-Range("D18").Value = "OK"

-Else

-Range("D18").Value = "NG"

-End If

-End Function

-

-Function test_xlPending(ByRef num)

-Range("A19").Clear

-Range("B19").Clear

-Range("C19").Clear

-Range("D19").Clear

-Range("A19").Value = "xlPending"

-Range("B19").Value = 2

-Range("C19").Value = num

-B19 = Range("B19").Value

-C19 = Range("C19").Value

-If B19 = C19 Then

-Range("D19").Value = "OK"

-Else

-Range("D19").Value = "NG"

-End If

-End Function

-

-Function test_xlAutomaticScale(ByRef num)

-Range("A20").Clear

-Range("B20").Clear

-Range("C20").Clear

-Range("D20").Clear

-Range("A20").Value = "xlAutomaticScale"

-Range("B20").Value = -4105

-Range("C20").Value = num

-B20 = Range("B20").Value

-C20 = Range("C20").Value

-If B20 = C20 Then

-Range("D20").Value = "OK"

-Else

-Range("D20").Value = "NG"

-End If

-End Function

-

-Function test_xlCategoryScale(ByRef num)

-Range("A21").Clear

-Range("B21").Clear

-Range("C21").Clear

-Range("D21").Clear

-Range("A21").Value = "xlCategoryScale"

-Range("B21").Value = 2

-Range("C21").Value = num

-B21 = Range("B21").Value

-C21 = Range("C21").Value

-If B21 = C21 Then

-Range("D21").Value = "OK"

-Else

-Range("D21").Value = "NG"

-End If

-End Function

-

-Function test_xlTimeScale(ByRef num)

-Range("A22").Clear

-Range("B22").Clear

-Range("C22").Clear

-Range("D22").Clear

-Range("A22").Value = "xlTimeScale"

-Range("B22").Value = 3

-Range("C22").Value = num

-B22 = Range("B22").Value

-C22 = Range("C22").Value

-If B22 = C22 Then

-Range("D22").Value = "OK"

-Else

-Range("D22").Value = "NG"

-End If

-End Function

-

-Function test_xlInsertDeleteCells(ByRef num)

-Range("A23").Clear

-Range("B23").Clear

-Range("C23").Clear

-Range("D23").Clear

-Range("A23").Value = "xlInsertDeleteCells"

-Range("B23").Value = 1

-Range("C23").Value = num

-B23 = Range("B23").Value

-C23 = Range("C23").Value

-If B23 = C23 Then

-Range("D23").Value = "OK"

-Else

-Range("D23").Value = "NG"

-End If

-End Function

-

-Function test_xlInsertEntireRows(ByRef num)

-Range("A24").Clear

-Range("B24").Clear

-Range("C24").Clear

-Range("D24").Clear

-Range("A24").Value = "xlInsertEntireRows"

-Range("B24").Value = 2

-Range("C24").Value = num

-B24 = Range("B24").Value

-C24 = Range("C24").Value

-If B24 = C24 Then

-Range("D24").Value = "OK"

-Else

-Range("D24").Value = "NG"

-End If

-End Function

-

-Function test_xlOverwriteCells(ByRef num)

-Range("A25").Clear

-Range("B25").Clear

-Range("C25").Clear

-Range("D25").Clear

-Range("A25").Value = "xlOverwriteCells"

-Range("B25").Value = 0

-Range("C25").Value = num

-B25 = Range("B25").Value

-C25 = Range("C25").Value

-If B25 = C25 Then

-Range("D25").Value = "OK"

-Else

-Range("D25").Value = "NG"

-End If

-End Function

-

-Function test_xlCellTypeAllFormatConditions(ByRef num)

-Range("A26").Clear

-Range("B26").Clear

-Range("C26").Clear

-Range("D26").Clear

-Range("A26").Value = "xlCellTypeAllFormatConditions"

-Range("B26").Value = -4172

-Range("C26").Value = num

-B26 = Range("B26").Value

-C26 = Range("C26").Value

-If B26 = C26 Then

-Range("D26").Value = "OK"

-Else

-Range("D26").Value = "NG"

-End If

-End Function

-

-Function test_xlCellTypeAllValidation(ByRef num)

-Range("A27").Clear

-Range("B27").Clear

-Range("C27").Clear

-Range("D27").Clear

-Range("A27").Value = "xlCellTypeAllValidation"

-Range("B27").Value = -4174

-Range("C27").Value = num

-B27 = Range("B27").Value

-C27 = Range("C27").Value

-If B27 = C27 Then

-Range("D27").Value = "OK"

-Else

-Range("D27").Value = "NG"

-End If

-End Function

-

-Function test_xlCellTypeBlanks(ByRef num)

-Range("A28").Clear

-Range("B28").Clear

-Range("C28").Clear

-Range("D28").Clear

-Range("A28").Value = "xlCellTypeBlanks"

-Range("B28").Value = 4

-Range("C28").Value = num

-B28 = Range("B28").Value

-C28 = Range("C28").Value

-If B28 = C28 Then

-Range("D28").Value = "OK"

-Else

-Range("D28").Value = "NG"

-End If

-End Function

-

-Function test_xlCellTypeComments(ByRef num)

-Range("A29").Clear

-Range("B29").Clear

-Range("C29").Clear

-Range("D29").Clear

-Range("A29").Value = "xlCellTypeComments"

-Range("B29").Value = -4144

-Range("C29").Value = num

-B29 = Range("B29").Value

-C29 = Range("C29").Value

-If B29 = C29 Then

-Range("D29").Value = "OK"

-Else

-Range("D29").Value = "NG"

-End If

-End Function

-

-Function test_xlCellTypeConstants(ByRef num)

-Range("A30").Clear

-Range("B30").Clear

-Range("C30").Clear

-Range("D30").Clear

-Range("A30").Value = "xlCellTypeConstants"

-Range("B30").Value = 2

-Range("C30").Value = num

-B30 = Range("B30").Value

-C30 = Range("C30").Value

-If B30 = C30 Then

-Range("D30").Value = "OK"

-Else

-Range("D30").Value = "NG"

-End If

-End Function

-

-Function test_xlCellTypeFormulas(ByRef num)

-Range("A31").Clear

-Range("B31").Clear

-Range("C31").Clear

-Range("D31").Clear

-Range("A31").Value = "xlCellTypeFormulas"

-Range("B31").Value = -4123

-Range("C31").Value = num

-B31 = Range("B31").Value

-C31 = Range("C31").Value

-If B31 = C31 Then

-Range("D31").Value = "OK"

-Else

-Range("D31").Value = "NG"

-End If

-End Function

-

-Function test_xlCellTypeLastCell(ByRef num)

-Range("A32").Clear

-Range("B32").Clear

-Range("C32").Clear

-Range("D32").Clear

-Range("A32").Value = "xlCellTypeLastCell"

-Range("B32").Value = 11

-Range("C32").Value = num

-B32 = Range("B32").Value

-C32 = Range("C32").Value

-If B32 = C32 Then

-Range("D32").Value = "OK"

-Else

-Range("D32").Value = "NG"

-End If

-End Function

-

-Function test_xlCellTypeSameFormatConditions(ByRef num)

-Range("A33").Clear

-Range("B33").Clear

-Range("C33").Clear

-Range("D33").Clear

-Range("A33").Value = "xlCellTypeSameFormatConditions"

-Range("B33").Value = -4173

-Range("C33").Value = num

-B33 = Range("B33").Value

-C33 = Range("C33").Value

-If B33 = C33 Then

-Range("D33").Value = "OK"

-Else

-Range("D33").Value = "NG"

-End If

-End Function

-

-Function test_xlCellTypeSameValidation(ByRef num)

-Range("A34").Clear

-Range("B34").Clear

-Range("C34").Clear

-Range("D34").Clear

-Range("A34").Value = "xlCellTypeSameValidation"

-Range("B34").Value = -4175

-Range("C34").Value = num

-B34 = Range("B34").Value

-C34 = Range("C34").Value

-If B34 = C34 Then

-Range("D34").Value = "OK"

-Else

-Range("D34").Value = "NG"

-End If

-End Function

-

-Function test_xlCellTypeVisible(ByRef num)

-Range("A35").Clear

-Range("B35").Clear

-Range("C35").Clear

-Range("D35").Clear

-Range("A35").Value = "xlCellTypeVisible"

-Range("B35").Value = 12

-Range("C35").Value = num

-B35 = Range("B35").Value

-C35 = Range("C35").Value

-If B35 = C35 Then

-Range("D35").Value = "OK"

-Else

-Range("D35").Value = "NG"

-End If

-End Function

-

-Function test_xlAnyGallery(ByRef num)

-Range("A36").Clear

-Range("B36").Clear

-Range("C36").Clear

-Range("D36").Clear

-Range("A36").Value = "xlAnyGallery"

-Range("B36").Value = 23

-Range("C36").Value = num

-B36 = Range("B36").Value

-C36 = Range("C36").Value

-If B36 = C36 Then

-Range("D36").Value = "OK"

-Else

-Range("D36").Value = "NG"

-End If

-End Function

-

-Function test_xlBuildIn(ByRef num)

-Range("A37").Clear

-Range("B37").Clear

-Range("C37").Clear

-Range("D37").Clear

-Range("A37").Value = "xlBuildIn"

-Range("B37").Value = 21

-Range("C37").Value = num

-B37 = Range("B37").Value

-C37 = Range("C37").Value

-If B37 = C37 Then

-Range("D37").Value = "OK"

-Else

-Range("D37").Value = "NG"

-End If

-End Function

-

-Function test_xlUserDefined(ByRef num)

-Range("A38").Clear

-Range("B38").Clear

-Range("C38").Clear

-Range("D38").Clear

-Range("A38").Value = "xlUserDefined"

-Range("B38").Value = 22

-Range("C38").Value = num

-B38 = Range("B38").Value

-C38 = Range("C38").Value

-If B38 = C38 Then

-Range("D38").Value = "OK"

-Else

-Range("D38").Value = "NG"

-End If

-End Function

-

-Function test_xlAxis(ByRef num)

-Range("A39").Clear

-Range("B39").Clear

-Range("C39").Clear

-Range("D39").Clear

-Range("A39").Value = "xlAxis"

-Range("B39").Value = 21

-Range("C39").Value = num

-B39 = Range("B39").Value

-C39 = Range("C39").Value

-If B39 = C39 Then

-Range("D39").Value = "OK"

-Else

-Range("D39").Value = "NG"

-End If

-End Function

-

-Function test_xlAxisTitle(ByRef num)

-Range("A40").Clear

-Range("B40").Clear

-Range("C40").Clear

-Range("D40").Clear

-Range("A40").Value = "xlAxisTitle"

-Range("B40").Value = 17

-Range("C40").Value = num

-B40 = Range("B40").Value

-C40 = Range("C40").Value

-If B40 = C40 Then

-Range("D40").Value = "OK"

-Else

-Range("D40").Value = "NG"

-End If

-End Function

-

-Function test_xlChartTitle(ByRef num)

-Range("A41").Clear

-Range("B41").Clear

-Range("C41").Clear

-Range("D41").Clear

-Range("A41").Value = "xlChartTitle"

-Range("B41").Value = 4

-Range("C41").Value = num

-B41 = Range("B41").Value

-C41 = Range("C41").Value

-If B41 = C41 Then

-Range("D41").Value = "OK"

-Else

-Range("D41").Value = "NG"

-End If

-End Function

-

-Function test_xlCorners(ByRef num)

-Range("A42").Clear

-Range("B42").Clear

-Range("C42").Clear

-Range("D42").Clear

-Range("A42").Value = "xlCorners"

-Range("B42").Value = 6

-Range("C42").Value = num

-B42 = Range("B42").Value

-C42 = Range("C42").Value

-If B42 = C42 Then

-Range("D42").Value = "OK"

-Else

-Range("D42").Value = "NG"

-End If

-End Function

-

-Function test_xlDataLabel(ByRef num)

-Range("A43").Clear

-Range("B43").Clear

-Range("C43").Clear

-Range("D43").Clear

-Range("A43").Value = "xlDataLabel"

-Range("B43").Value = 0

-Range("C43").Value = num

-B43 = Range("B43").Value

-C43 = Range("C43").Value

-If B43 = C43 Then

-Range("D43").Value = "OK"

-Else

-Range("D43").Value = "NG"

-End If

-End Function

-

-Function test_xlDataTable(ByRef num)

-Range("A44").Clear

-Range("B44").Clear

-Range("C44").Clear

-Range("D44").Clear

-Range("A44").Value = "xlDataTable"

-Range("B44").Value = 0

-Range("C44").Value = num

-B44 = Range("B44").Value

-C44 = Range("C44").Value

-If B44 = C44 Then

-Range("D44").Value = "OK"

-Else

-Range("D44").Value = "NG"

-End If

-End Function

-

-Function test_xlDisplayUnitLabel(ByRef num)

-Range("A45").Clear

-Range("B45").Clear

-Range("C45").Clear

-Range("D45").Clear

-Range("A45").Value = "xlDisplayUnitLabel"

-Range("B45").Value = 30

-Range("C45").Value = num

-B45 = Range("B45").Value

-C45 = Range("C45").Value

-If B45 = C45 Then

-Range("D45").Value = "OK"

-Else

-Range("D45").Value = "NG"

-End If

-End Function

-

-Function test_xlDownBars(ByRef num)

-Range("A46").Clear

-Range("B46").Clear

-Range("C46").Clear

-Range("D46").Clear

-Range("A46").Value = "xlDownBars"

-Range("B46").Value = 20

-Range("C46").Value = num

-B46 = Range("B46").Value

-C46 = Range("C46").Value

-If B46 = C46 Then

-Range("D46").Value = "OK"

-Else

-Range("D46").Value = "NG"

-End If

-End Function

-

-Function test_xlDropLines(ByRef num)

-Range("A47").Clear

-Range("B47").Clear

-Range("C47").Clear

-Range("D47").Clear

-Range("A47").Value = "xlDropLines"

-Range("B47").Value = 26

-Range("C47").Value = num

-B47 = Range("B47").Value

-C47 = Range("C47").Value

-If B47 = C47 Then

-Range("D47").Value = "OK"

-Else

-Range("D47").Value = "NG"

-End If

-End Function

-

-Function test_xlErrorBars(ByRef num)

-Range("A48").Clear

-Range("B48").Clear

-Range("C48").Clear

-Range("D48").Clear

-Range("A48").Value = "xlErrorBars"

-Range("B48").Value = 9

-Range("C48").Value = num

-B48 = Range("B48").Value

-C48 = Range("C48").Value

-If B48 = C48 Then

-Range("D48").Value = "OK"

-Else

-Range("D48").Value = "NG"

-End If

-End Function

-

-Function test_xlFloor(ByRef num)

-Range("A49").Clear

-Range("B49").Clear

-Range("C49").Clear

-Range("D49").Clear

-Range("A49").Value = "xlFloor"

-Range("B49").Value = 23

-Range("C49").Value = num

-B49 = Range("B49").Value

-C49 = Range("C49").Value

-If B49 = C49 Then

-Range("D49").Value = "OK"

-Else

-Range("D49").Value = "NG"

-End If

-End Function

-

-Function test_xlHiLoLines(ByRef num)

-Range("A50").Clear

-Range("B50").Clear

-Range("C50").Clear

-Range("D50").Clear

-Range("A50").Value = "xlHiLoLines"

-Range("B50").Value = 25

-Range("C50").Value = num

-B50 = Range("B50").Value

-C50 = Range("C50").Value

-If B50 = C50 Then

-Range("D50").Value = "OK"

-Else

-Range("D50").Value = "NG"

-End If

-End Function

-

-Function test_xlLeaderLines(ByRef num)

-Range("A51").Clear

-Range("B51").Clear

-Range("C51").Clear

-Range("D51").Clear

-Range("A51").Value = "xlLeaderLines"

-Range("B51").Value = 29

-Range("C51").Value = num

-B51 = Range("B51").Value

-C51 = Range("C51").Value

-If B51 = C51 Then

-Range("D51").Value = "OK"

-Else

-Range("D51").Value = "NG"

-End If

-End Function

-

-Function test_xlLegend(ByRef num)

-Range("A52").Clear

-Range("B52").Clear

-Range("C52").Clear

-Range("D52").Clear

-Range("A52").Value = "xlLegend"

-Range("B52").Value = 24

-Range("C52").Value = num

-B52 = Range("B52").Value

-C52 = Range("C52").Value

-If B52 = C52 Then

-Range("D52").Value = "OK"

-Else

-Range("D52").Value = "NG"

-End If

-End Function

-

-Function test_xlLegendEntry(ByRef num)

-Range("A53").Clear

-Range("B53").Clear

-Range("C53").Clear

-Range("D53").Clear

-Range("A53").Value = "xlLegendEntry"

-Range("B53").Value = 12

-Range("C53").Value = num

-B53 = Range("B53").Value

-C53 = Range("C53").Value

-If B53 = C53 Then

-Range("D53").Value = "OK"

-Else

-Range("D53").Value = "NG"

-End If

-End Function

-

-Function test_xlLegendKey(ByRef num)

-Range("A54").Clear

-Range("B54").Clear

-Range("C54").Clear

-Range("D54").Clear

-Range("A54").Value = "xlLegendKey"

-Range("B54").Value = 13

-Range("C54").Value = num

-B54 = Range("B54").Value

-C54 = Range("C54").Value

-If B54 = C54 Then

-Range("D54").Value = "OK"

-Else

-Range("D54").Value = "NG"

-End If

-End Function

-

-Function test_xlMajorGridlines(ByRef num)

-Range("A55").Clear

-Range("B55").Clear

-Range("C55").Clear

-Range("D55").Clear

-Range("A55").Value = "xlMajorGridlines"

-Range("B55").Value = 15

-Range("C55").Value = num

-B55 = Range("B55").Value

-C55 = Range("C55").Value

-If B55 = C55 Then

-Range("D55").Value = "OK"

-Else

-Range("D55").Value = "NG"

-End If

-End Function

-

-Function test_xlMinorGridlines(ByRef num)

-Range("A56").Clear

-Range("B56").Clear

-Range("C56").Clear

-Range("D56").Clear

-Range("A56").Value = "xlMinorGridlines"

-Range("B56").Value = 16

-Range("C56").Value = num

-B56 = Range("B56").Value

-C56 = Range("C56").Value

-If B56 = C56 Then

-Range("D56").Value = "OK"

-Else

-Range("D56").Value = "NG"

-End If

-End Function

-

-Function test_xlNothing(ByRef num)

-Range("A57").Clear

-Range("B57").Clear

-Range("C57").Clear

-Range("D57").Clear

-Range("A57").Value = "xlNothing"

-Range("B57").Value = 28

-Range("C57").Value = num

-B57 = Range("B57").Value

-C57 = Range("C57").Value

-If B57 = C57 Then

-Range("D57").Value = "OK"

-Else

-Range("D57").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotChartDropZone(ByRef num)

-Range("A58").Clear

-Range("B58").Clear

-Range("C58").Clear

-Range("D58").Clear

-Range("A58").Value = "xlPivotChartDropZone"

-Range("B58").Value = 32

-Range("C58").Value = num

-B58 = Range("B58").Value

-C58 = Range("C58").Value

-If B58 = C58 Then

-Range("D58").Value = "OK"

-Else

-Range("D58").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotChartFieldButton(ByRef num)

-Range("A59").Clear

-Range("B59").Clear

-Range("C59").Clear

-Range("D59").Clear

-Range("A59").Value = "xlPivotChartFieldButton"

-Range("B59").Value = 31

-Range("C59").Value = num

-B59 = Range("B59").Value

-C59 = Range("C59").Value

-If B59 = C59 Then

-Range("D59").Value = "OK"

-Else

-Range("D59").Value = "NG"

-End If

-End Function

-

-Function test_xlPlotArea(ByRef num)

-Range("A60").Clear

-Range("B60").Clear

-Range("C60").Clear

-Range("D60").Clear

-Range("A60").Value = "xlPlotArea"

-Range("B60").Value = 19

-Range("C60").Value = num

-B60 = Range("B60").Value

-C60 = Range("C60").Value

-If B60 = C60 Then

-Range("D60").Value = "OK"

-Else

-Range("D60").Value = "NG"

-End If

-End Function

-

-Function test_xlRaderAxisLabels(ByRef num)

-Range("A61").Clear

-Range("B61").Clear

-Range("C61").Clear

-Range("D61").Clear

-Range("A61").Value = "xlRaderAxisLabels"

-Range("B61").Value = 27

-Range("C61").Value = num

-B61 = Range("B61").Value

-C61 = Range("C61").Value

-If B61 = C61 Then

-Range("D61").Value = "OK"

-Else

-Range("D61").Value = "NG"

-End If

-End Function

-

-Function test_xlSeries(ByRef num)

-Range("A62").Clear

-Range("B62").Clear

-Range("C62").Clear

-Range("D62").Clear

-Range("A62").Value = "xlSeries"

-Range("B62").Value = 3

-Range("C62").Value = num

-B62 = Range("B62").Value

-C62 = Range("C62").Value

-If B62 = C62 Then

-Range("D62").Value = "OK"

-Else

-Range("D62").Value = "NG"

-End If

-End Function

-

-Function test_xlSeriesLines(ByRef num)

-Range("A63").Clear

-Range("B63").Clear

-Range("C63").Clear

-Range("D63").Clear

-Range("A63").Value = "xlSeriesLines"

-Range("B63").Value = 22

-Range("C63").Value = num

-B63 = Range("B63").Value

-C63 = Range("C63").Value

-If B63 = C63 Then

-Range("D63").Value = "OK"

-Else

-Range("D63").Value = "NG"

-End If

-End Function

-

-Function test_xlShape(ByRef num)

-Range("A64").Clear

-Range("B64").Clear

-Range("C64").Clear

-Range("D64").Clear

-Range("A64").Value = "xlShape"

-Range("B64").Value = 14

-Range("C64").Value = num

-B64 = Range("B64").Value

-C64 = Range("C64").Value

-If B64 = C64 Then

-Range("D64").Value = "OK"

-Else

-Range("D64").Value = "NG"

-End If

-End Function

-

-Function test_xlTrendline(ByRef num)

-Range("A65").Clear

-Range("B65").Clear

-Range("C65").Clear

-Range("D65").Clear

-Range("A65").Value = "xlTrendline"

-Range("B65").Value = 8

-Range("C65").Value = num

-B65 = Range("B65").Value

-C65 = Range("C65").Value

-If B65 = C65 Then

-Range("D65").Value = "OK"

-Else

-Range("D65").Value = "NG"

-End If

-End Function

-

-Function test_xlUpBars(ByRef num)

-Range("A66").Clear

-Range("B66").Clear

-Range("C66").Clear

-Range("D66").Clear

-Range("A66").Value = "xlUpBars"

-Range("B66").Value = 18

-Range("C66").Value = num

-B66 = Range("B66").Value

-C66 = Range("C66").Value

-If B66 = C66 Then

-Range("D66").Value = "OK"

-Else

-Range("D66").Value = "NG"

-End If

-End Function

-

-Function test_xlWalls(ByRef num)

-Range("A67").Clear

-Range("B67").Clear

-Range("C67").Clear

-Range("D67").Clear

-Range("A67").Value = "xlWalls"

-Range("B67").Value = 5

-Range("C67").Value = num

-B67 = Range("B67").Value

-C67 = Range("C67").Value

-If B67 = C67 Then

-Range("D67").Value = "OK"

-Else

-Range("D67").Value = "NG"

-End If

-End Function

-

-Function test_xlXErrorBars(ByRef num)

-Range("A68").Clear

-Range("B68").Clear

-Range("C68").Clear

-Range("D68").Clear

-Range("A68").Value = "xlXErrorBars"

-Range("B68").Value = 10

-Range("C68").Value = num

-B68 = Range("B68").Value

-C68 = Range("C68").Value

-If B68 = C68 Then

-Range("D68").Value = "OK"

-Else

-Range("D68").Value = "NG"

-End If

-End Function

-

-Function test_xlYErrorBars(ByRef num)

-Range("A69").Clear

-Range("B69").Clear

-Range("C69").Clear

-Range("D69").Clear

-Range("A69").Value = "xlYErrorBars"

-Range("B69").Value = 11

-Range("C69").Value = num

-B69 = Range("B69").Value

-C69 = Range("C69").Value

-If B69 = C69 Then

-Range("D69").Value = "OK"

-Else

-Range("D69").Value = "NG"

-End If

-End Function

-

-Function test_xlLocationAsNewSheet(ByRef num)

-Range("A70").Clear

-Range("B70").Clear

-Range("C70").Clear

-Range("D70").Clear

-Range("A70").Value = "xlLocationAsNewSheet"

-Range("B70").Value = 1

-Range("C70").Value = num

-B70 = Range("B70").Value

-C70 = Range("C70").Value

-If B70 = C70 Then

-Range("D70").Value = "OK"

-Else

-Range("D70").Value = "NG"

-End If

-End Function

-

-Function test_xlLocationAsObject(ByRef num)

-Range("A71").Clear

-Range("B71").Clear

-Range("C71").Clear

-Range("D71").Clear

-Range("A71").Value = "xlLocationAsObject"

-Range("B71").Value = 2

-Range("C71").Value = num

-B71 = Range("B71").Value

-C71 = Range("C71").Value

-If B71 = C71 Then

-Range("D71").Value = "OK"

-Else

-Range("D71").Value = "NG"

-End If

-End Function

-

-Function test_xlLocationAutomatic(ByRef num)

-Range("A72").Clear

-Range("B72").Clear

-Range("C72").Clear

-Range("D72").Clear

-Range("A72").Value = "xlLocationAutomatic"

-Range("B72").Value = 3

-Range("C72").Value = num

-B72 = Range("B72").Value

-C72 = Range("C72").Value

-If B72 = C72 Then

-Range("D72").Value = "OK"

-Else

-Range("D72").Value = "NG"

-End If

-End Function

-

-Function test_xlAllFaces(ByRef num)

-Range("A73").Clear

-Range("B73").Clear

-Range("C73").Clear

-Range("D73").Clear

-Range("A73").Value = "xlAllFaces"

-Range("B73").Value = 7

-Range("C73").Value = num

-B73 = Range("B73").Value

-C73 = Range("C73").Value

-If B73 = C73 Then

-Range("D73").Value = "OK"

-Else

-Range("D73").Value = "NG"

-End If

-End Function

-

-Function test_xlEnd(ByRef num)

-Range("A74").Clear

-Range("B74").Clear

-Range("C74").Clear

-Range("D74").Clear

-Range("A74").Value = "xlEnd"

-Range("B74").Value = 2

-Range("C74").Value = num

-B74 = Range("B74").Value

-C74 = Range("C74").Value

-If B74 = C74 Then

-Range("D74").Value = "OK"

-Else

-Range("D74").Value = "NG"

-End If

-End Function

-

-Function test_xlEndSides(ByRef num)

-Range("A75").Clear

-Range("B75").Clear

-Range("C75").Clear

-Range("D75").Clear

-Range("A75").Value = "xlEndSides"

-Range("B75").Value = 3

-Range("C75").Value = num

-B75 = Range("B75").Value

-C75 = Range("C75").Value

-If B75 = C75 Then

-Range("D75").Value = "OK"

-Else

-Range("D75").Value = "NG"

-End If

-End Function

-

-Function test_xlFront(ByRef num)

-Range("A76").Clear

-Range("B76").Clear

-Range("C76").Clear

-Range("D76").Clear

-Range("A76").Value = "xlFront"

-Range("B76").Value = 4

-Range("C76").Value = num

-B76 = Range("B76").Value

-C76 = Range("C76").Value

-If B76 = C76 Then

-Range("D76").Value = "OK"

-Else

-Range("D76").Value = "NG"

-End If

-End Function

-

-Function test_xlFrontEnd(ByRef num)

-Range("A77").Clear

-Range("B77").Clear

-Range("C77").Clear

-Range("D77").Clear

-Range("A77").Value = "xlFrontEnd"

-Range("B77").Value = 6

-Range("C77").Value = num

-B77 = Range("B77").Value

-C77 = Range("C77").Value

-If B77 = C77 Then

-Range("D77").Value = "OK"

-Else

-Range("D77").Value = "NG"

-End If

-End Function

-

-Function test_xlFrontSides(ByRef num)

-Range("A78").Clear

-Range("B78").Clear

-Range("C78").Clear

-Range("D78").Clear

-Range("A78").Value = "xlFrontSides"

-Range("B78").Value = 5

-Range("C78").Value = num

-B78 = Range("B78").Value

-C78 = Range("C78").Value

-If B78 = C78 Then

-Range("D78").Value = "OK"

-Else

-Range("D78").Value = "NG"

-End If

-End Function

-

-Function test_xlSlides(ByRef num)

-Range("A79").Clear

-Range("B79").Clear

-Range("C79").Clear

-Range("D79").Clear

-Range("A79").Value = "xlSlides"

-Range("B79").Value = 1

-Range("C79").Value = num

-B79 = Range("B79").Value

-C79 = Range("C79").Value

-If B79 = C79 Then

-Range("D79").Value = "OK"

-Else

-Range("D79").Value = "NG"

-End If

-End Function

-

-Function test_xlStack(ByRef num)

-Range("A80").Clear

-Range("B80").Clear

-Range("C80").Clear

-Range("D80").Clear

-Range("A80").Value = "xlStack"

-Range("B80").Value = 2

-Range("C80").Value = num

-B80 = Range("B80").Value

-C80 = Range("C80").Value

-If B80 = C80 Then

-Range("D80").Value = "OK"

-Else

-Range("D80").Value = "NG"

-End If

-End Function

-

-Function test_xlStackScale(ByRef num)

-Range("A81").Clear

-Range("B81").Clear

-Range("C81").Clear

-Range("D81").Clear

-Range("A81").Value = "xlStackScale"

-Range("B81").Value = 3

-Range("C81").Value = num

-B81 = Range("B81").Value

-C81 = Range("C81").Value

-If B81 = C81 Then

-Range("D81").Value = "OK"

-Else

-Range("D81").Value = "NG"

-End If

-End Function

-

-Function test_xlStretch(ByRef num)

-Range("A82").Clear

-Range("B82").Clear

-Range("C82").Clear

-Range("D82").Clear

-Range("A82").Value = "xlStretch"

-Range("B82").Value = 1

-Range("C82").Value = num

-B82 = Range("B82").Value

-C82 = Range("C82").Value

-If B82 = C82 Then

-Range("D82").Value = "OK"

-Else

-Range("D82").Value = "NG"

-End If

-End Function

-

-Function test_xlSplitByCustomSplit(ByRef num)

-Range("A83").Clear

-Range("B83").Clear

-Range("C83").Clear

-Range("D83").Clear

-Range("A83").Value = "xlSplitByCustomSplit"

-Range("B83").Value = 4

-Range("C83").Value = num

-B83 = Range("B83").Value

-C83 = Range("C83").Value

-If B83 = C83 Then

-Range("D83").Value = "OK"

-Else

-Range("D83").Value = "NG"

-End If

-End Function

-

-Function test_xlSplitByPercentValue(ByRef num)

-Range("A84").Clear

-Range("B84").Clear

-Range("C84").Clear

-Range("D84").Clear

-Range("A84").Value = "xlSplitByPercentValue"

-Range("B84").Value = 3

-Range("C84").Value = num

-B84 = Range("B84").Value

-C84 = Range("C84").Value

-If B84 = C84 Then

-Range("D84").Value = "OK"

-Else

-Range("D84").Value = "NG"

-End If

-End Function

-

-Function test_xlSplitByPercentPosition(ByRef num)

-Range("A85").Clear

-Range("B85").Clear

-Range("C85").Clear

-Range("D85").Clear

-Range("A85").Value = "xlSplitByPercentPosition"

-Range("B85").Value = 1

-Range("C85").Value = num

-B85 = Range("B85").Value

-C85 = Range("C85").Value

-If B85 = C85 Then

-Range("D85").Value = "OK"

-Else

-Range("D85").Value = "NG"

-End If

-End Function

-

-Function test_xlSplitByValue(ByRef num)

-Range("A86").Clear

-Range("B86").Clear

-Range("C86").Clear

-Range("D86").Clear

-Range("A86").Value = "xlSplitByValue"

-Range("B86").Value = 2

-Range("C86").Value = num

-B86 = Range("B86").Value

-C86 = Range("C86").Value

-If B86 = C86 Then

-Range("D86").Value = "OK"

-Else

-Range("D86").Value = "NG"

-End If

-End Function

-

-Function test_xl3DArea(ByRef num)

-Range("A87").Clear

-Range("B87").Clear

-Range("C87").Clear

-Range("D87").Clear

-Range("A87").Value = "xl3DArea"

-Range("B87").Value = -4098

-Range("C87").Value = num

-B87 = Range("B87").Value

-C87 = Range("C87").Value

-If B87 = C87 Then

-Range("D87").Value = "OK"

-Else

-Range("D87").Value = "NG"

-End If

-End Function

-

-Function test_xl3DAreaStacked(ByRef num)

-Range("A88").Clear

-Range("B88").Clear

-Range("C88").Clear

-Range("D88").Clear

-Range("A88").Value = "xl3DAreaStacked"

-Range("B88").Value = 78

-Range("C88").Value = num

-B88 = Range("B88").Value

-C88 = Range("C88").Value

-If B88 = C88 Then

-Range("D88").Value = "OK"

-Else

-Range("D88").Value = "NG"

-End If

-End Function

-

-Function test_xl3DAreaStacked100(ByRef num)

-Range("A89").Clear

-Range("B89").Clear

-Range("C89").Clear

-Range("D89").Clear

-Range("A89").Value = "xl3DAreaStacked100"

-Range("B89").Value = 79

-Range("C89").Value = num

-B89 = Range("B89").Value

-C89 = Range("C89").Value

-If B89 = C89 Then

-Range("D89").Value = "OK"

-Else

-Range("D89").Value = "NG"

-End If

-End Function

-

-Function test_xl3DBarClustered(ByRef num)

-Range("A90").Clear

-Range("B90").Clear

-Range("C90").Clear

-Range("D90").Clear

-Range("A90").Value = "xl3DBarClustered"

-Range("B90").Value = 60

-Range("C90").Value = num

-B90 = Range("B90").Value

-C90 = Range("C90").Value

-If B90 = C90 Then

-Range("D90").Value = "OK"

-Else

-Range("D90").Value = "NG"

-End If

-End Function

-

-Function test_xl3DBarStacked(ByRef num)

-Range("A91").Clear

-Range("B91").Clear

-Range("C91").Clear

-Range("D91").Clear

-Range("A91").Value = "xl3DBarStacked"

-Range("B91").Value = 61

-Range("C91").Value = num

-B91 = Range("B91").Value

-C91 = Range("C91").Value

-If B91 = C91 Then

-Range("D91").Value = "OK"

-Else

-Range("D91").Value = "NG"

-End If

-End Function

-

-Function test_xl3DBarStacked100(ByRef num)

-Range("A92").Clear

-Range("B92").Clear

-Range("C92").Clear

-Range("D92").Clear

-Range("A92").Value = "xl3DBarStacked100"

-Range("B92").Value = 62

-Range("C92").Value = num

-B92 = Range("B92").Value

-C92 = Range("C92").Value

-If B92 = C92 Then

-Range("D92").Value = "OK"

-Else

-Range("D92").Value = "NG"

-End If

-End Function

-

-Function test_xl3DColumn(ByRef num)

-Range("A93").Clear

-Range("B93").Clear

-Range("C93").Clear

-Range("D93").Clear

-Range("A93").Value = "xl3DColumn"

-Range("B93").Value = -4100

-Range("C93").Value = num

-B93 = Range("B93").Value

-C93 = Range("C93").Value

-If B93 = C93 Then

-Range("D93").Value = "OK"

-Else

-Range("D93").Value = "NG"

-End If

-End Function

-

-Function test_xl3DColumnClustered(ByRef num)

-Range("A94").Clear

-Range("B94").Clear

-Range("C94").Clear

-Range("D94").Clear

-Range("A94").Value = "xl3DColumnClustered"

-Range("B94").Value = 54

-Range("C94").Value = num

-B94 = Range("B94").Value

-C94 = Range("C94").Value

-If B94 = C94 Then

-Range("D94").Value = "OK"

-Else

-Range("D94").Value = "NG"

-End If

-End Function

-

-Function test_xl3DColumnStacked(ByRef num)

-Range("A95").Clear

-Range("B95").Clear

-Range("C95").Clear

-Range("D95").Clear

-Range("A95").Value = "xl3DColumnStacked"

-Range("B95").Value = 55

-Range("C95").Value = num

-B95 = Range("B95").Value

-C95 = Range("C95").Value

-If B95 = C95 Then

-Range("D95").Value = "OK"

-Else

-Range("D95").Value = "NG"

-End If

-End Function

-

-Function test_xl3DColumnStacked100(ByRef num)

-Range("A96").Clear

-Range("B96").Clear

-Range("C96").Clear

-Range("D96").Clear

-Range("A96").Value = "xl3DColumnStacked100"

-Range("B96").Value = 56

-Range("C96").Value = num

-B96 = Range("B96").Value

-C96 = Range("C96").Value

-If B96 = C96 Then

-Range("D96").Value = "OK"

-Else

-Range("D96").Value = "NG"

-End If

-End Function

-

-Function test_xl3DLine(ByRef num)

-Range("A97").Clear

-Range("B97").Clear

-Range("C97").Clear

-Range("D97").Clear

-Range("A97").Value = "xl3DLine"

-Range("B97").Value = -4101

-Range("C97").Value = num

-B97 = Range("B97").Value

-C97 = Range("C97").Value

-If B97 = C97 Then

-Range("D97").Value = "OK"

-Else

-Range("D97").Value = "NG"

-End If

-End Function

-

-Function test_xl3DPie(ByRef num)

-Range("A98").Clear

-Range("B98").Clear

-Range("C98").Clear

-Range("D98").Clear

-Range("A98").Value = "xl3DPie"

-Range("B98").Value = -4102

-Range("C98").Value = num

-B98 = Range("B98").Value

-C98 = Range("C98").Value

-If B98 = C98 Then

-Range("D98").Value = "OK"

-Else

-Range("D98").Value = "NG"

-End If

-End Function

-

-Function test_xl3DPieExploded(ByRef num)

-Range("A99").Clear

-Range("B99").Clear

-Range("C99").Clear

-Range("D99").Clear

-Range("A99").Value = "xl3DPieExploded"

-Range("B99").Value = 70

-Range("C99").Value = num

-B99 = Range("B99").Value

-C99 = Range("C99").Value

-If B99 = C99 Then

-Range("D99").Value = "OK"

-Else

-Range("D99").Value = "NG"

-End If

-End Function

-

-Function test_xlArea(ByRef num)

-Range("A100").Clear

-Range("B100").Clear

-Range("C100").Clear

-Range("D100").Clear

-Range("A100").Value = "xlArea"

-Range("B100").Value = 1

-Range("C100").Value = num

-B100 = Range("B100").Value

-C100 = Range("C100").Value

-If B100 = C100 Then

-Range("D100").Value = "OK"

-Else

-Range("D100").Value = "NG"

-End If

-End Function

-

-Function test_xlAreaStacked(ByRef num)

-Range("A101").Clear

-Range("B101").Clear

-Range("C101").Clear

-Range("D101").Clear

-Range("A101").Value = "xlAreaStacked"

-Range("B101").Value = 76

-Range("C101").Value = num

-B101 = Range("B101").Value

-C101 = Range("C101").Value

-If B101 = C101 Then

-Range("D101").Value = "OK"

-Else

-Range("D101").Value = "NG"

-End If

-End Function

-

-Function test_xlAreaStacked100(ByRef num)

-Range("A102").Clear

-Range("B102").Clear

-Range("C102").Clear

-Range("D102").Clear

-Range("A102").Value = "xlAreaStacked100"

-Range("B102").Value = 77

-Range("C102").Value = num

-B102 = Range("B102").Value

-C102 = Range("C102").Value

-If B102 = C102 Then

-Range("D102").Value = "OK"

-Else

-Range("D102").Value = "NG"

-End If

-End Function

-

-Function test_xlBarClustered(ByRef num)

-Range("A103").Clear

-Range("B103").Clear

-Range("C103").Clear

-Range("D103").Clear

-Range("A103").Value = "xlBarClustered"

-Range("B103").Value = 57

-Range("C103").Value = num

-B103 = Range("B103").Value

-C103 = Range("C103").Value

-If B103 = C103 Then

-Range("D103").Value = "OK"

-Else

-Range("D103").Value = "NG"

-End If

-End Function

-

-Function test_xlBarOfPie(ByRef num)

-Range("A104").Clear

-Range("B104").Clear

-Range("C104").Clear

-Range("D104").Clear

-Range("A104").Value = "xlBarOfPie"

-Range("B104").Value = 71

-Range("C104").Value = num

-B104 = Range("B104").Value

-C104 = Range("C104").Value

-If B104 = C104 Then

-Range("D104").Value = "OK"

-Else

-Range("D104").Value = "NG"

-End If

-End Function

-

-Function test_xlBarStacked(ByRef num)

-Range("A105").Clear

-Range("B105").Clear

-Range("C105").Clear

-Range("D105").Clear

-Range("A105").Value = "xlBarStacked"

-Range("B105").Value = 58

-Range("C105").Value = num

-B105 = Range("B105").Value

-C105 = Range("C105").Value

-If B105 = C105 Then

-Range("D105").Value = "OK"

-Else

-Range("D105").Value = "NG"

-End If

-End Function

-

-Function test_xlBarStacked100(ByRef num)

-Range("A106").Clear

-Range("B106").Clear

-Range("C106").Clear

-Range("D106").Clear

-Range("A106").Value = "xlBarStacked100"

-Range("B106").Value = 59

-Range("C106").Value = num

-B106 = Range("B106").Value

-C106 = Range("C106").Value

-If B106 = C106 Then

-Range("D106").Value = "OK"

-Else

-Range("D106").Value = "NG"

-End If

-End Function

-

-Function test_xlBubble(ByRef num)

-Range("A107").Clear

-Range("B107").Clear

-Range("C107").Clear

-Range("D107").Clear

-Range("A107").Value = "xlBubble"

-Range("B107").Value = 15

-Range("C107").Value = num

-B107 = Range("B107").Value

-C107 = Range("C107").Value

-If B107 = C107 Then

-Range("D107").Value = "OK"

-Else

-Range("D107").Value = "NG"

-End If

-End Function

-

-Function test_xlBubble3DEffect(ByRef num)

-Range("A108").Clear

-Range("B108").Clear

-Range("C108").Clear

-Range("D108").Clear

-Range("A108").Value = "xlBubble3DEffect"

-Range("B108").Value = 87

-Range("C108").Value = num

-B108 = Range("B108").Value

-C108 = Range("C108").Value

-If B108 = C108 Then

-Range("D108").Value = "OK"

-Else

-Range("D108").Value = "NG"

-End If

-End Function

-

-Function test_xlColumnClustered(ByRef num)

-Range("A109").Clear

-Range("B109").Clear

-Range("C109").Clear

-Range("D109").Clear

-Range("A109").Value = "xlColumnClustered"

-Range("B109").Value = 51

-Range("C109").Value = num

-B109 = Range("B109").Value

-C109 = Range("C109").Value

-If B109 = C109 Then

-Range("D109").Value = "OK"

-Else

-Range("D109").Value = "NG"

-End If

-End Function

-

-Function test_xlColumnStacked(ByRef num)

-Range("A110").Clear

-Range("B110").Clear

-Range("C110").Clear

-Range("D110").Clear

-Range("A110").Value = "xlColumnStacked"

-Range("B110").Value = 52

-Range("C110").Value = num

-B110 = Range("B110").Value

-C110 = Range("C110").Value

-If B110 = C110 Then

-Range("D110").Value = "OK"

-Else

-Range("D110").Value = "NG"

-End If

-End Function

-

-Function test_xlColumnStacked100(ByRef num)

-Range("A111").Clear

-Range("B111").Clear

-Range("C111").Clear

-Range("D111").Clear

-Range("A111").Value = "xlColumnStacked100"

-Range("B111").Value = 53

-Range("C111").Value = num

-B111 = Range("B111").Value

-C111 = Range("C111").Value

-If B111 = C111 Then

-Range("D111").Value = "OK"

-Else

-Range("D111").Value = "NG"

-End If

-End Function

-

-Function test_xlConeBarClustered(ByRef num)

-Range("A112").Clear

-Range("B112").Clear

-Range("C112").Clear

-Range("D112").Clear

-Range("A112").Value = "xlConeBarClustered"

-Range("B112").Value = 102

-Range("C112").Value = num

-B112 = Range("B112").Value

-C112 = Range("C112").Value

-If B112 = C112 Then

-Range("D112").Value = "OK"

-Else

-Range("D112").Value = "NG"

-End If

-End Function

-

-Function test_xlConeBarStacked(ByRef num)

-Range("A113").Clear

-Range("B113").Clear

-Range("C113").Clear

-Range("D113").Clear

-Range("A113").Value = "xlConeBarStacked"

-Range("B113").Value = 103

-Range("C113").Value = num

-B113 = Range("B113").Value

-C113 = Range("C113").Value

-If B113 = C113 Then

-Range("D113").Value = "OK"

-Else

-Range("D113").Value = "NG"

-End If

-End Function

-

-Function test_xlConeBarStacked100(ByRef num)

-Range("A114").Clear

-Range("B114").Clear

-Range("C114").Clear

-Range("D114").Clear

-Range("A114").Value = "xlConeBarStacked100"

-Range("B114").Value = 104

-Range("C114").Value = num

-B114 = Range("B114").Value

-C114 = Range("C114").Value

-If B114 = C114 Then

-Range("D114").Value = "OK"

-Else

-Range("D114").Value = "NG"

-End If

-End Function

-

-Function test_xlConeCol(ByRef num)

-Range("A115").Clear

-Range("B115").Clear

-Range("C115").Clear

-Range("D115").Clear

-Range("A115").Value = "xlConeCol"

-Range("B115").Value = 105

-Range("C115").Value = num

-B115 = Range("B115").Value

-C115 = Range("C115").Value

-If B115 = C115 Then

-Range("D115").Value = "OK"

-Else

-Range("D115").Value = "NG"

-End If

-End Function

-

-Function test_xlConeColClustered(ByRef num)

-Range("A116").Clear

-Range("B116").Clear

-Range("C116").Clear

-Range("D116").Clear

-Range("A116").Value = "xlConeColClustered"

-Range("B116").Value = 99

-Range("C116").Value = num

-B116 = Range("B116").Value

-C116 = Range("C116").Value

-If B116 = C116 Then

-Range("D116").Value = "OK"

-Else

-Range("D116").Value = "NG"

-End If

-End Function

-

-Function test_xlConeColStacked(ByRef num)

-Range("A117").Clear

-Range("B117").Clear

-Range("C117").Clear

-Range("D117").Clear

-Range("A117").Value = "xlConeColStacked"

-Range("B117").Value = 100

-Range("C117").Value = num

-B117 = Range("B117").Value

-C117 = Range("C117").Value

-If B117 = C117 Then

-Range("D117").Value = "OK"

-Else

-Range("D117").Value = "NG"

-End If

-End Function

-

-Function test_xlConeColStacked100(ByRef num)

-Range("A118").Clear

-Range("B118").Clear

-Range("C118").Clear

-Range("D118").Clear

-Range("A118").Value = "xlConeColStacked100"

-Range("B118").Value = 101

-Range("C118").Value = num

-B118 = Range("B118").Value

-C118 = Range("C118").Value

-If B118 = C118 Then

-Range("D118").Value = "OK"

-Else

-Range("D118").Value = "NG"

-End If

-End Function

-

-Function test_xlCylinderBarClustered(ByRef num)

-Range("A119").Clear

-Range("B119").Clear

-Range("C119").Clear

-Range("D119").Clear

-Range("A119").Value = "xlCylinderBarClustered"

-Range("B119").Value = 95

-Range("C119").Value = num

-B119 = Range("B119").Value

-C119 = Range("C119").Value

-If B119 = C119 Then

-Range("D119").Value = "OK"

-Else

-Range("D119").Value = "NG"

-End If

-End Function

-

-Function test_xlCylinderBarStacked(ByRef num)

-Range("A120").Clear

-Range("B120").Clear

-Range("C120").Clear

-Range("D120").Clear

-Range("A120").Value = "xlCylinderBarStacked"

-Range("B120").Value = 96

-Range("C120").Value = num

-B120 = Range("B120").Value

-C120 = Range("C120").Value

-If B120 = C120 Then

-Range("D120").Value = "OK"

-Else

-Range("D120").Value = "NG"

-End If

-End Function

-

-Function test_xlCylinderBarStacked100(ByRef num)

-Range("A121").Clear

-Range("B121").Clear

-Range("C121").Clear

-Range("D121").Clear

-Range("A121").Value = "xlCylinderBarStacked100"

-Range("B121").Value = 97

-Range("C121").Value = num

-B121 = Range("B121").Value

-C121 = Range("C121").Value

-If B121 = C121 Then

-Range("D121").Value = "OK"

-Else

-Range("D121").Value = "NG"

-End If

-End Function

-

-Function test_xlCylinderCol(ByRef num)

-Range("A122").Clear

-Range("B122").Clear

-Range("C122").Clear

-Range("D122").Clear

-Range("A122").Value = "xlCylinderCol"

-Range("B122").Value = 98

-Range("C122").Value = num

-B122 = Range("B122").Value

-C122 = Range("C122").Value

-If B122 = C122 Then

-Range("D122").Value = "OK"

-Else

-Range("D122").Value = "NG"

-End If

-End Function

-

-Function test_xlCylinderColClustered(ByRef num)

-Range("A123").Clear

-Range("B123").Clear

-Range("C123").Clear

-Range("D123").Clear

-Range("A123").Value = "xlCylinderColClustered"

-Range("B123").Value = 92

-Range("C123").Value = num

-B123 = Range("B123").Value

-C123 = Range("C123").Value

-If B123 = C123 Then

-Range("D123").Value = "OK"

-Else

-Range("D123").Value = "NG"

-End If

-End Function

-

-Function test_xlCylinderColStacked(ByRef num)

-Range("A124").Clear

-Range("B124").Clear

-Range("C124").Clear

-Range("D124").Clear

-Range("A124").Value = "xlCylinderColStacked"

-Range("B124").Value = 93

-Range("C124").Value = num

-B124 = Range("B124").Value

-C124 = Range("C124").Value

-If B124 = C124 Then

-Range("D124").Value = "OK"

-Else

-Range("D124").Value = "NG"

-End If

-End Function

-

-Function test_xlCylinderColStacked100(ByRef num)

-Range("A125").Clear

-Range("B125").Clear

-Range("C125").Clear

-Range("D125").Clear

-Range("A125").Value = "xlCylinderColStacked100"

-Range("B125").Value = 94

-Range("C125").Value = num

-B125 = Range("B125").Value

-C125 = Range("C125").Value

-If B125 = C125 Then

-Range("D125").Value = "OK"

-Else

-Range("D125").Value = "NG"

-End If

-End Function

-

-Function test_xlDoughnut(ByRef num)

-Range("A126").Clear

-Range("B126").Clear

-Range("C126").Clear

-Range("D126").Clear

-Range("A126").Value = "xlDoughnut"

-Range("B126").Value = -4120

-Range("C126").Value = num

-B126 = Range("B126").Value

-C126 = Range("C126").Value

-If B126 = C126 Then

-Range("D126").Value = "OK"

-Else

-Range("D126").Value = "NG"

-End If

-End Function

-

-Function test_xlDoughnutExploded(ByRef num)

-Range("A127").Clear

-Range("B127").Clear

-Range("C127").Clear

-Range("D127").Clear

-Range("A127").Value = "xlDoughnutExploded"

-Range("B127").Value = 80

-Range("C127").Value = num

-B127 = Range("B127").Value

-C127 = Range("C127").Value

-If B127 = C127 Then

-Range("D127").Value = "OK"

-Else

-Range("D127").Value = "NG"

-End If

-End Function

-

-Function test_xlLine(ByRef num)

-Range("A128").Clear

-Range("B128").Clear

-Range("C128").Clear

-Range("D128").Clear

-Range("A128").Value = "xlLine"

-Range("B128").Value = 4

-Range("C128").Value = num

-B128 = Range("B128").Value

-C128 = Range("C128").Value

-If B128 = C128 Then

-Range("D128").Value = "OK"

-Else

-Range("D128").Value = "NG"

-End If

-End Function

-

-Function test_xlLineMarkers(ByRef num)

-Range("A129").Clear

-Range("B129").Clear

-Range("C129").Clear

-Range("D129").Clear

-Range("A129").Value = "xlLineMarkers"

-Range("B129").Value = 65

-Range("C129").Value = num

-B129 = Range("B129").Value

-C129 = Range("C129").Value

-If B129 = C129 Then

-Range("D129").Value = "OK"

-Else

-Range("D129").Value = "NG"

-End If

-End Function

-

-Function test_xlLineMarkersStacked(ByRef num)

-Range("A130").Clear

-Range("B130").Clear

-Range("C130").Clear

-Range("D130").Clear

-Range("A130").Value = "xlLineMarkersStacked"

-Range("B130").Value = 66

-Range("C130").Value = num

-B130 = Range("B130").Value

-C130 = Range("C130").Value

-If B130 = C130 Then

-Range("D130").Value = "OK"

-Else

-Range("D130").Value = "NG"

-End If

-End Function

-

-Function test_xlLineMarkersStacked100(ByRef num)

-Range("A131").Clear

-Range("B131").Clear

-Range("C131").Clear

-Range("D131").Clear

-Range("A131").Value = "xlLineMarkersStacked100"

-Range("B131").Value = 67

-Range("C131").Value = num

-B131 = Range("B131").Value

-C131 = Range("C131").Value

-If B131 = C131 Then

-Range("D131").Value = "OK"

-Else

-Range("D131").Value = "NG"

-End If

-End Function

-

-Function test_xlLineStacked(ByRef num)

-Range("A132").Clear

-Range("B132").Clear

-Range("C132").Clear

-Range("D132").Clear

-Range("A132").Value = "xlLineStacked"

-Range("B132").Value = 63

-Range("C132").Value = num

-B132 = Range("B132").Value

-C132 = Range("C132").Value

-If B132 = C132 Then

-Range("D132").Value = "OK"

-Else

-Range("D132").Value = "NG"

-End If

-End Function

-

-Function test_xlLineStacked100(ByRef num)

-Range("A133").Clear

-Range("B133").Clear

-Range("C133").Clear

-Range("D133").Clear

-Range("A133").Value = "xlLineStacked100"

-Range("B133").Value = 64

-Range("C133").Value = num

-B133 = Range("B133").Value

-C133 = Range("C133").Value

-If B133 = C133 Then

-Range("D133").Value = "OK"

-Else

-Range("D133").Value = "NG"

-End If

-End Function

-

-Function test_xlPie(ByRef num)

-Range("A134").Clear

-Range("B134").Clear

-Range("C134").Clear

-Range("D134").Clear

-Range("A134").Value = "xlPie"

-Range("B134").Value = 5

-Range("C134").Value = num

-B134 = Range("B134").Value

-C134 = Range("C134").Value

-If B134 = C134 Then

-Range("D134").Value = "OK"

-Else

-Range("D134").Value = "NG"

-End If

-End Function

-

-Function test_xlPieExploded(ByRef num)

-Range("A135").Clear

-Range("B135").Clear

-Range("C135").Clear

-Range("D135").Clear

-Range("A135").Value = "xlPieExploded"

-Range("B135").Value = 69

-Range("C135").Value = num

-B135 = Range("B135").Value

-C135 = Range("C135").Value

-If B135 = C135 Then

-Range("D135").Value = "OK"

-Else

-Range("D135").Value = "NG"

-End If

-End Function

-

-Function test_xlPieOfPie(ByRef num)

-Range("A136").Clear

-Range("B136").Clear

-Range("C136").Clear

-Range("D136").Clear

-Range("A136").Value = "xlPieOfPie"

-Range("B136").Value = 68

-Range("C136").Value = num

-B136 = Range("B136").Value

-C136 = Range("C136").Value

-If B136 = C136 Then

-Range("D136").Value = "OK"

-Else

-Range("D136").Value = "NG"

-End If

-End Function

-

-Function test_xlPyramidBarClustered(ByRef num)

-Range("A137").Clear

-Range("B137").Clear

-Range("C137").Clear

-Range("D137").Clear

-Range("A137").Value = "xlPyramidBarClustered"

-Range("B137").Value = 109

-Range("C137").Value = num

-B137 = Range("B137").Value

-C137 = Range("C137").Value

-If B137 = C137 Then

-Range("D137").Value = "OK"

-Else

-Range("D137").Value = "NG"

-End If

-End Function

-

-Function test_xlPyramidBarStacked(ByRef num)

-Range("A138").Clear

-Range("B138").Clear

-Range("C138").Clear

-Range("D138").Clear

-Range("A138").Value = "xlPyramidBarStacked"

-Range("B138").Value = 110

-Range("C138").Value = num

-B138 = Range("B138").Value

-C138 = Range("C138").Value

-If B138 = C138 Then

-Range("D138").Value = "OK"

-Else

-Range("D138").Value = "NG"

-End If

-End Function

-

-Function test_xlPyramidBarStacked100(ByRef num)

-Range("A139").Clear

-Range("B139").Clear

-Range("C139").Clear

-Range("D139").Clear

-Range("A139").Value = "xlPyramidBarStacked100"

-Range("B139").Value = 111

-Range("C139").Value = num

-B139 = Range("B139").Value

-C139 = Range("C139").Value

-If B139 = C139 Then

-Range("D139").Value = "OK"

-Else

-Range("D139").Value = "NG"

-End If

-End Function

-

-Function test_xlPyramidCol(ByRef num)

-Range("A140").Clear

-Range("B140").Clear

-Range("C140").Clear

-Range("D140").Clear

-Range("A140").Value = "xlPyramidCol"

-Range("B140").Value = 112

-Range("C140").Value = num

-B140 = Range("B140").Value

-C140 = Range("C140").Value

-If B140 = C140 Then

-Range("D140").Value = "OK"

-Else

-Range("D140").Value = "NG"

-End If

-End Function

-

-Function test_xlPyramidColClustered(ByRef num)

-Range("A141").Clear

-Range("B141").Clear

-Range("C141").Clear

-Range("D141").Clear

-Range("A141").Value = "xlPyramidColClustered"

-Range("B141").Value = 106

-Range("C141").Value = num

-B141 = Range("B141").Value

-C141 = Range("C141").Value

-If B141 = C141 Then

-Range("D141").Value = "OK"

-Else

-Range("D141").Value = "NG"

-End If

-End Function

-

-Function test_xlPyramidColStacked(ByRef num)

-Range("A142").Clear

-Range("B142").Clear

-Range("C142").Clear

-Range("D142").Clear

-Range("A142").Value = "xlPyramidColStacked"

-Range("B142").Value = 107

-Range("C142").Value = num

-B142 = Range("B142").Value

-C142 = Range("C142").Value

-If B142 = C142 Then

-Range("D142").Value = "OK"

-Else

-Range("D142").Value = "NG"

-End If

-End Function

-

-Function test_xlPyramidColStacked100(ByRef num)

-Range("A143").Clear

-Range("B143").Clear

-Range("C143").Clear

-Range("D143").Clear

-Range("A143").Value = "xlPyramidColStacked100"

-Range("B143").Value = 108

-Range("C143").Value = num

-B143 = Range("B143").Value

-C143 = Range("C143").Value

-If B143 = C143 Then

-Range("D143").Value = "OK"

-Else

-Range("D143").Value = "NG"

-End If

-End Function

-

-Function test_xlRader(ByRef num)

-Range("A144").Clear

-Range("B144").Clear

-Range("C144").Clear

-Range("D144").Clear

-Range("A144").Value = "xlRader"

-Range("B144").Value = -4151

-Range("C144").Value = num

-B144 = Range("B144").Value

-C144 = Range("C144").Value

-If B144 = C144 Then

-Range("D144").Value = "OK"

-Else

-Range("D144").Value = "NG"

-End If

-End Function

-

-Function test_xlRaderFilled(ByRef num)

-Range("A145").Clear

-Range("B145").Clear

-Range("C145").Clear

-Range("D145").Clear

-Range("A145").Value = "xlRaderFilled"

-Range("B145").Value = 82

-Range("C145").Value = num

-B145 = Range("B145").Value

-C145 = Range("C145").Value

-If B145 = C145 Then

-Range("D145").Value = "OK"

-Else

-Range("D145").Value = "NG"

-End If

-End Function

-

-Function test_xlRaderMarkers(ByRef num)

-Range("A146").Clear

-Range("B146").Clear

-Range("C146").Clear

-Range("D146").Clear

-Range("A146").Value = "xlRaderMarkers"

-Range("B146").Value = 81

-Range("C146").Value = num

-B146 = Range("B146").Value

-C146 = Range("C146").Value

-If B146 = C146 Then

-Range("D146").Value = "OK"

-Else

-Range("D146").Value = "NG"

-End If

-End Function

-

-Function test_xlStockHLC(ByRef num)

-Range("A147").Clear

-Range("B147").Clear

-Range("C147").Clear

-Range("D147").Clear

-Range("A147").Value = "xlStockHLC"

-Range("B147").Value = 88

-Range("C147").Value = num

-B147 = Range("B147").Value

-C147 = Range("C147").Value

-If B147 = C147 Then

-Range("D147").Value = "OK"

-Else

-Range("D147").Value = "NG"

-End If

-End Function

-

-Function test_xlStockOHLC(ByRef num)

-Range("A148").Clear

-Range("B148").Clear

-Range("C148").Clear

-Range("D148").Clear

-Range("A148").Value = "xlStockOHLC"

-Range("B148").Value = 89

-Range("C148").Value = num

-B148 = Range("B148").Value

-C148 = Range("C148").Value

-If B148 = C148 Then

-Range("D148").Value = "OK"

-Else

-Range("D148").Value = "NG"

-End If

-End Function

-

-Function test_xlStockVHLC(ByRef num)

-Range("A149").Clear

-Range("B149").Clear

-Range("C149").Clear

-Range("D149").Clear

-Range("A149").Value = "xlStockVHLC"

-Range("B149").Value = 90

-Range("C149").Value = num

-B149 = Range("B149").Value

-C149 = Range("C149").Value

-If B149 = C149 Then

-Range("D149").Value = "OK"

-Else

-Range("D149").Value = "NG"

-End If

-End Function

-

-Function test_xlStockVOHLC(ByRef num)

-Range("A150").Clear

-Range("B150").Clear

-Range("C150").Clear

-Range("D150").Clear

-Range("A150").Value = "xlStockVOHLC"

-Range("B150").Value = 91

-Range("C150").Value = num

-B150 = Range("B150").Value

-C150 = Range("C150").Value

-If B150 = C150 Then

-Range("D150").Value = "OK"

-Else

-Range("D150").Value = "NG"

-End If

-End Function

-

-Function test_xlSurface(ByRef num)

-Range("A151").Clear

-Range("B151").Clear

-Range("C151").Clear

-Range("D151").Clear

-Range("A151").Value = "xlSurface"

-Range("B151").Value = 83

-Range("C151").Value = num

-B151 = Range("B151").Value

-C151 = Range("C151").Value

-If B151 = C151 Then

-Range("D151").Value = "OK"

-Else

-Range("D151").Value = "NG"

-End If

-End Function

-

-Function test_xlSurfaceTopView(ByRef num)

-Range("A152").Clear

-Range("B152").Clear

-Range("C152").Clear

-Range("D152").Clear

-Range("A152").Value = "xlSurfaceTopView"

-Range("B152").Value = 85

-Range("C152").Value = num

-B152 = Range("B152").Value

-C152 = Range("C152").Value

-If B152 = C152 Then

-Range("D152").Value = "OK"

-Else

-Range("D152").Value = "NG"

-End If

-End Function

-

-Function test_xlSurfaceTopViewWireframe(ByRef num)

-Range("A153").Clear

-Range("B153").Clear

-Range("C153").Clear

-Range("D153").Clear

-Range("A153").Value = "xlSurfaceTopViewWireframe"

-Range("B153").Value = 86

-Range("C153").Value = num

-B153 = Range("B153").Value

-C153 = Range("C153").Value

-If B153 = C153 Then

-Range("D153").Value = "OK"

-Else

-Range("D153").Value = "NG"

-End If

-End Function

-

-Function test_xlSurfaceWireframe(ByRef num)

-Range("A154").Clear

-Range("B154").Clear

-Range("C154").Clear

-Range("D154").Clear

-Range("A154").Value = "xlSurfaceWireframe"

-Range("B154").Value = 84

-Range("C154").Value = num

-B154 = Range("B154").Value

-C154 = Range("C154").Value

-If B154 = C154 Then

-Range("D154").Value = "OK"

-Else

-Range("D154").Value = "NG"

-End If

-End Function

-

-Function test_xlXYScatter(ByRef num)

-Range("A155").Clear

-Range("B155").Clear

-Range("C155").Clear

-Range("D155").Clear

-Range("A155").Value = "xlXYScatter"

-Range("B155").Value = -4169

-Range("C155").Value = num

-B155 = Range("B155").Value

-C155 = Range("C155").Value

-If B155 = C155 Then

-Range("D155").Value = "OK"

-Else

-Range("D155").Value = "NG"

-End If

-End Function

-

-Function test_xlXYScatterLines(ByRef num)

-Range("A156").Clear

-Range("B156").Clear

-Range("C156").Clear

-Range("D156").Clear

-Range("A156").Value = "xlXYScatterLines"

-Range("B156").Value = 74

-Range("C156").Value = num

-B156 = Range("B156").Value

-C156 = Range("C156").Value

-If B156 = C156 Then

-Range("D156").Value = "OK"

-Else

-Range("D156").Value = "NG"

-End If

-End Function

-

-Function test_xlXYScatterLinesNoMarkers(ByRef num)

-Range("A157").Clear

-Range("B157").Clear

-Range("C157").Clear

-Range("D157").Clear

-Range("A157").Value = "xlXYScatterLinesNoMarkers"

-Range("B157").Value = 75

-Range("C157").Value = num

-B157 = Range("B157").Value

-C157 = Range("C157").Value

-If B157 = C157 Then

-Range("D157").Value = "OK"

-Else

-Range("D157").Value = "NG"

-End If

-End Function

-

-Function test_xlXYScatterSmooth(ByRef num)

-Range("A158").Clear

-Range("B158").Clear

-Range("C158").Clear

-Range("D158").Clear

-Range("A158").Value = "xlXYScatterSmooth"

-Range("B158").Value = 72

-Range("C158").Value = num

-B158 = Range("B158").Value

-C158 = Range("C158").Value

-If B158 = C158 Then

-Range("D158").Value = "OK"

-Else

-Range("D158").Value = "NG"

-End If

-End Function

-

-Function test_xlXYScatterSmoothNoMarkers(ByRef num)

-Range("A159").Clear

-Range("B159").Clear

-Range("C159").Clear

-Range("D159").Clear

-Range("A159").Value = "xlXYScatterSmoothNoMarkers"

-Range("B159").Value = 73

-Range("C159").Value = num

-B159 = Range("B159").Value

-C159 = Range("C159").Value

-If B159 = C159 Then

-Range("D159").Value = "OK"

-Else

-Range("D159").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatBIFF(ByRef num)

-Range("A160").Clear

-Range("B160").Clear

-Range("C160").Clear

-Range("D160").Clear

-Range("A160").Value = "xlClipboardFormatBIFF"

-Range("B160").Value = 8

-Range("C160").Value = num

-B160 = Range("B160").Value

-C160 = Range("C160").Value

-If B160 = C160 Then

-Range("D160").Value = "OK"

-Else

-Range("D160").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatBIFF2(ByRef num)

-Range("A161").Clear

-Range("B161").Clear

-Range("C161").Clear

-Range("D161").Clear

-Range("A161").Value = "xlClipboardFormatBIFF2"

-Range("B161").Value = 18

-Range("C161").Value = num

-B161 = Range("B161").Value

-C161 = Range("C161").Value

-If B161 = C161 Then

-Range("D161").Value = "OK"

-Else

-Range("D161").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatBIFF3(ByRef num)

-Range("A162").Clear

-Range("B162").Clear

-Range("C162").Clear

-Range("D162").Clear

-Range("A162").Value = "xlClipboardFormatBIFF3"

-Range("B162").Value = 20

-Range("C162").Value = num

-B162 = Range("B162").Value

-C162 = Range("C162").Value

-If B162 = C162 Then

-Range("D162").Value = "OK"

-Else

-Range("D162").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatBIFF4(ByRef num)

-Range("A163").Clear

-Range("B163").Clear

-Range("C163").Clear

-Range("D163").Clear

-Range("A163").Value = "xlClipboardFormatBIFF4"

-Range("B163").Value = 30

-Range("C163").Value = num

-B163 = Range("B163").Value

-C163 = Range("C163").Value

-If B163 = C163 Then

-Range("D163").Value = "OK"

-Else

-Range("D163").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatBinary(ByRef num)

-Range("A164").Clear

-Range("B164").Clear

-Range("C164").Clear

-Range("D164").Clear

-Range("A164").Value = "xlClipboardFormatBinary"

-Range("B164").Value = 15

-Range("C164").Value = num

-B164 = Range("B164").Value

-C164 = Range("C164").Value

-If B164 = C164 Then

-Range("D164").Value = "OK"

-Else

-Range("D164").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatBitmap(ByRef num)

-Range("A165").Clear

-Range("B165").Clear

-Range("C165").Clear

-Range("D165").Clear

-Range("A165").Value = "xlClipboardFormatBitmap"

-Range("B165").Value = 9

-Range("C165").Value = num

-B165 = Range("B165").Value

-C165 = Range("C165").Value

-If B165 = C165 Then

-Range("D165").Value = "OK"

-Else

-Range("D165").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatCGM(ByRef num)

-Range("A166").Clear

-Range("B166").Clear

-Range("C166").Clear

-Range("D166").Clear

-Range("A166").Value = "xlClipboardFormatCGM"

-Range("B166").Value = 13

-Range("C166").Value = num

-B166 = Range("B166").Value

-C166 = Range("C166").Value

-If B166 = C166 Then

-Range("D166").Value = "OK"

-Else

-Range("D166").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatCSV(ByRef num)

-Range("A167").Clear

-Range("B167").Clear

-Range("C167").Clear

-Range("D167").Clear

-Range("A167").Value = "xlClipboardFormatCSV"

-Range("B167").Value = 5

-Range("C167").Value = num

-B167 = Range("B167").Value

-C167 = Range("C167").Value

-If B167 = C167 Then

-Range("D167").Value = "OK"

-Else

-Range("D167").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatDIF(ByRef num)

-Range("A168").Clear

-Range("B168").Clear

-Range("C168").Clear

-Range("D168").Clear

-Range("A168").Value = "xlClipboardFormatDIF"

-Range("B168").Value = 4

-Range("C168").Value = num

-B168 = Range("B168").Value

-C168 = Range("C168").Value

-If B168 = C168 Then

-Range("D168").Value = "OK"

-Else

-Range("D168").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatDspText(ByRef num)

-Range("A169").Clear

-Range("B169").Clear

-Range("C169").Clear

-Range("D169").Clear

-Range("A169").Value = "xlClipboardFormatDspText"

-Range("B169").Value = 12

-Range("C169").Value = num

-B169 = Range("B169").Value

-C169 = Range("C169").Value

-If B169 = C169 Then

-Range("D169").Value = "OK"

-Else

-Range("D169").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatEmbeddedObject(ByRef num)

-Range("A170").Clear

-Range("B170").Clear

-Range("C170").Clear

-Range("D170").Clear

-Range("A170").Value = "xlClipboardFormatEmbeddedObject"

-Range("B170").Value = 21

-Range("C170").Value = num

-B170 = Range("B170").Value

-C170 = Range("C170").Value

-If B170 = C170 Then

-Range("D170").Value = "OK"

-Else

-Range("D170").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatEmbedSource(ByRef num)

-Range("A171").Clear

-Range("B171").Clear

-Range("C171").Clear

-Range("D171").Clear

-Range("A171").Value = "xlClipboardFormatEmbedSource"

-Range("B171").Value = 22

-Range("C171").Value = num

-B171 = Range("B171").Value

-C171 = Range("C171").Value

-If B171 = C171 Then

-Range("D171").Value = "OK"

-Else

-Range("D171").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatLink(ByRef num)

-Range("A172").Clear

-Range("B172").Clear

-Range("C172").Clear

-Range("D172").Clear

-Range("A172").Value = "xlClipboardFormatLink"

-Range("B172").Value = 11

-Range("C172").Value = num

-B172 = Range("B172").Value

-C172 = Range("C172").Value

-If B172 = C172 Then

-Range("D172").Value = "OK"

-Else

-Range("D172").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatLinkSource(ByRef num)

-Range("A173").Clear

-Range("B173").Clear

-Range("C173").Clear

-Range("D173").Clear

-Range("A173").Value = "xlClipboardFormatLinkSource"

-Range("B173").Value = 23

-Range("C173").Value = num

-B173 = Range("B173").Value

-C173 = Range("C173").Value

-If B173 = C173 Then

-Range("D173").Value = "OK"

-Else

-Range("D173").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatLinkSourceDesc(ByRef num)

-Range("A174").Clear

-Range("B174").Clear

-Range("C174").Clear

-Range("D174").Clear

-Range("A174").Value = "xlClipboardFormatLinkSourceDesc"

-Range("B174").Value = 32

-Range("C174").Value = num

-B174 = Range("B174").Value

-C174 = Range("C174").Value

-If B174 = C174 Then

-Range("D174").Value = "OK"

-Else

-Range("D174").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatMovie(ByRef num)

-Range("A175").Clear

-Range("B175").Clear

-Range("C175").Clear

-Range("D175").Clear

-Range("A175").Value = "xlClipboardFormatMovie"

-Range("B175").Value = 24

-Range("C175").Value = num

-B175 = Range("B175").Value

-C175 = Range("C175").Value

-If B175 = C175 Then

-Range("D175").Value = "OK"

-Else

-Range("D175").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatNative(ByRef num)

-Range("A176").Clear

-Range("B176").Clear

-Range("C176").Clear

-Range("D176").Clear

-Range("A176").Value = "xlClipboardFormatNative"

-Range("B176").Value = 14

-Range("C176").Value = num

-B176 = Range("B176").Value

-C176 = Range("C176").Value

-If B176 = C176 Then

-Range("D176").Value = "OK"

-Else

-Range("D176").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatObjectDesc(ByRef num)

-Range("A177").Clear

-Range("B177").Clear

-Range("C177").Clear

-Range("D177").Clear

-Range("A177").Value = "xlClipboardFormatObjectDesc"

-Range("B177").Value = 31

-Range("C177").Value = num

-B177 = Range("B177").Value

-C177 = Range("C177").Value

-If B177 = C177 Then

-Range("D177").Value = "OK"

-Else

-Range("D177").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatObjectLink(ByRef num)

-Range("A178").Clear

-Range("B178").Clear

-Range("C178").Clear

-Range("D178").Clear

-Range("A178").Value = "xlClipboardFormatObjectLink"

-Range("B178").Value = 19

-Range("C178").Value = num

-B178 = Range("B178").Value

-C178 = Range("C178").Value

-If B178 = C178 Then

-Range("D178").Value = "OK"

-Else

-Range("D178").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatOwnerLink(ByRef num)

-Range("A179").Clear

-Range("B179").Clear

-Range("C179").Clear

-Range("D179").Clear

-Range("A179").Value = "xlClipboardFormatOwnerLink"

-Range("B179").Value = 17

-Range("C179").Value = num

-B179 = Range("B179").Value

-C179 = Range("C179").Value

-If B179 = C179 Then

-Range("D179").Value = "OK"

-Else

-Range("D179").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatPICT(ByRef num)

-Range("A180").Clear

-Range("B180").Clear

-Range("C180").Clear

-Range("D180").Clear

-Range("A180").Value = "xlClipboardFormatPICT"

-Range("B180").Value = 2

-Range("C180").Value = num

-B180 = Range("B180").Value

-C180 = Range("C180").Value

-If B180 = C180 Then

-Range("D180").Value = "OK"

-Else

-Range("D180").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatPrintPICT(ByRef num)

-Range("A181").Clear

-Range("B181").Clear

-Range("C181").Clear

-Range("D181").Clear

-Range("A181").Value = "xlClipboardFormatPrintPICT"

-Range("B181").Value = 3

-Range("C181").Value = num

-B181 = Range("B181").Value

-C181 = Range("C181").Value

-If B181 = C181 Then

-Range("D181").Value = "OK"

-Else

-Range("D181").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatRTF(ByRef num)

-Range("A182").Clear

-Range("B182").Clear

-Range("C182").Clear

-Range("D182").Clear

-Range("A182").Value = "xlClipboardFormatRTF"

-Range("B182").Value = 7

-Range("C182").Value = num

-B182 = Range("B182").Value

-C182 = Range("C182").Value

-If B182 = C182 Then

-Range("D182").Value = "OK"

-Else

-Range("D182").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatScreenPICT(ByRef num)

-Range("A183").Clear

-Range("B183").Clear

-Range("C183").Clear

-Range("D183").Clear

-Range("A183").Value = "xlClipboardFormatScreenPICT"

-Range("B183").Value = 29

-Range("C183").Value = num

-B183 = Range("B183").Value

-C183 = Range("C183").Value

-If B183 = C183 Then

-Range("D183").Value = "OK"

-Else

-Range("D183").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatStandardFont(ByRef num)

-Range("A184").Clear

-Range("B184").Clear

-Range("C184").Clear

-Range("D184").Clear

-Range("A184").Value = "xlClipboardFormatStandardFont"

-Range("B184").Value = 28

-Range("C184").Value = num

-B184 = Range("B184").Value

-C184 = Range("C184").Value

-If B184 = C184 Then

-Range("D184").Value = "OK"

-Else

-Range("D184").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatStandardScale(ByRef num)

-Range("A185").Clear

-Range("B185").Clear

-Range("C185").Clear

-Range("D185").Clear

-Range("A185").Value = "xlClipboardFormatStandardScale"

-Range("B185").Value = 27

-Range("C185").Value = num

-B185 = Range("B185").Value

-C185 = Range("C185").Value

-If B185 = C185 Then

-Range("D185").Value = "OK"

-Else

-Range("D185").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatSYLK(ByRef num)

-Range("A186").Clear

-Range("B186").Clear

-Range("C186").Clear

-Range("D186").Clear

-Range("A186").Value = "xlClipboardFormatSYLK"

-Range("B186").Value = 6

-Range("C186").Value = num

-B186 = Range("B186").Value

-C186 = Range("C186").Value

-If B186 = C186 Then

-Range("D186").Value = "OK"

-Else

-Range("D186").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatTable(ByRef num)

-Range("A187").Clear

-Range("B187").Clear

-Range("C187").Clear

-Range("D187").Clear

-Range("A187").Value = "xlClipboardFormatTable"

-Range("B187").Value = 16

-Range("C187").Value = num

-B187 = Range("B187").Value

-C187 = Range("C187").Value

-If B187 = C187 Then

-Range("D187").Value = "OK"

-Else

-Range("D187").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatText(ByRef num)

-Range("A188").Clear

-Range("B188").Clear

-Range("C188").Clear

-Range("D188").Clear

-Range("A188").Value = "xlClipboardFormatText"

-Range("B188").Value = 0

-Range("C188").Value = num

-B188 = Range("B188").Value

-C188 = Range("C188").Value

-If B188 = C188 Then

-Range("D188").Value = "OK"

-Else

-Range("D188").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatToolFace(ByRef num)

-Range("A189").Clear

-Range("B189").Clear

-Range("C189").Clear

-Range("D189").Clear

-Range("A189").Value = "xlClipboardFormatToolFace"

-Range("B189").Value = 25

-Range("C189").Value = num

-B189 = Range("B189").Value

-C189 = Range("C189").Value

-If B189 = C189 Then

-Range("D189").Value = "OK"

-Else

-Range("D189").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatToolFacePICT(ByRef num)

-Range("A190").Clear

-Range("B190").Clear

-Range("C190").Clear

-Range("D190").Clear

-Range("A190").Value = "xlClipboardFormatToolFacePICT"

-Range("B190").Value = 26

-Range("C190").Value = num

-B190 = Range("B190").Value

-C190 = Range("C190").Value

-If B190 = C190 Then

-Range("D190").Value = "OK"

-Else

-Range("D190").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatToolVALU(ByRef num)

-Range("A191").Clear

-Range("B191").Clear

-Range("C191").Clear

-Range("D191").Clear

-Range("A191").Value = "xlClipboardFormatToolVALU"

-Range("B191").Value = 1

-Range("C191").Value = num

-B191 = Range("B191").Value

-C191 = Range("C191").Value

-If B191 = C191 Then

-Range("D191").Value = "OK"

-Else

-Range("D191").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboardFormatToolWK1(ByRef num)

-Range("A192").Clear

-Range("B192").Clear

-Range("C192").Clear

-Range("D192").Clear

-Range("A192").Value = "xlClipboardFormatToolWK1"

-Range("B192").Value = 10

-Range("C192").Value = num

-B192 = Range("B192").Value

-C192 = Range("C192").Value

-If B192 = C192 Then

-Range("D192").Value = "OK"

-Else

-Range("D192").Value = "NG"

-End If

-End Function

-

-Function test_xlCmdCube(ByRef num)

-Range("A193").Clear

-Range("B193").Clear

-Range("C193").Clear

-Range("D193").Clear

-Range("A193").Value = "xlCmdCube"

-Range("B193").Value = 1

-Range("C193").Value = num

-B193 = Range("B193").Value

-C193 = Range("C193").Value

-If B193 = C193 Then

-Range("D193").Value = "OK"

-Else

-Range("D193").Value = "NG"

-End If

-End Function

-

-Function test_xlCmdDefault(ByRef num)

-Range("A194").Clear

-Range("B194").Clear

-Range("C194").Clear

-Range("D194").Clear

-Range("A194").Value = "xlCmdDefault"

-Range("B194").Value = 4

-Range("C194").Value = num

-B194 = Range("B194").Value

-C194 = Range("C194").Value

-If B194 = C194 Then

-Range("D194").Value = "OK"

-Else

-Range("D194").Value = "NG"

-End If

-End Function

-

-Function test_xlCmdList(ByRef num)

-Range("A195").Clear

-Range("B195").Clear

-Range("C195").Clear

-Range("D195").Clear

-Range("A195").Value = "xlCmdList"

-Range("B195").Value = 5

-Range("C195").Value = num

-B195 = Range("B195").Value

-C195 = Range("C195").Value

-If B195 = C195 Then

-Range("D195").Value = "OK"

-Else

-Range("D195").Value = "NG"

-End If

-End Function

-

-Function test_xlCmdSql(ByRef num)

-Range("A196").Clear

-Range("B196").Clear

-Range("C196").Clear

-Range("D196").Clear

-Range("A196").Value = "xlCmdSql"

-Range("B196").Value = 2

-Range("C196").Value = num

-B196 = Range("B196").Value

-C196 = Range("C196").Value

-If B196 = C196 Then

-Range("D196").Value = "OK"

-Else

-Range("D196").Value = "NG"

-End If

-End Function

-

-Function test_xlCmdTable(ByRef num)

-Range("A197").Clear

-Range("B197").Clear

-Range("C197").Clear

-Range("D197").Clear

-Range("A197").Value = "xlCmdTable"

-Range("B197").Value = 3

-Range("C197").Value = num

-B197 = Range("B197").Value

-C197 = Range("C197").Value

-If B197 = C197 Then

-Range("D197").Value = "OK"

-Else

-Range("D197").Value = "NG"

-End If

-End Function

-

-Function test_xlColorIndexAutomatic(ByRef num)

-Range("A198").Clear

-Range("B198").Clear

-Range("C198").Clear

-Range("D198").Clear

-Range("A198").Value = "xlColorIndexAutomatic"

-Range("B198").Value = -4105

-Range("C198").Value = num

-B198 = Range("B198").Value

-C198 = Range("C198").Value

-If B198 = C198 Then

-Range("D198").Value = "OK"

-Else

-Range("D198").Value = "NG"

-End If

-End Function

-

-Function test_xlColorIndexNone(ByRef num)

-Range("A199").Clear

-Range("B199").Clear

-Range("C199").Clear

-Range("D199").Clear

-Range("A199").Value = "xlColorIndexNone"

-Range("B199").Value = -4142

-Range("C199").Value = num

-B199 = Range("B199").Value

-C199 = Range("C199").Value

-If B199 = C199 Then

-Range("D199").Value = "OK"

-Else

-Range("D199").Value = "NG"

-End If

-End Function

-

-Function test_xlDMYFormat(ByRef num)

-Range("A200").Clear

-Range("B200").Clear

-Range("C200").Clear

-Range("D200").Clear

-Range("A200").Value = "xlDMYFormat"

-Range("B200").Value = 4

-Range("C200").Value = num

-B200 = Range("B200").Value

-C200 = Range("C200").Value

-If B200 = C200 Then

-Range("D200").Value = "OK"

-Else

-Range("D200").Value = "NG"

-End If

-End Function

-

-Function test_xlDYMFormat(ByRef num)

-Range("A201").Clear

-Range("B201").Clear

-Range("C201").Clear

-Range("D201").Clear

-Range("A201").Value = "xlDYMFormat"

-Range("B201").Value = 7

-Range("C201").Value = num

-B201 = Range("B201").Value

-C201 = Range("C201").Value

-If B201 = C201 Then

-Range("D201").Value = "OK"

-Else

-Range("D201").Value = "NG"

-End If

-End Function

-

-Function test_xlEMDFormat(ByRef num)

-Range("A202").Clear

-Range("B202").Clear

-Range("C202").Clear

-Range("D202").Clear

-Range("A202").Value = "xlEMDFormat"

-Range("B202").Value = 10

-Range("C202").Value = num

-B202 = Range("B202").Value

-C202 = Range("C202").Value

-If B202 = C202 Then

-Range("D202").Value = "OK"

-Else

-Range("D202").Value = "NG"

-End If

-End Function

-

-Function test_xlGeneralFormat(ByRef num)

-Range("A203").Clear

-Range("B203").Clear

-Range("C203").Clear

-Range("D203").Clear

-Range("A203").Value = "xlGeneralFormat"

-Range("B203").Value = 1

-Range("C203").Value = num

-B203 = Range("B203").Value

-C203 = Range("C203").Value

-If B203 = C203 Then

-Range("D203").Value = "OK"

-Else

-Range("D203").Value = "NG"

-End If

-End Function

-

-Function test_xlMDYFormat(ByRef num)

-Range("A204").Clear

-Range("B204").Clear

-Range("C204").Clear

-Range("D204").Clear

-Range("A204").Value = "xlMDYFormat"

-Range("B204").Value = 3

-Range("C204").Value = num

-B204 = Range("B204").Value

-C204 = Range("C204").Value

-If B204 = C204 Then

-Range("D204").Value = "OK"

-Else

-Range("D204").Value = "NG"

-End If

-End Function

-

-Function test_xlMYDFormat(ByRef num)

-Range("A205").Clear

-Range("B205").Clear

-Range("C205").Clear

-Range("D205").Clear

-Range("A205").Value = "xlMYDFormat"

-Range("B205").Value = 6

-Range("C205").Value = num

-B205 = Range("B205").Value

-C205 = Range("C205").Value

-If B205 = C205 Then

-Range("D205").Value = "OK"

-Else

-Range("D205").Value = "NG"

-End If

-End Function

-

-Function test_xlSkipColumn(ByRef num)

-Range("A206").Clear

-Range("B206").Clear

-Range("C206").Clear

-Range("D206").Clear

-Range("A206").Value = "xlSkipColumn"

-Range("B206").Value = 9

-Range("C206").Value = num

-B206 = Range("B206").Value

-C206 = Range("C206").Value

-If B206 = C206 Then

-Range("D206").Value = "OK"

-Else

-Range("D206").Value = "NG"

-End If

-End Function

-

-Function test_xlTextFormat(ByRef num)

-Range("A207").Clear

-Range("B207").Clear

-Range("C207").Clear

-Range("D207").Clear

-Range("A207").Value = "xlTextFormat"

-Range("B207").Value = 2

-Range("C207").Value = num

-B207 = Range("B207").Value

-C207 = Range("C207").Value

-If B207 = C207 Then

-Range("D207").Value = "OK"

-Else

-Range("D207").Value = "NG"

-End If

-End Function

-

-Function test_xlYDMFormat(ByRef num)

-Range("A208").Clear

-Range("B208").Clear

-Range("C208").Clear

-Range("D208").Clear

-Range("A208").Value = "xlYDMFormat"

-Range("B208").Value = 8

-Range("C208").Value = num

-B208 = Range("B208").Value

-C208 = Range("C208").Value

-If B208 = C208 Then

-Range("D208").Value = "OK"

-Else

-Range("D208").Value = "NG"

-End If

-End Function

-

-Function test_xlYMDFormat(ByRef num)

-Range("A209").Clear

-Range("B209").Clear

-Range("C209").Clear

-Range("D209").Clear

-Range("A209").Value = "xlYMDFormat"

-Range("B209").Value = 5

-Range("C209").Value = num

-B209 = Range("B209").Value

-C209 = Range("C209").Value

-If B209 = C209 Then

-Range("D209").Value = "OK"

-Else

-Range("D209").Value = "NG"

-End If

-End Function

-

-Function test_xlCommandUnderlinesAutomatic(ByRef num)

-Range("A210").Clear

-Range("B210").Clear

-Range("C210").Clear

-Range("D210").Clear

-Range("A210").Value = "xlCommandUnderlinesAutomatic"

-Range("B210").Value = -4105

-Range("C210").Value = num

-B210 = Range("B210").Value

-C210 = Range("C210").Value

-If B210 = C210 Then

-Range("D210").Value = "OK"

-Else

-Range("D210").Value = "NG"

-End If

-End Function

-

-Function test_xlCommandUnderlinesOff(ByRef num)

-Range("A211").Clear

-Range("B211").Clear

-Range("C211").Clear

-Range("D211").Clear

-Range("A211").Value = "xlCommandUnderlinesOff"

-Range("B211").Value = -4146

-Range("C211").Value = num

-B211 = Range("B211").Value

-C211 = Range("C211").Value

-If B211 = C211 Then

-Range("D211").Value = "OK"

-Else

-Range("D211").Value = "NG"

-End If

-End Function

-

-Function test_xlCommandUnderlinesOn(ByRef num)

-Range("A212").Clear

-Range("B212").Clear

-Range("C212").Clear

-Range("D212").Clear

-Range("A212").Value = "xlCommandUnderlinesOn"

-Range("B212").Value = 1

-Range("C212").Value = num

-B212 = Range("B212").Value

-C212 = Range("C212").Value

-If B212 = C212 Then

-Range("D212").Value = "OK"

-Else

-Range("D212").Value = "NG"

-End If

-End Function

-

-Function test_xlCommentAndIndicator(ByRef num)

-Range("A213").Clear

-Range("B213").Clear

-Range("C213").Clear

-Range("D213").Clear

-Range("A213").Value = "xlCommentAndIndicator"

-Range("B213").Value = 1

-Range("C213").Value = num

-B213 = Range("B213").Value

-C213 = Range("C213").Value

-If B213 = C213 Then

-Range("D213").Value = "OK"

-Else

-Range("D213").Value = "NG"

-End If

-End Function

-

-Function test_xlCommentIndicatorOnly(ByRef num)

-Range("A214").Clear

-Range("B214").Clear

-Range("C214").Clear

-Range("D214").Clear

-Range("A214").Value = "xlCommentIndicatorOnly"

-Range("B214").Value = -1

-Range("C214").Value = num

-B214 = Range("B214").Value

-C214 = Range("C214").Value

-If B214 = C214 Then

-Range("D214").Value = "OK"

-Else

-Range("D214").Value = "NG"

-End If

-End Function

-

-Function test_xlNoIndicator(ByRef num)

-Range("A215").Clear

-Range("B215").Clear

-Range("C215").Clear

-Range("D215").Clear

-Range("A215").Value = "xlNoIndicator"

-Range("B215").Value = 0

-Range("C215").Value = num

-B215 = Range("B215").Value

-C215 = Range("C215").Value

-If B215 = C215 Then

-Range("D215").Value = "OK"

-Else

-Range("D215").Value = "NG"

-End If

-End Function

-

-Function test_xlAverage(ByRef num)

-Range("A216").Clear

-Range("B216").Clear

-Range("C216").Clear

-Range("D216").Clear

-Range("A216").Value = "xlAverage"

-Range("B216").Value = -4106

-Range("C216").Value = num

-B216 = Range("B216").Value

-C216 = Range("C216").Value

-If B216 = C216 Then

-Range("D216").Value = "OK"

-Else

-Range("D216").Value = "NG"

-End If

-End Function

-

-Function test_xlCount(ByRef num)

-Range("A217").Clear

-Range("B217").Clear

-Range("C217").Clear

-Range("D217").Clear

-Range("A217").Value = "xlCount"

-Range("B217").Value = -4112

-Range("C217").Value = num

-B217 = Range("B217").Value

-C217 = Range("C217").Value

-If B217 = C217 Then

-Range("D217").Value = "OK"

-Else

-Range("D217").Value = "NG"

-End If

-End Function

-

-Function test_xlCountNums(ByRef num)

-Range("A218").Clear

-Range("B218").Clear

-Range("C218").Clear

-Range("D218").Clear

-Range("A218").Value = "xlCountNums"

-Range("B218").Value = -4113

-Range("C218").Value = num

-B218 = Range("B218").Value

-C218 = Range("C218").Value

-If B218 = C218 Then

-Range("D218").Value = "OK"

-Else

-Range("D218").Value = "NG"

-End If

-End Function

-

-Function test_xlMax(ByRef num)

-Range("A219").Clear

-Range("B219").Clear

-Range("C219").Clear

-Range("D219").Clear

-Range("A219").Value = "xlMax"

-Range("B219").Value = -4136

-Range("C219").Value = num

-B219 = Range("B219").Value

-C219 = Range("C219").Value

-If B219 = C219 Then

-Range("D219").Value = "OK"

-Else

-Range("D219").Value = "NG"

-End If

-End Function

-

-Function test_xlMin(ByRef num)

-Range("A220").Clear

-Range("B220").Clear

-Range("C220").Clear

-Range("D220").Clear

-Range("A220").Value = "xlMin"

-Range("B220").Value = -4139

-Range("C220").Value = num

-B220 = Range("B220").Value

-C220 = Range("C220").Value

-If B220 = C220 Then

-Range("D220").Value = "OK"

-Else

-Range("D220").Value = "NG"

-End If

-End Function

-

-Function test_xlProduct(ByRef num)

-Range("A221").Clear

-Range("B221").Clear

-Range("C221").Clear

-Range("D221").Clear

-Range("A221").Value = "xlProduct"

-Range("B221").Value = -4149

-Range("C221").Value = num

-B221 = Range("B221").Value

-C221 = Range("C221").Value

-If B221 = C221 Then

-Range("D221").Value = "OK"

-Else

-Range("D221").Value = "NG"

-End If

-End Function

-

-Function test_xlStDev(ByRef num)

-Range("A222").Clear

-Range("B222").Clear

-Range("C222").Clear

-Range("D222").Clear

-Range("A222").Value = "xlStDev"

-Range("B222").Value = -4155

-Range("C222").Value = num

-B222 = Range("B222").Value

-C222 = Range("C222").Value

-If B222 = C222 Then

-Range("D222").Value = "OK"

-Else

-Range("D222").Value = "NG"

-End If

-End Function

-

-Function test_xlStDevP(ByRef num)

-Range("A223").Clear

-Range("B223").Clear

-Range("C223").Clear

-Range("D223").Clear

-Range("A223").Value = "xlStDevP"

-Range("B223").Value = -4156

-Range("C223").Value = num

-B223 = Range("B223").Value

-C223 = Range("C223").Value

-If B223 = C223 Then

-Range("D223").Value = "OK"

-Else

-Range("D223").Value = "NG"

-End If

-End Function

-

-Function test_xlSum(ByRef num)

-Range("A224").Clear

-Range("B224").Clear

-Range("C224").Clear

-Range("D224").Clear

-Range("A224").Value = "xlSum"

-Range("B224").Value = -4157

-Range("C224").Value = num

-B224 = Range("B224").Value

-C224 = Range("C224").Value

-If B224 = C224 Then

-Range("D224").Value = "OK"

-Else

-Range("D224").Value = "NG"

-End If

-End Function

-

-Function test_xlUnknown(ByRef num)

-Range("A225").Clear

-Range("B225").Clear

-Range("C225").Clear

-Range("D225").Clear

-Range("A225").Value = "xlUnknown"

-Range("B225").Value = 1000

-Range("C225").Value = num

-B225 = Range("B225").Value

-C225 = Range("C225").Value

-If B225 = C225 Then

-Range("D225").Value = "OK"

-Else

-Range("D225").Value = "NG"

-End If

-End Function

-

-Function test_xlVar(ByRef num)

-Range("A226").Clear

-Range("B226").Clear

-Range("C226").Clear

-Range("D226").Clear

-Range("A226").Value = "xlVar"

-Range("B226").Value = -4164

-Range("C226").Value = num

-B226 = Range("B226").Value

-C226 = Range("C226").Value

-If B226 = C226 Then

-Range("D226").Value = "OK"

-Else

-Range("D226").Value = "NG"

-End If

-End Function

-

-Function test_xlVarP(ByRef num)

-Range("A227").Clear

-Range("B227").Clear

-Range("C227").Clear

-Range("D227").Clear

-Range("A227").Value = "xlVarP"

-Range("B227").Value = -4165

-Range("C227").Value = num

-B227 = Range("B227").Value

-C227 = Range("C227").Value

-If B227 = C227 Then

-Range("D227").Value = "OK"

-Else

-Range("D227").Value = "NG"

-End If

-End Function

-

-Function test_xlBitmap(ByRef num)

-Range("A228").Clear

-Range("B228").Clear

-Range("C228").Clear

-Range("D228").Clear

-Range("A228").Value = "xlBitmap"

-Range("B228").Value = 2

-Range("C228").Value = num

-B228 = Range("B228").Value

-C228 = Range("C228").Value

-If B228 = C228 Then

-Range("D228").Value = "OK"

-Else

-Range("D228").Value = "NG"

-End If

-End Function

-

-Function test_xlPicture(ByRef num)

-Range("A229").Clear

-Range("B229").Clear

-Range("C229").Clear

-Range("D229").Clear

-Range("A229").Value = "xlPicture"

-Range("B229").Value = -4147

-Range("C229").Value = num

-B229 = Range("B229").Value

-C229 = Range("C229").Value

-If B229 = C229 Then

-Range("D229").Value = "OK"

-Else

-Range("D229").Value = "NG"

-End If

-End Function

-

-Function test_xlExtractData(ByRef num)

-Range("A230").Clear

-Range("B230").Clear

-Range("C230").Clear

-Range("D230").Clear

-Range("A230").Value = "xlExtractData"

-Range("B230").Value = 2

-Range("C230").Value = num

-B230 = Range("B230").Value

-C230 = Range("C230").Value

-If B230 = C230 Then

-Range("D230").Value = "OK"

-Else

-Range("D230").Value = "NG"

-End If

-End Function

-

-Function test_xlNormalLoad(ByRef num)

-Range("A231").Clear

-Range("B231").Clear

-Range("C231").Clear

-Range("D231").Clear

-Range("A231").Value = "xlNormalLoad"

-Range("B231").Value = 0

-Range("C231").Value = num

-B231 = Range("B231").Value

-C231 = Range("C231").Value

-If B231 = C231 Then

-Range("D231").Value = "OK"

-Else

-Range("D231").Value = "NG"

-End If

-End Function

-

-Function test_xlRepairFile(ByRef num)

-Range("A232").Clear

-Range("B232").Clear

-Range("C232").Clear

-Range("D232").Clear

-Range("A232").Value = "xlRepairFile"

-Range("B232").Value = 1

-Range("C232").Value = num

-B232 = Range("B232").Value

-C232 = Range("C232").Value

-If B232 = C232 Then

-Range("D232").Value = "OK"

-Else

-Range("D232").Value = "NG"

-End If

-End Function

-

-Function test_xlCreatorCode(ByRef num)

-Range("A233").Clear

-Range("B233").Clear

-Range("C233").Clear

-Range("D233").Clear

-Range("A233").Value = "xlCreatorCode"

-Range("B233").Value = 1480803660

-Range("C233").Value = num

-B233 = Range("B233").Value

-C233 = Range("C233").Value

-If B233 = C233 Then

-Range("D233").Value = "OK"

-Else

-Range("D233").Value = "NG"

-End If

-End Function

-

-Function test_xlHierarchy(ByRef num)

-Range("A234").Clear

-Range("B234").Clear

-Range("C234").Clear

-Range("D234").Clear

-Range("A234").Value = "xlHierarchy"

-Range("B234").Value = 1

-Range("C234").Value = num

-B234 = Range("B234").Value

-C234 = Range("C234").Value

-If B234 = C234 Then

-Range("D234").Value = "OK"

-Else

-Range("D234").Value = "NG"

-End If

-End Function

-

-Function test_xlMeasure(ByRef num)

-Range("A235").Clear

-Range("B235").Clear

-Range("C235").Clear

-Range("D235").Clear

-Range("A235").Value = "xlMeasure"

-Range("B235").Value = 2

-Range("C235").Value = num

-B235 = Range("B235").Value

-C235 = Range("C235").Value

-If B235 = C235 Then

-Range("D235").Value = "OK"

-Else

-Range("D235").Value = "NG"

-End If

-End Function

-

-Function test_xlSet(ByRef num)

-Range("A236").Clear

-Range("B236").Clear

-Range("C236").Clear

-Range("D236").Clear

-Range("A236").Value = "xlSet"

-Range("B236").Value = 3

-Range("C236").Value = num

-B236 = Range("B236").Value

-C236 = Range("C236").Value

-If B236 = C236 Then

-Range("D236").Value = "OK"

-Else

-Range("D236").Value = "NG"

-End If

-End Function

-

-Function test_xlCopy(ByRef num)

-Range("A237").Clear

-Range("B237").Clear

-Range("C237").Clear

-Range("D237").Clear

-Range("A237").Value = "xlCopy"

-Range("B237").Value = 1

-Range("C237").Value = num

-B237 = Range("B237").Value

-C237 = Range("C237").Value

-If B237 = C237 Then

-Range("D237").Value = "OK"

-Else

-Range("D237").Value = "NG"

-End If

-End Function

-

-Function test_xlCut(ByRef num)

-Range("A238").Clear

-Range("B238").Clear

-Range("C238").Clear

-Range("D238").Clear

-Range("A238").Value = "xlCut"

-Range("B238").Value = 2

-Range("C238").Value = num

-B238 = Range("B238").Value

-C238 = Range("C238").Value

-If B238 = C238 Then

-Range("D238").Value = "OK"

-Else

-Range("D238").Value = "NG"

-End If

-End Function

-

-Function test_xlValidAlterInformation(ByRef num)

-Range("A239").Clear

-Range("B239").Clear

-Range("C239").Clear

-Range("D239").Clear

-Range("A239").Value = "xlValidAlterInformation"

-Range("B239").Value = 3

-Range("C239").Value = num

-B239 = Range("B239").Value

-C239 = Range("C239").Value

-If B239 = C239 Then

-Range("D239").Value = "OK"

-Else

-Range("D239").Value = "NG"

-End If

-End Function

-

-Function test_xlValidAlterStop(ByRef num)

-Range("A240").Clear

-Range("B240").Clear

-Range("C240").Clear

-Range("D240").Clear

-Range("A240").Value = "xlValidAlterStop"

-Range("B240").Value = 1

-Range("C240").Value = num

-B240 = Range("B240").Value

-C240 = Range("C240").Value

-If B240 = C240 Then

-Range("D240").Value = "OK"

-Else

-Range("D240").Value = "NG"

-End If

-End Function

-

-Function test_xlValidAlterWarning(ByRef num)

-Range("A241").Clear

-Range("B241").Clear

-Range("C241").Clear

-Range("D241").Clear

-Range("A241").Value = "xlValidAlterWarning"

-Range("B241").Value = 2

-Range("C241").Value = num

-B241 = Range("B241").Value

-C241 = Range("C241").Value

-If B241 = C241 Then

-Range("D241").Value = "OK"

-Else

-Range("D241").Value = "NG"

-End If

-End Function

-

-Function test_xlValidateCustom(ByRef num)

-Range("A242").Clear

-Range("B242").Clear

-Range("C242").Clear

-Range("D242").Clear

-Range("A242").Value = "xlValidateCustom"

-Range("B242").Value = 7

-Range("C242").Value = num

-B242 = Range("B242").Value

-C242 = Range("C242").Value

-If B242 = C242 Then

-Range("D242").Value = "OK"

-Else

-Range("D242").Value = "NG"

-End If

-End Function

-

-Function test_xlValidateDate(ByRef num)

-Range("A243").Clear

-Range("B243").Clear

-Range("C243").Clear

-Range("D243").Clear

-Range("A243").Value = "xlValidateDate"

-Range("B243").Value = 4

-Range("C243").Value = num

-B243 = Range("B243").Value

-C243 = Range("C243").Value

-If B243 = C243 Then

-Range("D243").Value = "OK"

-Else

-Range("D243").Value = "NG"

-End If

-End Function

-

-Function test_xlValidateDecimal(ByRef num)

-Range("A244").Clear

-Range("B244").Clear

-Range("C244").Clear

-Range("D244").Clear

-Range("A244").Value = "xlValidateDecimal"

-Range("B244").Value = 2

-Range("C244").Value = num

-B244 = Range("B244").Value

-C244 = Range("C244").Value

-If B244 = C244 Then

-Range("D244").Value = "OK"

-Else

-Range("D244").Value = "NG"

-End If

-End Function

-

-Function test_xlValidateInputOnly(ByRef num)

-Range("A245").Clear

-Range("B245").Clear

-Range("C245").Clear

-Range("D245").Clear

-Range("A245").Value = "xlValidateInputOnly"

-Range("B245").Value = 0

-Range("C245").Value = num

-B245 = Range("B245").Value

-C245 = Range("C245").Value

-If B245 = C245 Then

-Range("D245").Value = "OK"

-Else

-Range("D245").Value = "NG"

-End If

-End Function

-

-Function test_xlValidateList(ByRef num)

-Range("A246").Clear

-Range("B246").Clear

-Range("C246").Clear

-Range("D246").Clear

-Range("A246").Value = "xlValidateList"

-Range("B246").Value = 3

-Range("C246").Value = num

-B246 = Range("B246").Value

-C246 = Range("C246").Value

-If B246 = C246 Then

-Range("D246").Value = "OK"

-Else

-Range("D246").Value = "NG"

-End If

-End Function

-

-Function test_xlValidateTextLength(ByRef num)

-Range("A247").Clear

-Range("B247").Clear

-Range("C247").Clear

-Range("D247").Clear

-Range("A247").Value = "xlValidateTextLength"

-Range("B247").Value = 6

-Range("C247").Value = num

-B247 = Range("B247").Value

-C247 = Range("C247").Value

-If B247 = C247 Then

-Range("D247").Value = "OK"

-Else

-Range("D247").Value = "NG"

-End If

-End Function

-

-Function test_xlValidateTime(ByRef num)

-Range("A248").Clear

-Range("B248").Clear

-Range("C248").Clear

-Range("D248").Clear

-Range("A248").Value = "xlValidateTime"

-Range("B248").Value = 5

-Range("C248").Value = num

-B248 = Range("B248").Value

-C248 = Range("C248").Value

-If B248 = C248 Then

-Range("D248").Value = "OK"

-Else

-Range("D248").Value = "NG"

-End If

-End Function

-

-Function test_xlValidateWholeNumber(ByRef num)

-Range("A249").Clear

-Range("B249").Clear

-Range("C249").Clear

-Range("D249").Clear

-Range("A249").Value = "xlValidateWholeNumber"

-Range("B249").Value = 1

-Range("C249").Value = num

-B249 = Range("B249").Value

-C249 = Range("C249").Value

-If B249 = C249 Then

-Range("D249").Value = "OK"

-Else

-Range("D249").Value = "NG"

-End If

-End Function

-

-Function test_xlLabelPositionAbove(ByRef num)

-Range("A250").Clear

-Range("B250").Clear

-Range("C250").Clear

-Range("D250").Clear

-Range("A250").Value = "xlLabelPositionAbove"

-Range("B250").Value = 0

-Range("C250").Value = num

-B250 = Range("B250").Value

-C250 = Range("C250").Value

-If B250 = C250 Then

-Range("D250").Value = "OK"

-Else

-Range("D250").Value = "NG"

-End If

-End Function

-

-Function test_xlLabelPositionBelow(ByRef num)

-Range("A251").Clear

-Range("B251").Clear

-Range("C251").Clear

-Range("D251").Clear

-Range("A251").Value = "xlLabelPositionBelow"

-Range("B251").Value = 1

-Range("C251").Value = num

-B251 = Range("B251").Value

-C251 = Range("C251").Value

-If B251 = C251 Then

-Range("D251").Value = "OK"

-Else

-Range("D251").Value = "NG"

-End If

-End Function

-

-Function test_xlLabelPositionBestFit(ByRef num)

-Range("A252").Clear

-Range("B252").Clear

-Range("C252").Clear

-Range("D252").Clear

-Range("A252").Value = "xlLabelPositionBestFit"

-Range("B252").Value = 5

-Range("C252").Value = num

-B252 = Range("B252").Value

-C252 = Range("C252").Value

-If B252 = C252 Then

-Range("D252").Value = "OK"

-Else

-Range("D252").Value = "NG"

-End If

-End Function

-

-Function test_xlLabelPositionBestCenter(ByRef num)

-Range("A253").Clear

-Range("B253").Clear

-Range("C253").Clear

-Range("D253").Clear

-Range("A253").Value = "xlLabelPositionBestCenter"

-Range("B253").Value = -4108

-Range("C253").Value = num

-B253 = Range("B253").Value

-C253 = Range("C253").Value

-If B253 = C253 Then

-Range("D253").Value = "OK"

-Else

-Range("D253").Value = "NG"

-End If

-End Function

-

-Function test_xlLabelPositionBestCustom(ByRef num)

-Range("A254").Clear

-Range("B254").Clear

-Range("C254").Clear

-Range("D254").Clear

-Range("A254").Value = "xlLabelPositionBestCustom"

-Range("B254").Value = 7

-Range("C254").Value = num

-B254 = Range("B254").Value

-C254 = Range("C254").Value

-If B254 = C254 Then

-Range("D254").Value = "OK"

-Else

-Range("D254").Value = "NG"

-End If

-End Function

-

-Function test_xlLabelPositionInsideBase(ByRef num)

-Range("A255").Clear

-Range("B255").Clear

-Range("C255").Clear

-Range("D255").Clear

-Range("A255").Value = "xlLabelPositionInsideBase"

-Range("B255").Value = 4

-Range("C255").Value = num

-B255 = Range("B255").Value

-C255 = Range("C255").Value

-If B255 = C255 Then

-Range("D255").Value = "OK"

-Else

-Range("D255").Value = "NG"

-End If

-End Function

-

-Function test_xlLabelPositionInsideEnd(ByRef num)

-Range("A256").Clear

-Range("B256").Clear

-Range("C256").Clear

-Range("D256").Clear

-Range("A256").Value = "xlLabelPositionInsideEnd"

-Range("B256").Value = 3

-Range("C256").Value = num

-B256 = Range("B256").Value

-C256 = Range("C256").Value

-If B256 = C256 Then

-Range("D256").Value = "OK"

-Else

-Range("D256").Value = "NG"

-End If

-End Function

-

-Function test_xlLabelPositionInsideLeft(ByRef num)

-Range("A257").Clear

-Range("B257").Clear

-Range("C257").Clear

-Range("D257").Clear

-Range("A257").Value = "xlLabelPositionInsideLeft"

-Range("B257").Value = -4131

-Range("C257").Value = num

-B257 = Range("B257").Value

-C257 = Range("C257").Value

-If B257 = C257 Then

-Range("D257").Value = "OK"

-Else

-Range("D257").Value = "NG"

-End If

-End Function

-

-Function test_xlLabelPositionMixed(ByRef num)

-Range("A258").Clear

-Range("B258").Clear

-Range("C258").Clear

-Range("D258").Clear

-Range("A258").Value = "xlLabelPositionMixed"

-Range("B258").Value = 6

-Range("C258").Value = num

-B258 = Range("B258").Value

-C258 = Range("C258").Value

-If B258 = C258 Then

-Range("D258").Value = "OK"

-Else

-Range("D258").Value = "NG"

-End If

-End Function

-

-Function test_xlLabelPositionOutsideEnd(ByRef num)

-Range("A259").Clear

-Range("B259").Clear

-Range("C259").Clear

-Range("D259").Clear

-Range("A259").Value = "xlLabelPositionOutsideEnd"

-Range("B259").Value = 2

-Range("C259").Value = num

-B259 = Range("B259").Value

-C259 = Range("C259").Value

-If B259 = C259 Then

-Range("D259").Value = "OK"

-Else

-Range("D259").Value = "NG"

-End If

-End Function

-

-Function test_xlLabelPositionRight(ByRef num)

-Range("A260").Clear

-Range("B260").Clear

-Range("C260").Clear

-Range("D260").Clear

-Range("A260").Value = "xlLabelPositionRight"

-Range("B260").Value = -4152

-Range("C260").Value = num

-B260 = Range("B260").Value

-C260 = Range("C260").Value

-If B260 = C260 Then

-Range("D260").Value = "OK"

-Else

-Range("D260").Value = "NG"

-End If

-End Function

-

-Function test_xlDataLabelSeparatorDefault(ByRef num)

-Range("A261").Clear

-Range("B261").Clear

-Range("C261").Clear

-Range("D261").Clear

-Range("A261").Value = "xlDataLabelSeparatorDefault"

-Range("B261").Value = 1

-Range("C261").Value = num

-B261 = Range("B261").Value

-C261 = Range("C261").Value

-If B261 = C261 Then

-Range("D261").Value = "OK"

-Else

-Range("D261").Value = "NG"

-End If

-End Function

-

-Function test_xlDataLabelsShowBubbleSizes(ByRef num)

-Range("A262").Clear

-Range("B262").Clear

-Range("C262").Clear

-Range("D262").Clear

-Range("A262").Value = "xlDataLabelsShowBubbleSizes"

-Range("B262").Value = 6

-Range("C262").Value = num

-B262 = Range("B262").Value

-C262 = Range("C262").Value

-If B262 = C262 Then

-Range("D262").Value = "OK"

-Else

-Range("D262").Value = "NG"

-End If

-End Function

-

-Function test_xlDataLabelsShowLabel(ByRef num)

-Range("A263").Clear

-Range("B263").Clear

-Range("C263").Clear

-Range("D263").Clear

-Range("A263").Value = "xlDataLabelsShowLabel"

-Range("B263").Value = 4

-Range("C263").Value = num

-B263 = Range("B263").Value

-C263 = Range("C263").Value

-If B263 = C263 Then

-Range("D263").Value = "OK"

-Else

-Range("D263").Value = "NG"

-End If

-End Function

-

-Function test_xlDataLabelsShowLabelAndPercent(ByRef num)

-Range("A264").Clear

-Range("B264").Clear

-Range("C264").Clear

-Range("D264").Clear

-Range("A264").Value = "xlDataLabelsShowLabelAndPercent"

-Range("B264").Value = 5

-Range("C264").Value = num

-B264 = Range("B264").Value

-C264 = Range("C264").Value

-If B264 = C264 Then

-Range("D264").Value = "OK"

-Else

-Range("D264").Value = "NG"

-End If

-End Function

-

-Function test_xlDataLabelsShowNone(ByRef num)

-Range("A265").Clear

-Range("B265").Clear

-Range("C265").Clear

-Range("D265").Clear

-Range("A265").Value = "xlDataLabelsShowNone"

-Range("B265").Value = -4142

-Range("C265").Value = num

-B265 = Range("B265").Value

-C265 = Range("C265").Value

-If B265 = C265 Then

-Range("D265").Value = "OK"

-Else

-Range("D265").Value = "NG"

-End If

-End Function

-

-Function test_xlDataLabelsShowPercent(ByRef num)

-Range("A266").Clear

-Range("B266").Clear

-Range("C266").Clear

-Range("D266").Clear

-Range("A266").Value = "xlDataLabelsShowPercent"

-Range("B266").Value = 3

-Range("C266").Value = num

-B266 = Range("B266").Value

-C266 = Range("C266").Value

-If B266 = C266 Then

-Range("D266").Value = "OK"

-Else

-Range("D266").Value = "NG"

-End If

-End Function

-

-Function test_xlDataLabelsShowValue(ByRef num)

-Range("A267").Clear

-Range("B267").Clear

-Range("C267").Clear

-Range("D267").Clear

-Range("A267").Value = "xlDataLabelsShowValue"

-Range("B267").Value = 2

-Range("C267").Value = num

-B267 = Range("B267").Value

-C267 = Range("C267").Value

-If B267 = C267 Then

-Range("D267").Value = "OK"

-Else

-Range("D267").Value = "NG"

-End If

-End Function

-

-Function test_xlDay(ByRef num)

-Range("A268").Clear

-Range("B268").Clear

-Range("C268").Clear

-Range("D268").Clear

-Range("A268").Value = "xlDay"

-Range("B268").Value = 1

-Range("C268").Value = num

-B268 = Range("B268").Value

-C268 = Range("C268").Value

-If B268 = C268 Then

-Range("D268").Value = "OK"

-Else

-Range("D268").Value = "NG"

-End If

-End Function

-

-Function test_xlMonth(ByRef num)

-Range("A269").Clear

-Range("B269").Clear

-Range("C269").Clear

-Range("D269").Clear

-Range("A269").Value = "xlMonth"

-Range("B269").Value = 3

-Range("C269").Value = num

-B269 = Range("B269").Value

-C269 = Range("C269").Value

-If B269 = C269 Then

-Range("D269").Value = "OK"

-Else

-Range("D269").Value = "NG"

-End If

-End Function

-

-Function test_xlWeekday(ByRef num)

-Range("A270").Clear

-Range("B270").Clear

-Range("C270").Clear

-Range("D270").Clear

-Range("A270").Value = "xlWeekday"

-Range("B270").Value = 2

-Range("C270").Value = num

-B270 = Range("B270").Value

-C270 = Range("C270").Value

-If B270 = C270 Then

-Range("D270").Value = "OK"

-Else

-Range("D270").Value = "NG"

-End If

-End Function

-

-Function test_xlYear(ByRef num)

-Range("A271").Clear

-Range("B271").Clear

-Range("C271").Clear

-Range("D271").Clear

-Range("A271").Value = "xlYear"

-Range("B271").Value = 4

-Range("C271").Value = num

-B271 = Range("B271").Value

-C271 = Range("C271").Value

-If B271 = C271 Then

-Range("D271").Value = "OK"

-Else

-Range("D271").Value = "NG"

-End If

-End Function

-

-Function test_xlAutoFill(ByRef num)

-Range("A272").Clear

-Range("B272").Clear

-Range("C272").Clear

-Range("D272").Clear

-Range("A272").Value = "xlAutoFill"

-Range("B272").Value = 4

-Range("C272").Value = num

-B272 = Range("B272").Value

-C272 = Range("C272").Value

-If B272 = C272 Then

-Range("D272").Value = "OK"

-Else

-Range("D272").Value = "NG"

-End If

-End Function

-

-Function test_xlChronological(ByRef num)

-Range("A273").Clear

-Range("B273").Clear

-Range("C273").Clear

-Range("D273").Clear

-Range("A273").Value = "xlChronological"

-Range("B273").Value = 3

-Range("C273").Value = num

-B273 = Range("B273").Value

-C273 = Range("C273").Value

-If B273 = C273 Then

-Range("D273").Value = "OK"

-Else

-Range("D273").Value = "NG"

-End If

-End Function

-

-Function test_xlDataSeriesLinear(ByRef num)

-Range("A274").Clear

-Range("B274").Clear

-Range("C274").Clear

-Range("D274").Clear

-Range("A274").Value = "xlDataSeriesLinear"

-Range("B274").Value = -4132

-Range("C274").Value = num

-B274 = Range("B274").Value

-C274 = Range("C274").Value

-If B274 = C274 Then

-Range("D274").Value = "OK"

-Else

-Range("D274").Value = "NG"

-End If

-End Function

-

-Function test_xlGrowth(ByRef num)

-Range("A275").Clear

-Range("B275").Clear

-Range("C275").Clear

-Range("D275").Clear

-Range("A275").Value = "xlGrowth"

-Range("B275").Value = 2

-Range("C275").Value = num

-B275 = Range("B275").Value

-C275 = Range("C275").Value

-If B275 = C275 Then

-Range("D275").Value = "OK"

-Else

-Range("D275").Value = "NG"

-End If

-End Function

-

-Function test_xlShiftToLeft(ByRef num)

-Range("A276").Clear

-Range("B276").Clear

-Range("C276").Clear

-Range("D276").Clear

-Range("A276").Value = "xlShiftToLeft"

-Range("B276").Value = -4159

-Range("C276").Value = num

-B276 = Range("B276").Value

-C276 = Range("C276").Value

-If B276 = C276 Then

-Range("D276").Value = "OK"

-Else

-Range("D276").Value = "NG"

-End If

-End Function

-

-Function test_xlShiftUp(ByRef num)

-Range("A277").Clear

-Range("B277").Clear

-Range("C277").Clear

-Range("D277").Clear

-Range("A277").Value = "xlShiftUp"

-Range("B277").Value = -4162

-Range("C277").Value = num

-B277 = Range("B277").Value

-C277 = Range("C277").Value

-If B277 = C277 Then

-Range("D277").Value = "OK"

-Else

-Range("D277").Value = "NG"

-End If

-End Function

-

-Function test_xlDown(ByRef num)

-Range("A278").Clear

-Range("B278").Clear

-Range("C278").Clear

-Range("D278").Clear

-Range("A278").Value = "xlDown"

-Range("B278").Value = -4121

-Range("C278").Value = num

-B278 = Range("B278").Value

-C278 = Range("C278").Value

-If B278 = C278 Then

-Range("D278").Value = "OK"

-Else

-Range("D278").Value = "NG"

-End If

-End Function

-

-Function test_xlToLeft(ByRef num)

-Range("A279").Clear

-Range("B279").Clear

-Range("C279").Clear

-Range("D279").Clear

-Range("A279").Value = "xlToLeft"

-Range("B279").Value = -4159

-Range("C279").Value = num

-B279 = Range("B279").Value

-C279 = Range("C279").Value

-If B279 = C279 Then

-Range("D279").Value = "OK"

-Else

-Range("D279").Value = "NG"

-End If

-End Function

-

-Function test_xlToRight(ByRef num)

-Range("A280").Clear

-Range("B280").Clear

-Range("C280").Clear

-Range("D280").Clear

-Range("A280").Value = "xlToRight"

-Range("B280").Value = -4161

-Range("C280").Value = num

-B280 = Range("B280").Value

-C280 = Range("C280").Value

-If B280 = C280 Then

-Range("D280").Value = "OK"

-Else

-Range("D280").Value = "NG"

-End If

-End Function

-

-Function test_xlUp(ByRef num)

-Range("A281").Clear

-Range("B281").Clear

-Range("C281").Clear

-Range("D281").Clear

-Range("A281").Value = "xlUp"

-Range("B281").Value = -4162

-Range("C281").Value = num

-B281 = Range("B281").Value

-C281 = Range("C281").Value

-If B281 = C281 Then

-Range("D281").Value = "OK"

-Else

-Range("D281").Value = "NG"

-End If

-End Function

-

-Function test_xlInterpolated(ByRef num)

-Range("A282").Clear

-Range("B282").Clear

-Range("C282").Clear

-Range("D282").Clear

-Range("A282").Value = "xlInterpolated"

-Range("B282").Value = 3

-Range("C282").Value = num

-B282 = Range("B282").Value

-C282 = Range("C282").Value

-If B282 = C282 Then

-Range("D282").Value = "OK"

-Else

-Range("D282").Value = "NG"

-End If

-End Function

-

-Function test_xlNotPlotted(ByRef num)

-Range("A283").Clear

-Range("B283").Clear

-Range("C283").Clear

-Range("D283").Clear

-Range("A283").Value = "xlNotPlotted"

-Range("B283").Value = 2

-Range("C283").Value = num

-B283 = Range("B283").Value

-C283 = Range("C283").Value

-If B283 = C283 Then

-Range("D283").Value = "OK"

-Else

-Range("D283").Value = "NG"

-End If

-End Function

-

-Function test_xlZero(ByRef num)

-Range("A284").Clear

-Range("B284").Clear

-Range("C284").Clear

-Range("D284").Clear

-Range("A284").Value = "xlZero"

-Range("B284").Value = 1

-Range("C284").Value = num

-B284 = Range("B284").Value

-C284 = Range("C284").Value

-If B284 = C284 Then

-Range("D284").Value = "OK"

-Else

-Range("D284").Value = "NG"

-End If

-End Function

-

-Function test_xlDisplayShapes(ByRef num)

-Range("A285").Clear

-Range("B285").Clear

-Range("C285").Clear

-Range("D285").Clear

-Range("A285").Value = "xlDisplayShapes"

-Range("B285").Value = -4104

-Range("C285").Value = num

-B285 = Range("B285").Value

-C285 = Range("C285").Value

-If B285 = C285 Then

-Range("D285").Value = "OK"

-Else

-Range("D285").Value = "NG"

-End If

-End Function

-

-Function test_xlHide(ByRef num)

-Range("A286").Clear

-Range("B286").Clear

-Range("C286").Clear

-Range("D286").Clear

-Range("A286").Value = "xlHide"

-Range("B286").Value = 3

-Range("C286").Value = num

-B286 = Range("B286").Value

-C286 = Range("C286").Value

-If B286 = C286 Then

-Range("D286").Value = "OK"

-Else

-Range("D286").Value = "NG"

-End If

-End Function

-

-Function test_xlPlaceholders(ByRef num)

-Range("A287").Clear

-Range("B287").Clear

-Range("C287").Clear

-Range("D287").Clear

-Range("A287").Value = "xlPlaceholders"

-Range("B287").Value = 2

-Range("C287").Value = num

-B287 = Range("B287").Value

-C287 = Range("C287").Value

-If B287 = C287 Then

-Range("D287").Value = "OK"

-Else

-Range("D287").Value = "NG"

-End If

-End Function

-

-Function test_xlHundredMillions(ByRef num)

-Range("A288").Clear

-Range("B288").Clear

-Range("C288").Clear

-Range("D288").Clear

-Range("A288").Value = "xlHundredMillions"

-Range("B288").Value = -8

-Range("C288").Value = num

-B288 = Range("B288").Value

-C288 = Range("C288").Value

-If B288 = C288 Then

-Range("D288").Value = "OK"

-Else

-Range("D288").Value = "NG"

-End If

-End Function

-

-Function test_xlHundreds(ByRef num)

-Range("A289").Clear

-Range("B289").Clear

-Range("C289").Clear

-Range("D289").Clear

-Range("A289").Value = "xlHundreds"

-Range("B289").Value = -2

-Range("C289").Value = num

-B289 = Range("B289").Value

-C289 = Range("C289").Value

-If B289 = C289 Then

-Range("D289").Value = "OK"

-Else

-Range("D289").Value = "NG"

-End If

-End Function

-

-Function test_xlHundredThousands(ByRef num)

-Range("A290").Clear

-Range("B290").Clear

-Range("C290").Clear

-Range("D290").Clear

-Range("A290").Value = "xlHundredThousands"

-Range("B290").Value = -5

-Range("C290").Value = num

-B290 = Range("B290").Value

-C290 = Range("C290").Value

-If B290 = C290 Then

-Range("D290").Value = "OK"

-Else

-Range("D290").Value = "NG"

-End If

-End Function

-

-Function test_xlMillionMillons(ByRef num)

-Range("A291").Clear

-Range("B291").Clear

-Range("C291").Clear

-Range("D291").Clear

-Range("A291").Value = "xlMillionMillons"

-Range("B291").Value = -10

-Range("C291").Value = num

-B291 = Range("B291").Value

-C291 = Range("C291").Value

-If B291 = C291 Then

-Range("D291").Value = "OK"

-Else

-Range("D291").Value = "NG"

-End If

-End Function

-

-Function test_xlMillions(ByRef num)

-Range("A292").Clear

-Range("B292").Clear

-Range("C292").Clear

-Range("D292").Clear

-Range("A292").Value = "xlMillions"

-Range("B292").Value = -6

-Range("C292").Value = num

-B292 = Range("B292").Value

-C292 = Range("C292").Value

-If B292 = C292 Then

-Range("D292").Value = "OK"

-Else

-Range("D292").Value = "NG"

-End If

-End Function

-

-Function test_xlTenMillions(ByRef num)

-Range("A293").Clear

-Range("B293").Clear

-Range("C293").Clear

-Range("D293").Clear

-Range("A293").Value = "xlTenMillions"

-Range("B293").Value = -7

-Range("C293").Value = num

-B293 = Range("B293").Value

-C293 = Range("C293").Value

-If B293 = C293 Then

-Range("D293").Value = "OK"

-Else

-Range("D293").Value = "NG"

-End If

-End Function

-

-Function test_xlTenThousands(ByRef num)

-Range("A294").Clear

-Range("B294").Clear

-Range("C294").Clear

-Range("D294").Clear

-Range("A294").Value = "xlTenThousands"

-Range("B294").Value = -4

-Range("C294").Value = num

-B294 = Range("B294").Value

-C294 = Range("C294").Value

-If B294 = C294 Then

-Range("D294").Value = "OK"

-Else

-Range("D294").Value = "NG"

-End If

-End Function

-

-Function test_xlThousandMillions(ByRef num)

-Range("A295").Clear

-Range("B295").Clear

-Range("C295").Clear

-Range("D295").Clear

-Range("A295").Value = "xlThousandMillions"

-Range("B295").Value = -9

-Range("C295").Value = num

-B295 = Range("B295").Value

-C295 = Range("C295").Value

-If B295 = C295 Then

-Range("D295").Value = "OK"

-Else

-Range("D295").Value = "NG"

-End If

-End Function

-

-Function test_xlThousands(ByRef num)

-Range("A296").Clear

-Range("B296").Clear

-Range("C296").Clear

-Range("D296").Clear

-Range("A296").Value = "xlThousands"

-Range("B296").Value = -3

-Range("C296").Value = num

-B296 = Range("B296").Value

-C296 = Range("C296").Value

-If B296 = C296 Then

-Range("D296").Value = "OK"

-Else

-Range("D296").Value = "NG"

-End If

-End Function

-

-<<<<<<
-======================
-Module5
->>>>>>
-Attribute VB_Name = "Module5"

-

-Sub main_5()

-test_XlEditionFormat (XlEditionFormat)

-test_xlAutomaticUpdate (xlAutomaticUpdate)

-test_xlCancel (xlCancel)

-test_xlChangeAttributes (xlChangeAttributes)

-test_xlManualUpdate (xlManualUpdate)

-test_xlOpenSource (xlOpenSource)

-test_xlSelect (xlSelect)

-test_xlSendPublisher (xlSendPublisher)

-test_xlUpdateSubscriber (xlUpdateSubscriber)

-test_xlPublisher (xlPublisher)

-test_xlSubscriber (xlSubscriber)

-test_xlDisabled (xlDisabled)

-test_xlErrorHandler (xlErrorHandler)

-test_xlInterrupt (xlInterrupt)

-test_xlNoRestrictions (xlNoRestrictions)

-test_xlNoSelection (xlNoSelection)

-test_xlUnlockedCells (xlUnlockedCells)

-test_xlCap (xlCap)

-test_xlNoCap (xlNoCap)

-test_xlX (xlX)

-test_xlY (xlY)

-test_xlErrorBarIncludeBoth (xlErrorBarIncludeBoth)

-test_xlErrorBarIncludeMinusValues (xlErrorBarIncludeMinusValues)

-test_xlErrorBarIncludeNone (xlErrorBarIncludeNone)

-test_xlErrorBarIncludePlusValues (xlErrorBarIncludePlusValues)

-test_xlErrorBarTypeCustom (xlErrorBarTypeCustom)

-test_xlErrorBarTypeFixedValue (xlErrorBarTypeFixedValue)

-test_xlErrorBarTypePercent (xlErrorBarTypePercent)

-test_xlErrorBarTypeStDev (xlErrorBarTypeStDev)

-test_xlErrorBarTypeStError (xlErrorBarTypeStError)

-test_xlEmptyCellReferences (xlEmptyCellReferences)

-test_xlEvaluateToError (xlEvaluateToError)

-test_xlInconsistentFormula (xlInconsistentFormula)

-test_xlListDataValidation (xlListDataValidation)

-test_xlNumberAsText (xlNumberAsText)

-test_xlOmittedCells (xlOmittedCells)

-test_xlTextDate (xlTextDate)

-test_xlUnlockedFormulaCells (xlUnlockedFormulaCells)

-test_xlReadOnly (xlReadOnly)

-test_xlReadWrite (xlReadWrite)

-test_xlAddIn (xlAddIn)

-test_xlCSV (xlCSV)

-test_xlCSVMac (xlCSVMac)

-test_xlCSVMSDOS (xlCSVMSDOS)

-test_xlCSVWindows (xlCSVWindows)

-test_xlCurrentPlatformText (xlCurrentPlatformText)

-test_xlDBF2 (xlDBF2)

-test_xlDBF3 (xlDBF3)

-test_xlDBF4 (xlDBF4)

-test_xlDIF (xlDIF)

-test_xlExcel2 (xlExcel2)

-test_xlExcel2FarEast (xlExcel2FarEast)

-test_xlExcel3 (xlExcel3)

-test_xlExcel4 (xlExcel4)

-test_xlExcel4Wordbook (xlExcel4Wordbook)

-test_xlExcel5 (xlExcel5)

-test_xlExcel7 (xlExcel7)

-test_xlExcel9795 (xlExcel9795)

-test_xlHtml (xlHtml)

-test_xlIntlAddIn (xlIntlAddIn)

-test_xlIntlMacro (xlIntlMacro)

-test_xlSYLK (xlSYLK)

-test_xlTemplate (xlTemplate)

-test_xlTextMac (xlTextMac)

-test_xlTextMSDOS (xlTextMSDOS)

-test_xlTextPrinter (xlTextPrinter)

-test_xlTextWindows (xlTextWindows)

-test_xlUnicodeText (xlUnicodeText)

-test_xlWebArchive (xlWebArchive)

-test_xlWJ2WD1 (xlWJ2WD1)

-test_xlWJ3 (xlWJ3)

-test_xlWJ3FJ3 (xlWJ3FJ3)

-test_xlWK1 (xlWK1)

-test_xlWK1ALL (xlWK1ALL)

-test_xlWK1FMT (xlWK1FMT)

-test_xlWK3 (xlWK3)

-test_xlWK3FM3 (xlWK3FM3)

-test_xlWK4 (xlWK4)

-test_xlWKS (xlWKS)

-test_xlWordbookNormal (xlWordbookNormal)

-test_xlWords2FarEast (xlWords2FarEast)

-test_xlWQ1 (xlWQ1)

-test_xlXMLSpredsheet (xlXMLSpredsheet)

-test_xlFillWithAll (xlFillWithAll)

-test_xlFillWithContents (xlFillWithContents)

-test_xlFillWithFormats (xlFillWithFormats)

-test_xlFilterCopy (xlFilterCopy)

-test_xlFilterInPlace (xlFilterInPlace)

-test_xlComments (xlComments)

-test_xlFormulas (xlFormulas)

-test_xlValues (xlValues)

-test_xlButtonControl (xlButtonControl)

-test_xlCheckBox (xlCheckBox)

-test_xlDropDown (xlDropDown)

-test_xlEditBox (xlEditBox)

-test_xlGroupBox (xlGroupBox)

-test_xlLabel (xlLabel)

-test_xlListBox (xlListBox)

-test_xlOptionButton (xlOptionButton)

-test_xlSchollBar (xlSchollBar)

-test_xlSpinner (xlSpinner)

-test_xlBetween (xlBetween)

-test_xlEqual (xlEqual)

-test_xlGreater (xlGreater)

-test_xlGreaterEqual (xlGreaterEqual)

-test_xlLess (xlLess)

-test_xlLessEqual (xlLessEqual)

-test_xlNotBetween (xlNotBetween)

-test_xlNotEqual (xlNotEqual)

-test_xlCellValue (xlCellValue)

-test_xlExpression (xlExpression)

-test_xlColumnLabels (xlColumnLabels)

-test_xlMixedLabels (xlMixedLabels)

-test_xlNoLabels (xlNoLabels)

-test_xlRowLabels (xlRowLabels)

-test_xlHAlignCenter (xlHAlignCenter)

-test_xlHAlignCenterAcrossSelection (xlHAlignCenterAcrossSelection)

-test_xlHAlignDistributed (xlHAlignDistributed)

-test_xlHAlignFull (xlHAlignFull)

-test_xlHAlignGeneral (xlHAlignGeneral)

-test_xlHAlignJustify (xlHAlignJustify)

-test_xlHAlignLeft (xlHAlignLeft)

-test_xlHAlignRight (xlHAlignRight)

-test_xlHebrewFullScript (xlHebrewFullScript)

-test_xlHebrewMixedAuthorizedScript (xlHebrewMixedAuthorizedScript)

-test_xlHebrewMixedScript (xlHebrewMixedScript)

-test_xlHebrewPartialScript (xlHebrewPartialScript)

-test_xlAllChanges (xlAllChanges)

-test_xlNotYetReviewed (xlNotYetReviewed)

-test_xlSinceMyLastSave (xlSinceMyLastSave)

-test_xlHtmlCalc (xlHtmlCalc)

-test_xlHtmlChart (xlHtmlChart)

-test_xlHtmlList (xlHtmlList)

-test_xlHtmlStatic (xlHtmlStatic)

-test_xlIMEModeAlpha (xlIMEModeAlpha)

-test_xlIMEModeAlphaFull (xlIMEModeAlphaFull)

-test_xlIMEModeDisable (xlIMEModeDisable)

-test_xlIMEModeHangul (xlIMEModeHangul)

-test_xlIMEModeHangulFull (xlIMEModeHangulFull)

-test_xlIMEModeHiragana (xlIMEModeHiragana)

-test_xlIMEModeKatakana (xlIMEModeKatakana)

-test_xlIMEModeKatakanaHalf (xlIMEModeKatakanaHalf)

-test_xlIMEModeNoControl (xlIMEModeNoControl)

-test_xlIMEModeOff (xlIMEModeOff)

-test_xlIMEModeOn (xlIMEModeOn)

-test_xlPivotTableReport (xlPivotTableReport)

-test_xlQueryTable (xlQueryTable)

-test_xlFormatFromLeftOrAbove (xlFormatFromLeftOrAbove)

-test_xlFormatFromRightOrAbove (xlFormatFromRightOrAbove)

-test_xlShiftDown (xlShiftDown)

-test_xlShiftToRight (xlShiftToRight)

-test_xlOutline (xlOutline)

-test_xlTabular (xlTabular)

-test_xlLegendPositionBottom (xlLegendPositionBottom)

-test_xlLegendPositionCorner (xlLegendPositionCorner)

-test_xlLegendPositionLeft (xlLegendPositionLeft)

-test_xlLegendPositionRight (xlLegendPositionRight)

-test_xlLegendPositionTop (xlLegendPositionTop)

-test_xlContinuous (xlContinuous)

-test_xlDash (xlDash)

-test_xlDashDot (xlDashDot)

-test_xlDashDotDot (xlDashDotDot)

-test_xlDot (xlDot)

-test_xlDouble (xlDouble)

-test_xlLineStyleNone (xlLineStyleNone)

-test_xlSlantDashDot (xlSlantDashDot)

-test_xlExcelLink (xlExcelLink)

-test_xlPublishers (xlPublishers)

-test_xlSubscribers (xlSubscribers)

-test_xlEditionDate (xlEditionDate)

-test_xlLinkInfoStatus (xlLinkInfoStatus)

-test_xlUpdateState (xlUpdateState)

-test_xlLinkInfoOLELinks (xlLinkInfoOLELinks)

-test_xlLinkInfoPublishers (xlLinkInfoPublishers)

-test_xlLinkInfoSubscribers (xlLinkInfoSubscribers)

-test_xlLinkStatusCopiedValues (xlLinkStatusCopiedValues)

-test_xlLinkStatusIndeterminate (xlLinkStatusIndeterminate)

-test_xlLinkStatusInvalidName (xlLinkStatusInvalidName)

-test_xlLinkStatusMissingFile (xlLinkStatusMissingFile)

-test_xlLinkStatusMissingSheet (xlLinkStatusMissingSheet)

-test_xlLinkStatusNotStarted (xlLinkStatusNotStarted)

-test_xlLinkStatusOK (xlLinkStatusOK)

-test_xlLinkStatusOld (xlLinkStatusOld)

-test_xlLinkStatusSourceNotCalculated (xlLinkStatusSourceNotCalculated)

-test_xlLinkStatusSourceNotOpen (xlLinkStatusSourceNotOpen)

-test_xlLinkStatusSourceOpen (xlLinkStatusSourceOpen)

-test_xlLinkTypeExcelLinks (xlLinkTypeExcelLinks)

-test_xlLinkTypeOLELinks (xlLinkTypeOLELinks)

-test_xlListConflictDialog (xlListConflictDialog)

-test_xlListConflictDiscardAllConflicts (xlListConflictDiscardAllConflicts)

-test_xlListConflictError (xlListConflictError)

-test_xlListConflictRetryAllConflicts (xlListConflictRetryAllConflicts)

-test_xlListDataTypeCheckbox (xlListDataTypeCheckbox)

-test_xlListDataTypeChoice (xlListDataTypeChoice)

-test_xlListDataTypeChoiceMulti (xlListDataTypeChoiceMulti)

-test_xlListDataTypeCounter (xlListDataTypeCounter)

-test_xlListDataTypeCurrency (xlListDataTypeCurrency)

-test_xlListDataTypeDateTime (xlListDataTypeDateTime)

-test_xlListDataTypeHyperLink (xlListDataTypeHyperLink)

-test_xlListDataTypeListLookup (xlListDataTypeListLookup)

-test_xlListDataTypeMultiLineRichText (xlListDataTypeMultiLineRichText)

-test_xlListDataTypeMultiLineText (xlListDataTypeMultiLineText)

-test_xlListDataTypeNone (xlListDataTypeNone)

-test_xlListDataTypeNumber (xlListDataTypeNumber)

-test_xlListDataTypeText (xlListDataTypeText)

-test_xlSrcExternal (xlSrcExternal)

-test_xlSrcRange (xlSrcRange)

-test_xlSrcXml (xlSrcXml)

-test_xlColumnHeader (xlColumnHeader)

-test_xlColumnItem (xlColumnItem)

-test_xlDataHeader (xlDataHeader)

-test_xlDataItem (xlDataItem)

-test_xlPageHeader (xlPageHeader)

-test_xlPageItem (xlPageItem)

-test_xlRowHeader (xlRowHeader)

-test_xlRowItem (xlRowItem)

-test_xlTableBody (xlTableBody)

-test_xlPart (xlPart)

-test_xlWhole (xlWhole)

-test_xlMicrosoftAccess (xlMicrosoftAccess)

-test_xlMicrosoftFoxPro (xlMicrosoftFoxPro)

-test_xlMicrosoftMail (xlMicrosoftMail)

-test_xlMicrosoftPowerPoint (xlMicrosoftPowerPoint)

-test_xlMicrosoftProject (xlMicrosoftProject)

-test_xlMicrosoftSchedulePlus (xlMicrosoftSchedulePlus)

-test_xlMicrosoftWord (xlMicrosoftWord)

-test_xlMAPI (xlMAPI)

-test_xlNoMailSystem (xlNoMailSystem)

-test_xlPowerTalk (xlPowerTalk)

-test_xlMarkerStyleAutomatic (xlMarkerStyleAutomatic)

-test_xlMarkerStyleCircle (xlMarkerStyleCircle)

-test_xlMarkerStyleDash (xlMarkerStyleDash)

-test_xlMarkerStyleDiamond (xlMarkerStyleDiamond)

-test_xlMarkerStyleDot (xlMarkerStyleDot)

-test_xlMarkerStyleNone (xlMarkerStyleNone)

-test_xlMarkerStylePicture (xlMarkerStylePicture)

-test_xlMarkerStylePlus (xlMarkerStylePlus)

-test_xlMarkerStyleSquare (xlMarkerStyleSquare)

-test_xlMarkerStyleStar (xlMarkerStyleStar)

-test_xlMarkerStyleTiangle (xlMarkerStyleTiangle)

-test_xlMarkerStyleX (xlMarkerStyleX)

-test_xlNoButton (xlNoButton)

-test_xlPrimaryButton (xlPrimaryButton)

-test_xlSecondaryButton (xlSecondaryButton)

-test_xlDefault (xlDefault)

-test_xlIBeam (xlIBeam)

-test_xlNorthwestArrow (xlNorthwestArrow)

-test_xlWait (xlWait)

-test_XlOLEControl (XlOLEControl)

-test_XlOLEEmbed (XlOLEEmbed)

-test_XlOLELink (XlOLELink)

-test_XlVerbOpen (XlVerbOpen)

-test_XlVerbPrimary (XlVerbPrimary)

-test_xlFitToPage (xlFitToPage)

-test_xlFullPage (xlFullPage)

-test_xlScreenSize (xlScreenSize)

-test_xlDownThenOver (xlDownThenOver)

-test_xlOverThenDown (xlOverThenDown)

-test_xlDownward (xlDownward)

-test_xlHorizontal (xlHorizontal)

-test_xlUpward (xlUpward)

-test_xlVertical (xlVertical)

-test_xlBlanks (xlBlanks)

-test_xlButton (xlButton)

-test_xlDataAndLabel (xlDataAndLabel)

-test_xlDataOnly (xlDataOnly)

-test_xlFirstRow (xlFirstRow)

-test_xlLabelOnly (xlLabelOnly)

-test_xlOrigin (xlOrigin)

-test_XlPageBreakAutomatic (XlPageBreakAutomatic)

-test_XlPageBreakManual (XlPageBreakManual)

-test_XlPageBreakNone (XlPageBreakNone)

-test_xlPageBreakFull (xlPageBreakFull)

-test_xlPageBreakPartial (xlPageBreakPartial)

-test_xlLandscape (xlLandscape)

-test_xlPortrait (xlPortrait)

-test_xlPaper10x14 (xlPaper10x14)

-test_xlPaper11x17 (xlPaper11x17)

-test_xlPaperA3 (xlPaperA3)

-test_xlPaperA4Small (xlPaperA4Small)

-test_xlPaperA5 (xlPaperA5)

-test_xlPaperB4 (xlPaperB4)

-test_xlPaperB5 (xlPaperB5)

-test_xlPaperCsheet (xlPaperCsheet)

-test_xlPaperDsheet (xlPaperDsheet)

-test_xlPaperEnvelope10 (xlPaperEnvelope10)

-test_xlPaperEnvelope11 (xlPaperEnvelope11)

-test_xlPaperEnvelope12 (xlPaperEnvelope12)

-test_xlPaperEnvelope14 (xlPaperEnvelope14)

-test_xlPaperEnvelope9 (xlPaperEnvelope9)

-test_xlPaperEnvelopeB4 (xlPaperEnvelopeB4)

-test_xlPaperEnvelopeB5 (xlPaperEnvelopeB5)

-test_xlPaperEnvelopeB6 (xlPaperEnvelopeB6)

-test_xlPaperEnvelopeC3 (xlPaperEnvelopeC3)

-test_xlPaperEnvelopeC4 (xlPaperEnvelopeC4)

-test_xlPaperEnvelopeC5 (xlPaperEnvelopeC5)

-test_xlPaperEnvelopeC6 (xlPaperEnvelopeC6)

-test_xlPaperEnvelopeC65 (xlPaperEnvelopeC65)

-test_xlPaperEnvelopeDL (xlPaperEnvelopeDL)

-test_xlPaperEnvelopeItaly (xlPaperEnvelopeItaly)

-test_xlPaperEnvelopeMonarch (xlPaperEnvelopeMonarch)

-test_xlPaperEnvelopePersonal (xlPaperEnvelopePersonal)

-test_xlPaperEsheet (xlPaperEsheet)

-test_xlPaperExective (xlPaperExective)

-test_xlPaperFanfoldLegalGerman (xlPaperFanfoldLegalGerman)

-test_xlPaperFanfoldStdGerman (xlPaperFanfoldStdGerman)

-test_xlPaperFanfoldUS (xlPaperFanfoldUS)

-test_xlPaperFolio (xlPaperFolio)

-test_xlPaperLedger (xlPaperLedger)

-test_xlPaperLegal (xlPaperLegal)

-test_xlPaperLetter (xlPaperLetter)

-test_xlPaperLetterSmall (xlPaperLetterSmall)

-test_xlPaperNote (xlPaperNote)

-test_xlPaperQuarto (xlPaperQuarto)

-test_xlPaperStatement (xlPaperStatement)

-test_xlPaperTabloid (xlPaperTabloid)

-test_xlPaperUser (xlPaperUser)

-test_xlParameterTypeBigInt (xlParameterTypeBigInt)

-test_xlParameterTypeBinary (xlParameterTypeBinary)

-test_xlParameterTypeBit (xlParameterTypeBit)

-test_xlParameterTypeChar (xlParameterTypeChar)

-test_xlParameterTypeData (xlParameterTypeData)

-test_xlParameterTypeDecimal (xlParameterTypeDecimal)

-test_xlParameterTypeDouble (xlParameterTypeDouble)

-test_xlParameterTypeFloat (xlParameterTypeFloat)

-test_xlParameterTypeInteger (xlParameterTypeInteger)

-test_xlParameterTypeLongVarBinary (xlParameterTypeLongVarBinary)

-test_xlParameterTypeLongVarChar (xlParameterTypeLongVarChar)

-test_xlParameterTypeNumeric (xlParameterTypeNumeric)

-test_xlParameterTypeReal (xlParameterTypeReal)

-test_xlParameterTypeSmallInt (xlParameterTypeSmallInt)

-test_xlParameterTypeTime (xlParameterTypeTime)

-test_xlParameterTypeTimestamp (xlParameterTypeTimestamp)

-test_xlParameterTypeTinyInt (xlParameterTypeTinyInt)

-test_xlParameterTypeUnknown (xlParameterTypeUnknown)

-test_xlParameterTypeVarBinary (xlParameterTypeVarBinary)

-test_xlParameterTypeVarChar (xlParameterTypeVarChar)

-test_xlParameterTypeWChar (xlParameterTypeWChar)

-test_xlConstant (xlConstant)

-test_xlPrompt (xlPrompt)

-test_xlRange (xlRange)

-test_xlPasteSpecialOperationAdd (xlPasteSpecialOperationAdd)

-test_xlPasteSpecialOperationDivide (xlPasteSpecialOperationDivide)

-test_xlPasteSpecialOperationMultiply (xlPasteSpecialOperationMultiply)

-test_xlPasteSpecialOperationNone (xlPasteSpecialOperationNone)

-test_xlPasteSpecialOperationSubstract (xlPasteSpecialOperationSubstract)

-test_xlPasteAll (xlPasteAll)

-test_xlPasteAllExceptBorders (xlPasteAllExceptBorders)

-test_xlPasteAllColumnWidths (xlPasteAllColumnWidths)

-test_xlPasteComments (xlPasteComments)

-test_xlPasteFormats (xlPasteFormats)

-test_xlPasteFormulas (xlPasteFormulas)

-test_xlPasteFormulasAndNumberFormats (xlPasteFormulasAndNumberFormats)

-test_xlPasteValidation (xlPasteValidation)

-test_xlPasteValues (xlPasteValues)

-test_xlPasteValuesAndNumberFormats (xlPasteValuesAndNumberFormats)

-test_xlPatternAutomatic (xlPatternAutomatic)

-test_xlPatternChecker (xlPatternChecker)

-test_xlPatternCrissCross (xlPatternCrissCross)

-test_xlPatternDown (xlPatternDown)

-test_xlPatternGray16 (xlPatternGray16)

-test_xlPatternGray25 (xlPatternGray25)

-test_xlPatternGray50 (xlPatternGray50)

-test_xlPatternGray75 (xlPatternGray75)

-test_xlPatternGray8 (xlPatternGray8)

-test_xlPatternGrid (xlPatternGrid)

-test_xlPatternHorizontal (xlPatternHorizontal)

-test_xlPatternLightDown (xlPatternLightDown)

-test_xlPatternLightHorizontal (xlPatternLightHorizontal)

-test_xlPatternLightUp (xlPatternLightUp)

-test_xlPatternLightVertical (xlPatternLightVertical)

-test_xlPatternNone (xlPatternNone)

-test_xlPatternSemiGray75 (xlPatternSemiGray75)

-test_xlPatternSolid (xlPatternSolid)

-test_xlPatternUp (xlPatternUp)

-test_xlPatternVertical (xlPatternVertical)

-test_XlPhoneticAlignCenter (XlPhoneticAlignCenter)

-test_XlPhoneticAlignDistributed (XlPhoneticAlignDistributed)

-test_XlPhoneticAlignLeft (XlPhoneticAlignLeft)

-test_XlPhoneticAlignNoControl (XlPhoneticAlignNoControl)

-test_xlPrinter (xlPrinter)

-test_xlScreen (xlScreen)

-test_xlBMP (xlBMP)

-test_xlCGM (xlCGM)

-test_xlDRW (xlDRW)

-test_xlDXF (xlDXF)

-test_xlEPS (xlEPS)

-test_xlHGL (xlHGL)

-test_xlPCT (xlPCT)

-test_xlPCX (xlPCX)

-test_xlPIC (xlPIC)

-test_xlPLT (xlPLT)

-test_xlTIF (xlTIF)

-test_xlWMF (xlWMF)

-test_xlWPG (xlWPG)

-test_xlPivotCellBlankCell (xlPivotCellBlankCell)

-test_xlPivotCellCustomSubtotal (xlPivotCellCustomSubtotal)

-test_xlPivotCellDataField (xlPivotCellDataField)

-test_xlPivotCellDataPivotField (xlPivotCellDataPivotField)

-test_xlPivotCellGrandTotal (xlPivotCellGrandTotal)

-test_xlPivotCellPageFieldItem (xlPivotCellPageFieldItem)

-test_xlPivotCellPivotField (xlPivotCellPivotField)

-test_xlPivotCellPivotItem (xlPivotCellPivotItem)

-test_xlPivotCellSubtotal (xlPivotCellSubtotal)

-test_xlPivotCellValue (xlPivotCellValue)

-test_xlDifferenceFrom (xlDifferenceFrom)

-test_xlIndex (xlIndex)

-test_xlNoAdditionalCalculation (xlNoAdditionalCalculation)

-test_xlPercentDifferenceFrom (xlPercentDifferenceFrom)

-test_xlPercentOf (xlPercentOf)

-test_xlPercentOfColumn (xlPercentOfColumn)

-test_xlPercentOfRow (xlPercentOfRow)

-test_xlPercentOfTotal (xlPercentOfTotal)

-test_xlRunningTotal (xlRunningTotal)

-test_xlDate (xlDate)

-test_xlNumber (xlNumber)

-test_xlText (xlText)

-test_xlColumnField (xlColumnField)

-test_xlDataField (xlDataField)

-test_xlHidden (xlHidden)

-test_xlPageField (xlPageField)

-test_xlRowField (xlRowField)

-test_xlPTClassic (xlPTClassic)

-test_xlPTNone (xlPTNone)

-test_xlReport1 (xlReport1)

-test_xlReport10 (xlReport10)

-test_xlReport2 (xlReport2)

-test_xlReport3 (xlReport3)

-test_xlReport4 (xlReport4)

-test_xlReport5 (xlReport5)

-test_xlReport6 (xlReport6)

-test_xlReport7 (xlReport7)

-test_xlReport8 (xlReport8)

-test_xlReport9 (xlReport9)

-test_xlTable1 (xlTable1)

-test_xlTable10 (xlTable10)

-test_xlTable2 (xlTable2)

-test_xlTable3 (xlTable3)

-test_xlTable4 (xlTable4)

-test_xlTable5 (xlTable5)

-test_xlTable6 (xlTable6)

-test_xlTable7 (xlTable7)

-test_xlTable8 (xlTable8)

-test_xlTable9 (xlTable9)

-test_xlMissingItemsDefault (xlMissingItemsDefault)

-test_xlMissingItemsMax (xlMissingItemsMax)

-test_xlMissingItemsNone (xlMissingItemsNone)

-test_xlConsolidation (xlConsolidation)

-test_xlDatabase (xlDatabase)

-test_xlExternal (xlExternal)

-test_xlPivotTable (xlPivotTable)

-test_xlScenario (xlScenario)

-test_xlPivotTableVersion10 (xlPivotTableVersion10)

-test_xlPivotTableVersion2000 (xlPivotTableVersion2000)

-test_xlPivotTableCurrent (xlPivotTableCurrent)

-test_xlFreeFloating (xlFreeFloating)

-test_xlMove (xlMove)

-test_xlMoveAndSize (xlMoveAndSize)

-test_xlMacintosh (xlMacintosh)

-test_xlMSDOS (xlMSDOS)

-test_xlWindows (xlWindows)

-test_xlPrintErrorsBlank (xlPrintErrorsBlank)

-test_xlPrintErrorsDash (xlPrintErrorsDash)

-test_xlPrintErrorsDisplayed (xlPrintErrorsDisplayed)

-test_xlPrintErrorsNA (xlPrintErrorsNA)

-test_xlPrintLocation (xlPrintLocation)

-test_xlPrintNoComments (xlPrintNoComments)

-test_xlPrintSheetEnd (xlPrintSheetEnd)

-test_xlPriorityHigh (xlPriorityHigh)

-test_xlPriorityLow (xlPriorityLow)

-test_xlPriorityNormal (xlPriorityNormal)

-test_xlADORecordset (xlADORecordset)

-test_xlDAORecordset (xlDAORecordset)

-test_xlODBCQuery (xlODBCQuery)

-test_xlOLEDBQuery (xlOLEDBQuery)

-test_xlTextImport (xlTextImport)

-test_xlWebQuery (xlWebQuery)

-test_xlRangeAutoFormat3DEffects1 (xlRangeAutoFormat3DEffects1)

-test_xlRangeAutoFormat3DEffects2 (xlRangeAutoFormat3DEffects2)

-test_xlRangeAutoFormatAccounting1 (xlRangeAutoFormatAccounting1)

-test_xlRangeAutoFormatAccounting2 (xlRangeAutoFormatAccounting2)

-test_xlRangeAutoFormatAccounting3 (xlRangeAutoFormatAccounting3)

-test_xlRangeAutoFormatAccounting4 (xlRangeAutoFormatAccounting4)

-test_xlRangeAutoFormatClassic1 (xlRangeAutoFormatClassic1)

-test_xlRangeAutoFormatClassic2 (xlRangeAutoFormatClassic2)

-test_xlRangeAutoFormatClassic3 (xlRangeAutoFormatClassic3)

-test_xlRangeAutoFormatClassicPivotTable (xlRangeAutoFormatClassicPivotTable)

-test_xlRangeAutoFormatColor1 (xlRangeAutoFormatColor1)

-test_xlRangeAutoFormatColor2 (xlRangeAutoFormatColor2)

-test_xlRangeAutoFormatColor3 (xlRangeAutoFormatColor3)

-test_xlRangeAutoFormatList1 (xlRangeAutoFormatList1)

-test_xlRangeAutoFormatList2 (xlRangeAutoFormatList2)

-test_xlRangeAutoFormatList3 (xlRangeAutoFormatList3)

-test_xlRangeAutoFormatLocalFormat1 (xlRangeAutoFormatLocalFormat1)

-test_xlRangeAutoFormatLocalFormat2 (xlRangeAutoFormatLocalFormat2)

-test_xlRangeAutoFormatLocalFormat3 (xlRangeAutoFormatLocalFormat3)

-test_xlRangeAutoFormatLocalFormat4 (xlRangeAutoFormatLocalFormat4)

-test_xlRangeAutoFormatNone (xlRangeAutoFormatNone)

-test_xlRangeAutoFormatPTNone (xlRangeAutoFormatPTNone)

-test_xlRangeAutoFormatReport1 (xlRangeAutoFormatReport1)

-test_xlRangeAutoFormatReport10 (xlRangeAutoFormatReport10)

-test_xlRangeAutoFormatReport2 (xlRangeAutoFormatReport2)

-test_xlRangeAutoFormatReport3 (xlRangeAutoFormatReport3)

-test_xlRangeAutoFormatReport4 (xlRangeAutoFormatReport4)

-test_xlRangeAutoFormatReport5 (xlRangeAutoFormatReport5)

-test_xlRangeAutoFormatReport6 (xlRangeAutoFormatReport6)

-test_xlRangeAutoFormatReport7 (xlRangeAutoFormatReport7)

-test_xlRangeAutoFormatReport8 (xlRangeAutoFormatReport8)

-test_xlRangeAutoFormatReport9 (xlRangeAutoFormatReport9)

-test_xlRangeAutoFormatSimple (xlRangeAutoFormatSimple)

-test_xlRangeAutoFormatTable1 (xlRangeAutoFormatTable1)

-test_xlRangeAutoFormatTable10 (xlRangeAutoFormatTable10)

-test_xlRangeAutoFormatTable2 (xlRangeAutoFormatTable2)

-test_xlRangeAutoFormatTable3 (xlRangeAutoFormatTable3)

-test_xlRangeAutoFormatTable4 (xlRangeAutoFormatTable4)

-test_xlRangeAutoFormatTable5 (xlRangeAutoFormatTable5)

-test_xlRangeAutoFormatTable6 (xlRangeAutoFormatTable6)

-test_xlRangeAutoFormatTable7 (xlRangeAutoFormatTable7)

-test_xlRangeAutoFormatTable8 (xlRangeAutoFormatTable8)

-test_xlRangeAutoFormatTable9 (xlRangeAutoFormatTable9)

-test_xlRangeValueDefault (xlRangeValueDefault)

-test_xlRangeValueMSPersistXML (xlRangeValueMSPersistXML)

-test_xlRangeValueXMLSpreadsheet (xlRangeValueXMLSpreadsheet)

-test_xlA1 (xlA1)

-test_xlR1C1 (xlR1C1)

-test_xlAbsolute (xlAbsolute)

-test_xlAbsRowRelColumn (xlAbsRowRelColumn)

-test_xlRelative (xlRelative)

-test_xlRelRowAbsColumn (xlRelRowAbsColumn)

-test_xlAlways (xlAlways)

-test_xlAsRequired (xlAsRequired)

-test_xlNever (xlNever)

-test_xlAllAtOnce (xlAllAtOnce)

-test_xlOneAfterAnother (xlOneAfterAnother)

-test_xlNotYetRouted (xlNotYetRouted)

-test_xlRoutingComplete (xlRoutingComplete)

-test_xlRoutingInProgress (xlRoutingInProgress)

-test_xlColumns (xlColumns)

-test_xlRows (xlRows)

-test_xlAutoActivate (xlAutoActivate)

-test_xlAutoClose (xlAutoClose)

-test_xlAutoDeactivate (xlAutoDeactivate)

-test_xlAutoOpen (xlAutoOpen)

-test_xlDoNotSaveChanges (xlDoNotSaveChanges)

-test_xlSaveChanges (xlSaveChanges)

-test_xlExclusive (xlExclusive)

-test_xlNoChange (xlNoChange)

-test_xlShared (xlShared)

-test_xlLocalSessionsChanges (xlLocalSessionsChanges)

-test_xlOtherSessionsChanges (xlOtherSessionsChanges)

-test_xlUserResolution (xlUserResolution)

-test_xlScaleLinear (xlScaleLinear)

-test_xlScaleLogarithmicr (xlScaleLogarithmicr)

-test_xlNext (xlNext)

-test_xlPrevious (xlPrevious)

-test_xlByColumns (xlByColumns)

-test_xlByRows (xlByRows)

-test_xlWithinSheet (xlWithinSheet)

-test_xlWithinWorkbook (xlWithinWorkbook)

-test_xlChart (xlChart)

-test_xlDialogSheet (xlDialogSheet)

-test_xlExcel4IntMacroSheet (xlExcel4IntMacroSheet)

-test_xlExcel4MacroSheet (xlExcel4MacroSheet)

-test_xlWorkSheet (xlWorkSheet)

-test_xlSheetHidden (xlSheetHidden)

-test_xlSheetVeryHidden (xlSheetVeryHidden)

-test_xlSheetVisible (xlSheetVisible)

-test_xlSizeIsArea (xlSizeIsArea)

-test_xlSizeIsWidth (xlSizeIsWidth)

-test_xlSmartTagControlActiveX (xlSmartTagControlActiveX)

-test_xlSmartTagControlButton (xlSmartTagControlButton)

-test_xlSmartTagControlCheckbox (xlSmartTagControlCheckbox)

-test_xlSmartTagControlCombo (xlSmartTagControlCombo)

-test_xlSmartTagControlHelp (xlSmartTagControlHelp)

-test_xlSmartTagControlHelpURL (xlSmartTagControlHelpURL)

-test_xlSmartTagControlImage (xlSmartTagControlImage)

-test_xlSmartTagControlLabel (xlSmartTagControlLabel)

-test_xlSmartTagControlLink (xlSmartTagControlLink)

-test_xlSmartTagControlListbox (xlSmartTagControlListbox)

-test_xlSmartTagControlRadioGroup (xlSmartTagControlRadioGroup)

-test_xlSmartTagControlSeparator (xlSmartTagControlSeparator)

-test_xlSmartTagControlSmartTag (xlSmartTagControlSmartTag)

-test_xlSmartTagControlTextbox (xlSmartTagControlTextbox)

-test_xlButtonOnly (xlButtonOnly)

-test_xlDisplayNone (xlDisplayNone)

-test_xlIndicatorAndButton (xlIndicatorAndButton)

-test_xlSortNormal (xlSortNormal)

-test_xlSortTextAsNumbers (xlSortTextAsNumbers)

-test_xlPinYin (xlPinYin)

-test_xlStroke (xlStroke)

-test_xlCodePage (xlCodePage)

-test_xlSyllabary (xlSyllabary)

-test_xlAscending (xlAscending)

-test_xlDescending (xlDescending)

-test_xlSortColumns (xlSortColumns)

-test_xlSortRows (xlSortRows)

-test_xlSortLabels (xlSortLabels)

-test_xlSortValues (xlSortValues)

-test_xlSourceAutoFilter (xlSourceAutoFilter)

-test_xlSourceChart (xlSourceChart)

-test_xlSourcePivotTable (xlSourcePivotTable)

-test_xlSourcePrintArea (xlSourcePrintArea)

-test_xlSourceQuery (xlSourceQuery)

-test_xlSourceRange (xlSourceRange)

-test_xlSourceSheet (xlSourceSheet)

-test_xlSourceWordbook (xlSourceWordbook)

-test_xlSpeakByColumns (xlSpeakByColumns)

-test_xlSpeakByRows (xlSpeakByRows)

-test_xlErrors (xlErrors)

-test_xlLogical (xlLogical)

-test_xlNumbers (xlNumbers)

-test_xlTextValues (xlTextValues)

-test_xlSubscribeToPicture (xlSubscribeToPicture)

-test_xlSubscribeToText (xlSubscribeToText)

-test_xlAtBottom (xlAtBottom)

-test_xlAtTop (xlAtTop)

-test_xlSummaryOnLeft (xlSummaryOnLeft)

-test_xlSummaryOnRight (xlSummaryOnRight)

-test_xlStandardSummary (xlStandardSummary)

-test_xlSummaryPivotTable (xlSummaryPivotTable)

-test_xlSummaryAbove (xlSummaryAbove)

-test_xlSummaryBelow (xlSummaryBelow)

-test_xlTabPositionFirst (xlTabPositionFirst)

-test_xlTabPositionLast (xlTabPositionLast)

-test_xlDelimited (xlDelimited)

-test_xlFixedWidth (xlFixedWidth)

-test_xlTextQualifierDoubleQuote (xlTextQualifierDoubleQuote)

-test_xlTextQualifierNone (xlTextQualifierNone)

-test_xlTextQualifierSingleQuote (xlTextQualifierSingleQuote)

-test_xlTextVisualLTR (xlTextVisualLTR)

-test_xlTextVisualRTL (xlTextVisualRTL)

-test_XlTickLabelOrientationAutomatic (XlTickLabelOrientationAutomatic)

-test_XlTickLabelOrientationDownward (XlTickLabelOrientationDownward)

-test_XlTickLabelOrientationHorizontal (XlTickLabelOrientationHorizontal)

-test_XlTickLabelOrientationUpward (XlTickLabelOrientationUpward)

-test_XlTickLabelOrientationVertical (XlTickLabelOrientationVertical)

-test_xlTickLabelPositionHigh (xlTickLabelPositionHigh)

-test_xlTickLabelPositionLow (xlTickLabelPositionLow)

-test_xlTickLabelPositionNextToAxis (xlTickLabelPositionNextToAxis)

-test_xlTickLabelPositionNone (xlTickLabelPositionNone)

-test_xlTickMarkCross (xlTickMarkCross)

-test_xlTickMarkInside (xlTickMarkInside)

-test_xlTickMarkNone (xlTickMarkNone)

-test_xlTickMarkOutside (xlTickMarkOutside)

-test_xlDays (xlDays)

-test_xlMonths (xlMonths)

-test_xlYears (xlYears)

-test_xlNoButtonChanges (xlNoButtonChanges)

-test_xlNoChanges (xlNoChanges)

-test_xlNoDockingChanges (xlNoDockingChanges)

-test_xlNoShapeChanges (xlNoShapeChanges)

-test_xlToolbarProtectionNone (xlToolbarProtectionNone)

-test_xlTotalsCalculationAverage (xlTotalsCalculationAverage)

-test_xlTotalsCalculationCount (xlTotalsCalculationCount)

-test_xlTotalsCalculationCountNums (xlTotalsCalculationCountNums)

-test_xlTotalsCalculationCountMax (xlTotalsCalculationCountMax)

-test_xlTotalsCalculationCountMin (xlTotalsCalculationCountMin)

-test_xlTotalsCalculationCountNone (xlTotalsCalculationCountNone)

-test_xlTotalsCalculationCountStdDev (xlTotalsCalculationCountStdDev)

-test_xlTotalsCalculationCountSum (xlTotalsCalculationCountSum)

-test_xlTotalsCalculationCountVar (xlTotalsCalculationCountVar)

-test_xlExponential (xlExponential)

-test_xlLinear (xlLinear)

-test_xlLogarithmic (xlLogarithmic)

-test_xlMovingAvg (xlMovingAvg)

-test_xlPolynomial (xlPolynomial)

-test_xlPower (xlPower)

-test_XlUnderlineStyleDouble (XlUnderlineStyleDouble)

-test_XlUnderlineStyleDoubleAccounting (XlUnderlineStyleDoubleAccounting)

-test_XlUnderlineStyleNone (XlUnderlineStyleNone)

-test_XlUnderlineStyleSingle (XlUnderlineStyleSingle)

-test_XlUnderlineStyleSingleAccounting (XlUnderlineStyleSingleAccounting)

-test_XlUpdateLinksAlways (XlUpdateLinksAlways)

-test_XlUpdateLinksNever (XlUpdateLinksNever)

-test_XlUpdateLinksUserSetting (XlUpdateLinksUserSetting)

-test_xlVAlignBottom (xlVAlignBottom)

-test_xlVAlignCenter (xlVAlignCenter)

-test_xlVAlignDistributed (xlVAlignDistributed)

-test_xlVAlignJustify (xlVAlignJustify)

-test_xlVAlignTop (xlVAlignTop)

-test_XlWBATChart (XlWBATChart)

-test_XlWBATExcel4IntlMacroSheet (XlWBATExcel4IntlMacroSheet)

-test_XlWBATExcel4MacroSheet (XlWBATExcel4MacroSheet)

-test_XlWBATWorksheet (XlWBATWorksheet)

-test_xlWebFormattingAll (xlWebFormattingAll)

-test_xlWebFormattingNone (xlWebFormattingNone)

-test_xlWebFormattingRTF (xlWebFormattingRTF)

-test_xlAllTables (xlAllTables)

-test_xlEntirePage (xlEntirePage)

-test_xlSpecifiedTables (xlSpecifiedTables)

-test_xlMaximized (xlMaximized)

-test_xlMinimized (xlMinimized)

-test_xlNormal (xlNormal)

-test_xlChartAsWindow (xlChartAsWindow)

-test_xlChartInPlace (xlChartInPlace)

-test_xlClipboard (xlClipboard)

-test_xlInfo (xlInfo)

-test_xlWordbook (xlWordbook)

-test_xlNormalView (xlNormalView)

-test_xlPageBreakPreview (xlPageBreakPreview)

-test_xlCommand (xlCommand)

-test_xlFunction (xlFunction)

-test_xlnotXLM (xlnotXLM)

-test_xlXmlExportSuccess (xlXmlExportSuccess)

-test_xlXmlExportValidationFailed (xlXmlExportValidationFailed)

-test_xlXmlImportElementsTruncated (xlXmlImportElementsTruncated)

-test_xlXmlImportSuccess (xlXmlImportSuccess)

-test_xlXmlImportValidationFailed (xlXmlImportValidationFailed)

-test_xlXmlLoadImportToList (xlXmlLoadImportToList)

-test_xlXmlLoadMapXml (xlXmlLoadMapXml)

-test_xlXmlLoadOpenXml (xlXmlLoadOpenXml)

-test_xlXmlLoadPromptUser (xlXmlLoadPromptUser)

-test_xlGuess (xlGuess)

-test_xlNo (xlNo)

-test_xlYes (xlYes)

-Range("A1").Value = "constant name"

-Range("B1").Value = "OOo result"

-Range("C1").Value = "Excel result"

-Range("D1").Value = "Correct?"

-End Sub

-

-Function test_XlEditionFormat(ByRef num)

-Range("A2").Clear

-Range("B2").Clear

-Range("C2").Clear

-Range("D2").Clear

-Range("A2").Value = "XlEditionFormat"

-Range("B2").Value = 0

-Range("C2").Value = num

-B2 = Range("B2").Value

-C2 = Range("C2").Value

-If B2 = C2 Then

-Range("D2").Value = "OK"

-Else

-Range("D2").Value = "NG"

-End If

-End Function

-

-Function test_xlAutomaticUpdate(ByRef num)

-Range("A3").Clear

-Range("B3").Clear

-Range("C3").Clear

-Range("D3").Clear

-Range("A3").Value = "xlAutomaticUpdate"

-Range("B3").Value = 4

-Range("C3").Value = num

-B3 = Range("B3").Value

-C3 = Range("C3").Value

-If B3 = C3 Then

-Range("D3").Value = "OK"

-Else

-Range("D3").Value = "NG"

-End If

-End Function

-

-Function test_xlCancel(ByRef num)

-Range("A4").Clear

-Range("B4").Clear

-Range("C4").Clear

-Range("D4").Clear

-Range("A4").Value = "xlCancel"

-Range("B4").Value = 1

-Range("C4").Value = num

-B4 = Range("B4").Value

-C4 = Range("C4").Value

-If B4 = C4 Then

-Range("D4").Value = "OK"

-Else

-Range("D4").Value = "NG"

-End If

-End Function

-

-Function test_xlChangeAttributes(ByRef num)

-Range("A5").Clear

-Range("B5").Clear

-Range("C5").Clear

-Range("D5").Clear

-Range("A5").Value = "xlChangeAttributes"

-Range("B5").Value = 6

-Range("C5").Value = num

-B5 = Range("B5").Value

-C5 = Range("C5").Value

-If B5 = C5 Then

-Range("D5").Value = "OK"

-Else

-Range("D5").Value = "NG"

-End If

-End Function

-

-Function test_xlManualUpdate(ByRef num)

-Range("A6").Clear

-Range("B6").Clear

-Range("C6").Clear

-Range("D6").Clear

-Range("A6").Value = "xlManualUpdate"

-Range("B6").Value = 5

-Range("C6").Value = num

-B6 = Range("B6").Value

-C6 = Range("C6").Value

-If B6 = C6 Then

-Range("D6").Value = "OK"

-Else

-Range("D6").Value = "NG"

-End If

-End Function

-

-Function test_xlOpenSource(ByRef num)

-Range("A7").Clear

-Range("B7").Clear

-Range("C7").Clear

-Range("D7").Clear

-Range("A7").Value = "xlOpenSource"

-Range("B7").Value = 3

-Range("C7").Value = num

-B7 = Range("B7").Value

-C7 = Range("C7").Value

-If B7 = C7 Then

-Range("D7").Value = "OK"

-Else

-Range("D7").Value = "NG"

-End If

-End Function

-

-Function test_xlSelect(ByRef num)

-Range("A8").Clear

-Range("B8").Clear

-Range("C8").Clear

-Range("D8").Clear

-Range("A8").Value = "xlSelect"

-Range("B8").Value = 3

-Range("C8").Value = num

-B8 = Range("B8").Value

-C8 = Range("C8").Value

-If B8 = C8 Then

-Range("D8").Value = "OK"

-Else

-Range("D8").Value = "NG"

-End If

-End Function

-

-Function test_xlSendPublisher(ByRef num)

-Range("A9").Clear

-Range("B9").Clear

-Range("C9").Clear

-Range("D9").Clear

-Range("A9").Value = "xlSendPublisher"

-Range("B9").Value = 2

-Range("C9").Value = num

-B9 = Range("B9").Value

-C9 = Range("C9").Value

-If B9 = C9 Then

-Range("D9").Value = "OK"

-Else

-Range("D9").Value = "NG"

-End If

-End Function

-

-Function test_xlUpdateSubscriber(ByRef num)

-Range("A10").Clear

-Range("B10").Clear

-Range("C10").Clear

-Range("D10").Clear

-Range("A10").Value = "xlUpdateSubscriber"

-Range("B10").Value = 2

-Range("C10").Value = num

-B10 = Range("B10").Value

-C10 = Range("C10").Value

-If B10 = C10 Then

-Range("D10").Value = "OK"

-Else

-Range("D10").Value = "NG"

-End If

-End Function

-

-Function test_xlPublisher(ByRef num)

-Range("A11").Clear

-Range("B11").Clear

-Range("C11").Clear

-Range("D11").Clear

-Range("A11").Value = "xlPublisher"

-Range("B11").Value = 1

-Range("C11").Value = num

-B11 = Range("B11").Value

-C11 = Range("C11").Value

-If B11 = C11 Then

-Range("D11").Value = "OK"

-Else

-Range("D11").Value = "NG"

-End If

-End Function

-

-Function test_xlSubscriber(ByRef num)

-Range("A12").Clear

-Range("B12").Clear

-Range("C12").Clear

-Range("D12").Clear

-Range("A12").Value = "xlSubscriber"

-Range("B12").Value = 2

-Range("C12").Value = num

-B12 = Range("B12").Value

-C12 = Range("C12").Value

-If B12 = C12 Then

-Range("D12").Value = "OK"

-Else

-Range("D12").Value = "NG"

-End If

-End Function

-

-Function test_xlDisabled(ByRef num)

-Range("A13").Clear

-Range("B13").Clear

-Range("C13").Clear

-Range("D13").Clear

-Range("A13").Value = "xlDisabled"

-Range("B13").Value = 0

-Range("C13").Value = num

-B13 = Range("B13").Value

-C13 = Range("C13").Value

-If B13 = C13 Then

-Range("D13").Value = "OK"

-Else

-Range("D13").Value = "NG"

-End If

-End Function

-

-Function test_xlErrorHandler(ByRef num)

-Range("A14").Clear

-Range("B14").Clear

-Range("C14").Clear

-Range("D14").Clear

-Range("A14").Value = "xlErrorHandler"

-Range("B14").Value = 2

-Range("C14").Value = num

-B14 = Range("B14").Value

-C14 = Range("C14").Value

-If B14 = C14 Then

-Range("D14").Value = "OK"

-Else

-Range("D14").Value = "NG"

-End If

-End Function

-

-Function test_xlInterrupt(ByRef num)

-Range("A15").Clear

-Range("B15").Clear

-Range("C15").Clear

-Range("D15").Clear

-Range("A15").Value = "xlInterrupt"

-Range("B15").Value = 1

-Range("C15").Value = num

-B15 = Range("B15").Value

-C15 = Range("C15").Value

-If B15 = C15 Then

-Range("D15").Value = "OK"

-Else

-Range("D15").Value = "NG"

-End If

-End Function

-

-Function test_xlNoRestrictions(ByRef num)

-Range("A16").Clear

-Range("B16").Clear

-Range("C16").Clear

-Range("D16").Clear

-Range("A16").Value = "xlNoRestrictions"

-Range("B16").Value = 0

-Range("C16").Value = num

-B16 = Range("B16").Value

-C16 = Range("C16").Value

-If B16 = C16 Then

-Range("D16").Value = "OK"

-Else

-Range("D16").Value = "NG"

-End If

-End Function

-

-Function test_xlNoSelection(ByRef num)

-Range("A17").Clear

-Range("B17").Clear

-Range("C17").Clear

-Range("D17").Clear

-Range("A17").Value = "xlNoSelection"

-Range("B17").Value = -4142

-Range("C17").Value = num

-B17 = Range("B17").Value

-C17 = Range("C17").Value

-If B17 = C17 Then

-Range("D17").Value = "OK"

-Else

-Range("D17").Value = "NG"

-End If

-End Function

-

-Function test_xlUnlockedCells(ByRef num)

-Range("A18").Clear

-Range("B18").Clear

-Range("C18").Clear

-Range("D18").Clear

-Range("A18").Value = "xlUnlockedCells"

-Range("B18").Value = 1

-Range("C18").Value = num

-B18 = Range("B18").Value

-C18 = Range("C18").Value

-If B18 = C18 Then

-Range("D18").Value = "OK"

-Else

-Range("D18").Value = "NG"

-End If

-End Function

-

-Function test_xlCap(ByRef num)

-Range("A19").Clear

-Range("B19").Clear

-Range("C19").Clear

-Range("D19").Clear

-Range("A19").Value = "xlCap"

-Range("B19").Value = 1

-Range("C19").Value = num

-B19 = Range("B19").Value

-C19 = Range("C19").Value

-If B19 = C19 Then

-Range("D19").Value = "OK"

-Else

-Range("D19").Value = "NG"

-End If

-End Function

-

-Function test_xlNoCap(ByRef num)

-Range("A20").Clear

-Range("B20").Clear

-Range("C20").Clear

-Range("D20").Clear

-Range("A20").Value = "xlNoCap"

-Range("B20").Value = 2

-Range("C20").Value = num

-B20 = Range("B20").Value

-C20 = Range("C20").Value

-If B20 = C20 Then

-Range("D20").Value = "OK"

-Else

-Range("D20").Value = "NG"

-End If

-End Function

-

-Function test_xlX(ByRef num)

-Range("A21").Clear

-Range("B21").Clear

-Range("C21").Clear

-Range("D21").Clear

-Range("A21").Value = "xlX"

-Range("B21").Value = -4168

-Range("C21").Value = num

-B21 = Range("B21").Value

-C21 = Range("C21").Value

-If B21 = C21 Then

-Range("D21").Value = "OK"

-Else

-Range("D21").Value = "NG"

-End If

-End Function

-

-Function test_xlY(ByRef num)

-Range("A22").Clear

-Range("B22").Clear

-Range("C22").Clear

-Range("D22").Clear

-Range("A22").Value = "xlY"

-Range("B22").Value = 1

-Range("C22").Value = num

-B22 = Range("B22").Value

-C22 = Range("C22").Value

-If B22 = C22 Then

-Range("D22").Value = "OK"

-Else

-Range("D22").Value = "NG"

-End If

-End Function

-

-Function test_xlErrorBarIncludeBoth(ByRef num)

-Range("A23").Clear

-Range("B23").Clear

-Range("C23").Clear

-Range("D23").Clear

-Range("A23").Value = "xlErrorBarIncludeBoth"

-Range("B23").Value = 1

-Range("C23").Value = num

-B23 = Range("B23").Value

-C23 = Range("C23").Value

-If B23 = C23 Then

-Range("D23").Value = "OK"

-Else

-Range("D23").Value = "NG"

-End If

-End Function

-

-Function test_xlErrorBarIncludeMinusValues(ByRef num)

-Range("A24").Clear

-Range("B24").Clear

-Range("C24").Clear

-Range("D24").Clear

-Range("A24").Value = "xlErrorBarIncludeMinusValues"

-Range("B24").Value = 3

-Range("C24").Value = num

-B24 = Range("B24").Value

-C24 = Range("C24").Value

-If B24 = C24 Then

-Range("D24").Value = "OK"

-Else

-Range("D24").Value = "NG"

-End If

-End Function

-

-Function test_xlErrorBarIncludeNone(ByRef num)

-Range("A25").Clear

-Range("B25").Clear

-Range("C25").Clear

-Range("D25").Clear

-Range("A25").Value = "xlErrorBarIncludeNone"

-Range("B25").Value = -4142

-Range("C25").Value = num

-B25 = Range("B25").Value

-C25 = Range("C25").Value

-If B25 = C25 Then

-Range("D25").Value = "OK"

-Else

-Range("D25").Value = "NG"

-End If

-End Function

-

-Function test_xlErrorBarIncludePlusValues(ByRef num)

-Range("A26").Clear

-Range("B26").Clear

-Range("C26").Clear

-Range("D26").Clear

-Range("A26").Value = "xlErrorBarIncludePlusValues"

-Range("B26").Value = 2

-Range("C26").Value = num

-B26 = Range("B26").Value

-C26 = Range("C26").Value

-If B26 = C26 Then

-Range("D26").Value = "OK"

-Else

-Range("D26").Value = "NG"

-End If

-End Function

-

-Function test_xlErrorBarTypeCustom(ByRef num)

-Range("A27").Clear

-Range("B27").Clear

-Range("C27").Clear

-Range("D27").Clear

-Range("A27").Value = "xlErrorBarTypeCustom"

-Range("B27").Value = -4144

-Range("C27").Value = num

-B27 = Range("B27").Value

-C27 = Range("C27").Value

-If B27 = C27 Then

-Range("D27").Value = "OK"

-Else

-Range("D27").Value = "NG"

-End If

-End Function

-

-Function test_xlErrorBarTypeFixedValue(ByRef num)

-Range("A28").Clear

-Range("B28").Clear

-Range("C28").Clear

-Range("D28").Clear

-Range("A28").Value = "xlErrorBarTypeFixedValue"

-Range("B28").Value = 1

-Range("C28").Value = num

-B28 = Range("B28").Value

-C28 = Range("C28").Value

-If B28 = C28 Then

-Range("D28").Value = "OK"

-Else

-Range("D28").Value = "NG"

-End If

-End Function

-

-Function test_xlErrorBarTypePercent(ByRef num)

-Range("A29").Clear

-Range("B29").Clear

-Range("C29").Clear

-Range("D29").Clear

-Range("A29").Value = "xlErrorBarTypePercent"

-Range("B29").Value = 2

-Range("C29").Value = num

-B29 = Range("B29").Value

-C29 = Range("C29").Value

-If B29 = C29 Then

-Range("D29").Value = "OK"

-Else

-Range("D29").Value = "NG"

-End If

-End Function

-

-Function test_xlErrorBarTypeStDev(ByRef num)

-Range("A30").Clear

-Range("B30").Clear

-Range("C30").Clear

-Range("D30").Clear

-Range("A30").Value = "xlErrorBarTypeStDev"

-Range("B30").Value = -4155

-Range("C30").Value = num

-B30 = Range("B30").Value

-C30 = Range("C30").Value

-If B30 = C30 Then

-Range("D30").Value = "OK"

-Else

-Range("D30").Value = "NG"

-End If

-End Function

-

-Function test_xlErrorBarTypeStError(ByRef num)

-Range("A31").Clear

-Range("B31").Clear

-Range("C31").Clear

-Range("D31").Clear

-Range("A31").Value = "xlErrorBarTypeStError"

-Range("B31").Value = 4

-Range("C31").Value = num

-B31 = Range("B31").Value

-C31 = Range("C31").Value

-If B31 = C31 Then

-Range("D31").Value = "OK"

-Else

-Range("D31").Value = "NG"

-End If

-End Function

-

-Function test_xlEmptyCellReferences(ByRef num)

-Range("A32").Clear

-Range("B32").Clear

-Range("C32").Clear

-Range("D32").Clear

-Range("A32").Value = "xlEmptyCellReferences"

-Range("B32").Value = 7

-Range("C32").Value = num

-B32 = Range("B32").Value

-C32 = Range("C32").Value

-If B32 = C32 Then

-Range("D32").Value = "OK"

-Else

-Range("D32").Value = "NG"

-End If

-End Function

-

-Function test_xlEvaluateToError(ByRef num)

-Range("A33").Clear

-Range("B33").Clear

-Range("C33").Clear

-Range("D33").Clear

-Range("A33").Value = "xlEvaluateToError"

-Range("B33").Value = 1

-Range("C33").Value = num

-B33 = Range("B33").Value

-C33 = Range("C33").Value

-If B33 = C33 Then

-Range("D33").Value = "OK"

-Else

-Range("D33").Value = "NG"

-End If

-End Function

-

-Function test_xlInconsistentFormula(ByRef num)

-Range("A34").Clear

-Range("B34").Clear

-Range("C34").Clear

-Range("D34").Clear

-Range("A34").Value = "xlInconsistentFormula"

-Range("B34").Value = 4

-Range("C34").Value = num

-B34 = Range("B34").Value

-C34 = Range("C34").Value

-If B34 = C34 Then

-Range("D34").Value = "OK"

-Else

-Range("D34").Value = "NG"

-End If

-End Function

-

-Function test_xlListDataValidation(ByRef num)

-Range("A35").Clear

-Range("B35").Clear

-Range("C35").Clear

-Range("D35").Clear

-Range("A35").Value = "xlListDataValidation"

-Range("B35").Value = 8

-Range("C35").Value = num

-B35 = Range("B35").Value

-C35 = Range("C35").Value

-If B35 = C35 Then

-Range("D35").Value = "OK"

-Else

-Range("D35").Value = "NG"

-End If

-End Function

-

-Function test_xlNumberAsText(ByRef num)

-Range("A36").Clear

-Range("B36").Clear

-Range("C36").Clear

-Range("D36").Clear

-Range("A36").Value = "xlNumberAsText"

-Range("B36").Value = 3

-Range("C36").Value = num

-B36 = Range("B36").Value

-C36 = Range("C36").Value

-If B36 = C36 Then

-Range("D36").Value = "OK"

-Else

-Range("D36").Value = "NG"

-End If

-End Function

-

-Function test_xlOmittedCells(ByRef num)

-Range("A37").Clear

-Range("B37").Clear

-Range("C37").Clear

-Range("D37").Clear

-Range("A37").Value = "xlOmittedCells"

-Range("B37").Value = 5

-Range("C37").Value = num

-B37 = Range("B37").Value

-C37 = Range("C37").Value

-If B37 = C37 Then

-Range("D37").Value = "OK"

-Else

-Range("D37").Value = "NG"

-End If

-End Function

-

-Function test_xlTextDate(ByRef num)

-Range("A38").Clear

-Range("B38").Clear

-Range("C38").Clear

-Range("D38").Clear

-Range("A38").Value = "xlTextDate"

-Range("B38").Value = 2

-Range("C38").Value = num

-B38 = Range("B38").Value

-C38 = Range("C38").Value

-If B38 = C38 Then

-Range("D38").Value = "OK"

-Else

-Range("D38").Value = "NG"

-End If

-End Function

-

-Function test_xlUnlockedFormulaCells(ByRef num)

-Range("A39").Clear

-Range("B39").Clear

-Range("C39").Clear

-Range("D39").Clear

-Range("A39").Value = "xlUnlockedFormulaCells"

-Range("B39").Value = 6

-Range("C39").Value = num

-B39 = Range("B39").Value

-C39 = Range("C39").Value

-If B39 = C39 Then

-Range("D39").Value = "OK"

-Else

-Range("D39").Value = "NG"

-End If

-End Function

-

-Function test_xlReadOnly(ByRef num)

-Range("A40").Clear

-Range("B40").Clear

-Range("C40").Clear

-Range("D40").Clear

-Range("A40").Value = "xlReadOnly"

-Range("B40").Value = 3

-Range("C40").Value = num

-B40 = Range("B40").Value

-C40 = Range("C40").Value

-If B40 = C40 Then

-Range("D40").Value = "OK"

-Else

-Range("D40").Value = "NG"

-End If

-End Function

-

-Function test_xlReadWrite(ByRef num)

-Range("A41").Clear

-Range("B41").Clear

-Range("C41").Clear

-Range("D41").Clear

-Range("A41").Value = "xlReadWrite"

-Range("B41").Value = 2

-Range("C41").Value = num

-B41 = Range("B41").Value

-C41 = Range("C41").Value

-If B41 = C41 Then

-Range("D41").Value = "OK"

-Else

-Range("D41").Value = "NG"

-End If

-End Function

-

-Function test_xlAddIn(ByRef num)

-Range("A42").Clear

-Range("B42").Clear

-Range("C42").Clear

-Range("D42").Clear

-Range("A42").Value = "xlAddIn"

-Range("B42").Value = 18

-Range("C42").Value = num

-B42 = Range("B42").Value

-C42 = Range("C42").Value

-If B42 = C42 Then

-Range("D42").Value = "OK"

-Else

-Range("D42").Value = "NG"

-End If

-End Function

-

-Function test_xlCSV(ByRef num)

-Range("A43").Clear

-Range("B43").Clear

-Range("C43").Clear

-Range("D43").Clear

-Range("A43").Value = "xlCSV"

-Range("B43").Value = 6

-Range("C43").Value = num

-B43 = Range("B43").Value

-C43 = Range("C43").Value

-If B43 = C43 Then

-Range("D43").Value = "OK"

-Else

-Range("D43").Value = "NG"

-End If

-End Function

-

-Function test_xlCSVMac(ByRef num)

-Range("A44").Clear

-Range("B44").Clear

-Range("C44").Clear

-Range("D44").Clear

-Range("A44").Value = "xlCSVMac"

-Range("B44").Value = 22

-Range("C44").Value = num

-B44 = Range("B44").Value

-C44 = Range("C44").Value

-If B44 = C44 Then

-Range("D44").Value = "OK"

-Else

-Range("D44").Value = "NG"

-End If

-End Function

-

-Function test_xlCSVMSDOS(ByRef num)

-Range("A45").Clear

-Range("B45").Clear

-Range("C45").Clear

-Range("D45").Clear

-Range("A45").Value = "xlCSVMSDOS"

-Range("B45").Value = 24

-Range("C45").Value = num

-B45 = Range("B45").Value

-C45 = Range("C45").Value

-If B45 = C45 Then

-Range("D45").Value = "OK"

-Else

-Range("D45").Value = "NG"

-End If

-End Function

-

-Function test_xlCSVWindows(ByRef num)

-Range("A46").Clear

-Range("B46").Clear

-Range("C46").Clear

-Range("D46").Clear

-Range("A46").Value = "xlCSVWindows"

-Range("B46").Value = 23

-Range("C46").Value = num

-B46 = Range("B46").Value

-C46 = Range("C46").Value

-If B46 = C46 Then

-Range("D46").Value = "OK"

-Else

-Range("D46").Value = "NG"

-End If

-End Function

-

-Function test_xlCurrentPlatformText(ByRef num)

-Range("A47").Clear

-Range("B47").Clear

-Range("C47").Clear

-Range("D47").Clear

-Range("A47").Value = "xlCurrentPlatformText"

-Range("B47").Value = -4158

-Range("C47").Value = num

-B47 = Range("B47").Value

-C47 = Range("C47").Value

-If B47 = C47 Then

-Range("D47").Value = "OK"

-Else

-Range("D47").Value = "NG"

-End If

-End Function

-

-Function test_xlDBF2(ByRef num)

-Range("A48").Clear

-Range("B48").Clear

-Range("C48").Clear

-Range("D48").Clear

-Range("A48").Value = "xlDBF2"

-Range("B48").Value = 7

-Range("C48").Value = num

-B48 = Range("B48").Value

-C48 = Range("C48").Value

-If B48 = C48 Then

-Range("D48").Value = "OK"

-Else

-Range("D48").Value = "NG"

-End If

-End Function

-

-Function test_xlDBF3(ByRef num)

-Range("A49").Clear

-Range("B49").Clear

-Range("C49").Clear

-Range("D49").Clear

-Range("A49").Value = "xlDBF3"

-Range("B49").Value = 8

-Range("C49").Value = num

-B49 = Range("B49").Value

-C49 = Range("C49").Value

-If B49 = C49 Then

-Range("D49").Value = "OK"

-Else

-Range("D49").Value = "NG"

-End If

-End Function

-

-Function test_xlDBF4(ByRef num)

-Range("A50").Clear

-Range("B50").Clear

-Range("C50").Clear

-Range("D50").Clear

-Range("A50").Value = "xlDBF4"

-Range("B50").Value = 11

-Range("C50").Value = num

-B50 = Range("B50").Value

-C50 = Range("C50").Value

-If B50 = C50 Then

-Range("D50").Value = "OK"

-Else

-Range("D50").Value = "NG"

-End If

-End Function

-

-Function test_xlDIF(ByRef num)

-Range("A51").Clear

-Range("B51").Clear

-Range("C51").Clear

-Range("D51").Clear

-Range("A51").Value = "xlDIF"

-Range("B51").Value = 9

-Range("C51").Value = num

-B51 = Range("B51").Value

-C51 = Range("C51").Value

-If B51 = C51 Then

-Range("D51").Value = "OK"

-Else

-Range("D51").Value = "NG"

-End If

-End Function

-

-Function test_xlExcel2(ByRef num)

-Range("A52").Clear

-Range("B52").Clear

-Range("C52").Clear

-Range("D52").Clear

-Range("A52").Value = "xlExcel2"

-Range("B52").Value = 16

-Range("C52").Value = num

-B52 = Range("B52").Value

-C52 = Range("C52").Value

-If B52 = C52 Then

-Range("D52").Value = "OK"

-Else

-Range("D52").Value = "NG"

-End If

-End Function

-

-Function test_xlExcel2FarEast(ByRef num)

-Range("A53").Clear

-Range("B53").Clear

-Range("C53").Clear

-Range("D53").Clear

-Range("A53").Value = "xlExcel2FarEast"

-Range("B53").Value = 27

-Range("C53").Value = num

-B53 = Range("B53").Value

-C53 = Range("C53").Value

-If B53 = C53 Then

-Range("D53").Value = "OK"

-Else

-Range("D53").Value = "NG"

-End If

-End Function

-

-Function test_xlExcel3(ByRef num)

-Range("A54").Clear

-Range("B54").Clear

-Range("C54").Clear

-Range("D54").Clear

-Range("A54").Value = "xlExcel3"

-Range("B54").Value = 29

-Range("C54").Value = num

-B54 = Range("B54").Value

-C54 = Range("C54").Value

-If B54 = C54 Then

-Range("D54").Value = "OK"

-Else

-Range("D54").Value = "NG"

-End If

-End Function

-

-Function test_xlExcel4(ByRef num)

-Range("A55").Clear

-Range("B55").Clear

-Range("C55").Clear

-Range("D55").Clear

-Range("A55").Value = "xlExcel4"

-Range("B55").Value = 33

-Range("C55").Value = num

-B55 = Range("B55").Value

-C55 = Range("C55").Value

-If B55 = C55 Then

-Range("D55").Value = "OK"

-Else

-Range("D55").Value = "NG"

-End If

-End Function

-

-Function test_xlExcel4Wordbook(ByRef num)

-Range("A56").Clear

-Range("B56").Clear

-Range("C56").Clear

-Range("D56").Clear

-Range("A56").Value = "xlExcel4Wordbook"

-Range("B56").Value = 35

-Range("C56").Value = num

-B56 = Range("B56").Value

-C56 = Range("C56").Value

-If B56 = C56 Then

-Range("D56").Value = "OK"

-Else

-Range("D56").Value = "NG"

-End If

-End Function

-

-Function test_xlExcel5(ByRef num)

-Range("A57").Clear

-Range("B57").Clear

-Range("C57").Clear

-Range("D57").Clear

-Range("A57").Value = "xlExcel5"

-Range("B57").Value = 39

-Range("C57").Value = num

-B57 = Range("B57").Value

-C57 = Range("C57").Value

-If B57 = C57 Then

-Range("D57").Value = "OK"

-Else

-Range("D57").Value = "NG"

-End If

-End Function

-

-Function test_xlExcel7(ByRef num)

-Range("A58").Clear

-Range("B58").Clear

-Range("C58").Clear

-Range("D58").Clear

-Range("A58").Value = "xlExcel7"

-Range("B58").Value = 39

-Range("C58").Value = num

-B58 = Range("B58").Value

-C58 = Range("C58").Value

-If B58 = C58 Then

-Range("D58").Value = "OK"

-Else

-Range("D58").Value = "NG"

-End If

-End Function

-

-Function test_xlExcel9795(ByRef num)

-Range("A59").Clear

-Range("B59").Clear

-Range("C59").Clear

-Range("D59").Clear

-Range("A59").Value = "xlExcel9795"

-Range("B59").Value = 43

-Range("C59").Value = num

-B59 = Range("B59").Value

-C59 = Range("C59").Value

-If B59 = C59 Then

-Range("D59").Value = "OK"

-Else

-Range("D59").Value = "NG"

-End If

-End Function

-

-Function test_xlHtml(ByRef num)

-Range("A60").Clear

-Range("B60").Clear

-Range("C60").Clear

-Range("D60").Clear

-Range("A60").Value = "xlHtml"

-Range("B60").Value = 44

-Range("C60").Value = num

-B60 = Range("B60").Value

-C60 = Range("C60").Value

-If B60 = C60 Then

-Range("D60").Value = "OK"

-Else

-Range("D60").Value = "NG"

-End If

-End Function

-

-Function test_xlIntlAddIn(ByRef num)

-Range("A61").Clear

-Range("B61").Clear

-Range("C61").Clear

-Range("D61").Clear

-Range("A61").Value = "xlIntlAddIn"

-Range("B61").Value = 26

-Range("C61").Value = num

-B61 = Range("B61").Value

-C61 = Range("C61").Value

-If B61 = C61 Then

-Range("D61").Value = "OK"

-Else

-Range("D61").Value = "NG"

-End If

-End Function

-

-Function test_xlIntlMacro(ByRef num)

-Range("A62").Clear

-Range("B62").Clear

-Range("C62").Clear

-Range("D62").Clear

-Range("A62").Value = "xlIntlMacro"

-Range("B62").Value = 25

-Range("C62").Value = num

-B62 = Range("B62").Value

-C62 = Range("C62").Value

-If B62 = C62 Then

-Range("D62").Value = "OK"

-Else

-Range("D62").Value = "NG"

-End If

-End Function

-

-Function test_xlSYLK(ByRef num)

-Range("A63").Clear

-Range("B63").Clear

-Range("C63").Clear

-Range("D63").Clear

-Range("A63").Value = "xlSYLK"

-Range("B63").Value = 2

-Range("C63").Value = num

-B63 = Range("B63").Value

-C63 = Range("C63").Value

-If B63 = C63 Then

-Range("D63").Value = "OK"

-Else

-Range("D63").Value = "NG"

-End If

-End Function

-

-Function test_xlTemplate(ByRef num)

-Range("A64").Clear

-Range("B64").Clear

-Range("C64").Clear

-Range("D64").Clear

-Range("A64").Value = "xlTemplate"

-Range("B64").Value = 17

-Range("C64").Value = num

-B64 = Range("B64").Value

-C64 = Range("C64").Value

-If B64 = C64 Then

-Range("D64").Value = "OK"

-Else

-Range("D64").Value = "NG"

-End If

-End Function

-

-Function test_xlTextMac(ByRef num)

-Range("A65").Clear

-Range("B65").Clear

-Range("C65").Clear

-Range("D65").Clear

-Range("A65").Value = "xlTextMac"

-Range("B65").Value = 19

-Range("C65").Value = num

-B65 = Range("B65").Value

-C65 = Range("C65").Value

-If B65 = C65 Then

-Range("D65").Value = "OK"

-Else

-Range("D65").Value = "NG"

-End If

-End Function

-

-Function test_xlTextMSDOS(ByRef num)

-Range("A66").Clear

-Range("B66").Clear

-Range("C66").Clear

-Range("D66").Clear

-Range("A66").Value = "xlTextMSDOS"

-Range("B66").Value = 21

-Range("C66").Value = num

-B66 = Range("B66").Value

-C66 = Range("C66").Value

-If B66 = C66 Then

-Range("D66").Value = "OK"

-Else

-Range("D66").Value = "NG"

-End If

-End Function

-

-Function test_xlTextPrinter(ByRef num)

-Range("A67").Clear

-Range("B67").Clear

-Range("C67").Clear

-Range("D67").Clear

-Range("A67").Value = "xlTextPrinter"

-Range("B67").Value = 36

-Range("C67").Value = num

-B67 = Range("B67").Value

-C67 = Range("C67").Value

-If B67 = C67 Then

-Range("D67").Value = "OK"

-Else

-Range("D67").Value = "NG"

-End If

-End Function

-

-Function test_xlTextWindows(ByRef num)

-Range("A68").Clear

-Range("B68").Clear

-Range("C68").Clear

-Range("D68").Clear

-Range("A68").Value = "xlTextWindows"

-Range("B68").Value = 20

-Range("C68").Value = num

-B68 = Range("B68").Value

-C68 = Range("C68").Value

-If B68 = C68 Then

-Range("D68").Value = "OK"

-Else

-Range("D68").Value = "NG"

-End If

-End Function

-

-Function test_xlUnicodeText(ByRef num)

-Range("A69").Clear

-Range("B69").Clear

-Range("C69").Clear

-Range("D69").Clear

-Range("A69").Value = "xlUnicodeText"

-Range("B69").Value = 42

-Range("C69").Value = num

-B69 = Range("B69").Value

-C69 = Range("C69").Value

-If B69 = C69 Then

-Range("D69").Value = "OK"

-Else

-Range("D69").Value = "NG"

-End If

-End Function

-

-Function test_xlWebArchive(ByRef num)

-Range("A70").Clear

-Range("B70").Clear

-Range("C70").Clear

-Range("D70").Clear

-Range("A70").Value = "xlWebArchive"

-Range("B70").Value = 45

-Range("C70").Value = num

-B70 = Range("B70").Value

-C70 = Range("C70").Value

-If B70 = C70 Then

-Range("D70").Value = "OK"

-Else

-Range("D70").Value = "NG"

-End If

-End Function

-

-Function test_xlWJ2WD1(ByRef num)

-Range("A71").Clear

-Range("B71").Clear

-Range("C71").Clear

-Range("D71").Clear

-Range("A71").Value = "xlWJ2WD1"

-Range("B71").Value = 14

-Range("C71").Value = num

-B71 = Range("B71").Value

-C71 = Range("C71").Value

-If B71 = C71 Then

-Range("D71").Value = "OK"

-Else

-Range("D71").Value = "NG"

-End If

-End Function

-

-Function test_xlWJ3(ByRef num)

-Range("A72").Clear

-Range("B72").Clear

-Range("C72").Clear

-Range("D72").Clear

-Range("A72").Value = "xlWJ3"

-Range("B72").Value = 40

-Range("C72").Value = num

-B72 = Range("B72").Value

-C72 = Range("C72").Value

-If B72 = C72 Then

-Range("D72").Value = "OK"

-Else

-Range("D72").Value = "NG"

-End If

-End Function

-

-Function test_xlWJ3FJ3(ByRef num)

-Range("A73").Clear

-Range("B73").Clear

-Range("C73").Clear

-Range("D73").Clear

-Range("A73").Value = "xlWJ3FJ3"

-Range("B73").Value = 41

-Range("C73").Value = num

-B73 = Range("B73").Value

-C73 = Range("C73").Value

-If B73 = C73 Then

-Range("D73").Value = "OK"

-Else

-Range("D73").Value = "NG"

-End If

-End Function

-

-Function test_xlWK1(ByRef num)

-Range("A74").Clear

-Range("B74").Clear

-Range("C74").Clear

-Range("D74").Clear

-Range("A74").Value = "xlWK1"

-Range("B74").Value = 5

-Range("C74").Value = num

-B74 = Range("B74").Value

-C74 = Range("C74").Value

-If B74 = C74 Then

-Range("D74").Value = "OK"

-Else

-Range("D74").Value = "NG"

-End If

-End Function

-

-Function test_xlWK1ALL(ByRef num)

-Range("A75").Clear

-Range("B75").Clear

-Range("C75").Clear

-Range("D75").Clear

-Range("A75").Value = "xlWK1ALL"

-Range("B75").Value = 31

-Range("C75").Value = num

-B75 = Range("B75").Value

-C75 = Range("C75").Value

-If B75 = C75 Then

-Range("D75").Value = "OK"

-Else

-Range("D75").Value = "NG"

-End If

-End Function

-

-Function test_xlWK1FMT(ByRef num)

-Range("A76").Clear

-Range("B76").Clear

-Range("C76").Clear

-Range("D76").Clear

-Range("A76").Value = "xlWK1FMT"

-Range("B76").Value = 30

-Range("C76").Value = num

-B76 = Range("B76").Value

-C76 = Range("C76").Value

-If B76 = C76 Then

-Range("D76").Value = "OK"

-Else

-Range("D76").Value = "NG"

-End If

-End Function

-

-Function test_xlWK3(ByRef num)

-Range("A77").Clear

-Range("B77").Clear

-Range("C77").Clear

-Range("D77").Clear

-Range("A77").Value = "xlWK3"

-Range("B77").Value = 15

-Range("C77").Value = num

-B77 = Range("B77").Value

-C77 = Range("C77").Value

-If B77 = C77 Then

-Range("D77").Value = "OK"

-Else

-Range("D77").Value = "NG"

-End If

-End Function

-

-Function test_xlWK3FM3(ByRef num)

-Range("A78").Clear

-Range("B78").Clear

-Range("C78").Clear

-Range("D78").Clear

-Range("A78").Value = "xlWK3FM3"

-Range("B78").Value = 32

-Range("C78").Value = num

-B78 = Range("B78").Value

-C78 = Range("C78").Value

-If B78 = C78 Then

-Range("D78").Value = "OK"

-Else

-Range("D78").Value = "NG"

-End If

-End Function

-

-Function test_xlWK4(ByRef num)

-Range("A79").Clear

-Range("B79").Clear

-Range("C79").Clear

-Range("D79").Clear

-Range("A79").Value = "xlWK4"

-Range("B79").Value = 38

-Range("C79").Value = num

-B79 = Range("B79").Value

-C79 = Range("C79").Value

-If B79 = C79 Then

-Range("D79").Value = "OK"

-Else

-Range("D79").Value = "NG"

-End If

-End Function

-

-Function test_xlWKS(ByRef num)

-Range("A80").Clear

-Range("B80").Clear

-Range("C80").Clear

-Range("D80").Clear

-Range("A80").Value = "xlWKS"

-Range("B80").Value = 4

-Range("C80").Value = num

-B80 = Range("B80").Value

-C80 = Range("C80").Value

-If B80 = C80 Then

-Range("D80").Value = "OK"

-Else

-Range("D80").Value = "NG"

-End If

-End Function

-

-Function test_xlWordbookNormal(ByRef num)

-Range("A81").Clear

-Range("B81").Clear

-Range("C81").Clear

-Range("D81").Clear

-Range("A81").Value = "xlWordbookNormal"

-Range("B81").Value = -4143

-Range("C81").Value = num

-B81 = Range("B81").Value

-C81 = Range("C81").Value

-If B81 = C81 Then

-Range("D81").Value = "OK"

-Else

-Range("D81").Value = "NG"

-End If

-End Function

-

-Function test_xlWords2FarEast(ByRef num)

-Range("A82").Clear

-Range("B82").Clear

-Range("C82").Clear

-Range("D82").Clear

-Range("A82").Value = "xlWords2FarEast"

-Range("B82").Value = 28

-Range("C82").Value = num

-B82 = Range("B82").Value

-C82 = Range("C82").Value

-If B82 = C82 Then

-Range("D82").Value = "OK"

-Else

-Range("D82").Value = "NG"

-End If

-End Function

-

-Function test_xlWQ1(ByRef num)

-Range("A83").Clear

-Range("B83").Clear

-Range("C83").Clear

-Range("D83").Clear

-Range("A83").Value = "xlWQ1"

-Range("B83").Value = 34

-Range("C83").Value = num

-B83 = Range("B83").Value

-C83 = Range("C83").Value

-If B83 = C83 Then

-Range("D83").Value = "OK"

-Else

-Range("D83").Value = "NG"

-End If

-End Function

-

-Function test_xlXMLSpredsheet(ByRef num)

-Range("A84").Clear

-Range("B84").Clear

-Range("C84").Clear

-Range("D84").Clear

-Range("A84").Value = "xlXMLSpredsheet"

-Range("B84").Value = 46

-Range("C84").Value = num

-B84 = Range("B84").Value

-C84 = Range("C84").Value

-If B84 = C84 Then

-Range("D84").Value = "OK"

-Else

-Range("D84").Value = "NG"

-End If

-End Function

-

-Function test_xlFillWithAll(ByRef num)

-Range("A85").Clear

-Range("B85").Clear

-Range("C85").Clear

-Range("D85").Clear

-Range("A85").Value = "xlFillWithAll"

-Range("B85").Value = -4104

-Range("C85").Value = num

-B85 = Range("B85").Value

-C85 = Range("C85").Value

-If B85 = C85 Then

-Range("D85").Value = "OK"

-Else

-Range("D85").Value = "NG"

-End If

-End Function

-

-Function test_xlFillWithContents(ByRef num)

-Range("A86").Clear

-Range("B86").Clear

-Range("C86").Clear

-Range("D86").Clear

-Range("A86").Value = "xlFillWithContents"

-Range("B86").Value = 2

-Range("C86").Value = num

-B86 = Range("B86").Value

-C86 = Range("C86").Value

-If B86 = C86 Then

-Range("D86").Value = "OK"

-Else

-Range("D86").Value = "NG"

-End If

-End Function

-

-Function test_xlFillWithFormats(ByRef num)

-Range("A87").Clear

-Range("B87").Clear

-Range("C87").Clear

-Range("D87").Clear

-Range("A87").Value = "xlFillWithFormats"

-Range("B87").Value = -4122

-Range("C87").Value = num

-B87 = Range("B87").Value

-C87 = Range("C87").Value

-If B87 = C87 Then

-Range("D87").Value = "OK"

-Else

-Range("D87").Value = "NG"

-End If

-End Function

-

-Function test_xlFilterCopy(ByRef num)

-Range("A88").Clear

-Range("B88").Clear

-Range("C88").Clear

-Range("D88").Clear

-Range("A88").Value = "xlFilterCopy"

-Range("B88").Value = 2

-Range("C88").Value = num

-B88 = Range("B88").Value

-C88 = Range("C88").Value

-If B88 = C88 Then

-Range("D88").Value = "OK"

-Else

-Range("D88").Value = "NG"

-End If

-End Function

-

-Function test_xlFilterInPlace(ByRef num)

-Range("A89").Clear

-Range("B89").Clear

-Range("C89").Clear

-Range("D89").Clear

-Range("A89").Value = "xlFilterInPlace"

-Range("B89").Value = 1

-Range("C89").Value = num

-B89 = Range("B89").Value

-C89 = Range("C89").Value

-If B89 = C89 Then

-Range("D89").Value = "OK"

-Else

-Range("D89").Value = "NG"

-End If

-End Function

-

-Function test_xlComments(ByRef num)

-Range("A90").Clear

-Range("B90").Clear

-Range("C90").Clear

-Range("D90").Clear

-Range("A90").Value = "xlComments"

-Range("B90").Value = -4144

-Range("C90").Value = num

-B90 = Range("B90").Value

-C90 = Range("C90").Value

-If B90 = C90 Then

-Range("D90").Value = "OK"

-Else

-Range("D90").Value = "NG"

-End If

-End Function

-

-Function test_xlFormulas(ByRef num)

-Range("A91").Clear

-Range("B91").Clear

-Range("C91").Clear

-Range("D91").Clear

-Range("A91").Value = "xlFormulas"

-Range("B91").Value = -4123

-Range("C91").Value = num

-B91 = Range("B91").Value

-C91 = Range("C91").Value

-If B91 = C91 Then

-Range("D91").Value = "OK"

-Else

-Range("D91").Value = "NG"

-End If

-End Function

-

-Function test_xlValues(ByRef num)

-Range("A92").Clear

-Range("B92").Clear

-Range("C92").Clear

-Range("D92").Clear

-Range("A92").Value = "xlValues"

-Range("B92").Value = -4163

-Range("C92").Value = num

-B92 = Range("B92").Value

-C92 = Range("C92").Value

-If B92 = C92 Then

-Range("D92").Value = "OK"

-Else

-Range("D92").Value = "NG"

-End If

-End Function

-

-Function test_xlButtonControl(ByRef num)

-Range("A93").Clear

-Range("B93").Clear

-Range("C93").Clear

-Range("D93").Clear

-Range("A93").Value = "xlButtonControl"

-Range("B93").Value = 0

-Range("C93").Value = num

-B93 = Range("B93").Value

-C93 = Range("C93").Value

-If B93 = C93 Then

-Range("D93").Value = "OK"

-Else

-Range("D93").Value = "NG"

-End If

-End Function

-

-Function test_xlCheckBox(ByRef num)

-Range("A94").Clear

-Range("B94").Clear

-Range("C94").Clear

-Range("D94").Clear

-Range("A94").Value = "xlCheckBox"

-Range("B94").Value = 1

-Range("C94").Value = num

-B94 = Range("B94").Value

-C94 = Range("C94").Value

-If B94 = C94 Then

-Range("D94").Value = "OK"

-Else

-Range("D94").Value = "NG"

-End If

-End Function

-

-Function test_xlDropDown(ByRef num)

-Range("A95").Clear

-Range("B95").Clear

-Range("C95").Clear

-Range("D95").Clear

-Range("A95").Value = "xlDropDown"

-Range("B95").Value = 2

-Range("C95").Value = num

-B95 = Range("B95").Value

-C95 = Range("C95").Value

-If B95 = C95 Then

-Range("D95").Value = "OK"

-Else

-Range("D95").Value = "NG"

-End If

-End Function

-

-Function test_xlEditBox(ByRef num)

-Range("A96").Clear

-Range("B96").Clear

-Range("C96").Clear

-Range("D96").Clear

-Range("A96").Value = "xlEditBox"

-Range("B96").Value = 3

-Range("C96").Value = num

-B96 = Range("B96").Value

-C96 = Range("C96").Value

-If B96 = C96 Then

-Range("D96").Value = "OK"

-Else

-Range("D96").Value = "NG"

-End If

-End Function

-

-Function test_xlGroupBox(ByRef num)

-Range("A97").Clear

-Range("B97").Clear

-Range("C97").Clear

-Range("D97").Clear

-Range("A97").Value = "xlGroupBox"

-Range("B97").Value = 4

-Range("C97").Value = num

-B97 = Range("B97").Value

-C97 = Range("C97").Value

-If B97 = C97 Then

-Range("D97").Value = "OK"

-Else

-Range("D97").Value = "NG"

-End If

-End Function

-

-Function test_xlLabel(ByRef num)

-Range("A98").Clear

-Range("B98").Clear

-Range("C98").Clear

-Range("D98").Clear

-Range("A98").Value = "xlLabel"

-Range("B98").Value = 5

-Range("C98").Value = num

-B98 = Range("B98").Value

-C98 = Range("C98").Value

-If B98 = C98 Then

-Range("D98").Value = "OK"

-Else

-Range("D98").Value = "NG"

-End If

-End Function

-

-Function test_xlListBox(ByRef num)

-Range("A99").Clear

-Range("B99").Clear

-Range("C99").Clear

-Range("D99").Clear

-Range("A99").Value = "xlListBox"

-Range("B99").Value = 6

-Range("C99").Value = num

-B99 = Range("B99").Value

-C99 = Range("C99").Value

-If B99 = C99 Then

-Range("D99").Value = "OK"

-Else

-Range("D99").Value = "NG"

-End If

-End Function

-

-Function test_xlOptionButton(ByRef num)

-Range("A100").Clear

-Range("B100").Clear

-Range("C100").Clear

-Range("D100").Clear

-Range("A100").Value = "xlOptionButton"

-Range("B100").Value = 7

-Range("C100").Value = num

-B100 = Range("B100").Value

-C100 = Range("C100").Value

-If B100 = C100 Then

-Range("D100").Value = "OK"

-Else

-Range("D100").Value = "NG"

-End If

-End Function

-

-Function test_xlSchollBar(ByRef num)

-Range("A101").Clear

-Range("B101").Clear

-Range("C101").Clear

-Range("D101").Clear

-Range("A101").Value = "xlSchollBar"

-Range("B101").Value = 8

-Range("C101").Value = num

-B101 = Range("B101").Value

-C101 = Range("C101").Value

-If B101 = C101 Then

-Range("D101").Value = "OK"

-Else

-Range("D101").Value = "NG"

-End If

-End Function

-

-Function test_xlSpinner(ByRef num)

-Range("A102").Clear

-Range("B102").Clear

-Range("C102").Clear

-Range("D102").Clear

-Range("A102").Value = "xlSpinner"

-Range("B102").Value = 9

-Range("C102").Value = num

-B102 = Range("B102").Value

-C102 = Range("C102").Value

-If B102 = C102 Then

-Range("D102").Value = "OK"

-Else

-Range("D102").Value = "NG"

-End If

-End Function

-

-Function test_xlBetween(ByRef num)

-Range("A103").Clear

-Range("B103").Clear

-Range("C103").Clear

-Range("D103").Clear

-Range("A103").Value = "xlBetween"

-Range("B103").Value = 1

-Range("C103").Value = num

-B103 = Range("B103").Value

-C103 = Range("C103").Value

-If B103 = C103 Then

-Range("D103").Value = "OK"

-Else

-Range("D103").Value = "NG"

-End If

-End Function

-

-Function test_xlEqual(ByRef num)

-Range("A104").Clear

-Range("B104").Clear

-Range("C104").Clear

-Range("D104").Clear

-Range("A104").Value = "xlEqual"

-Range("B104").Value = 3

-Range("C104").Value = num

-B104 = Range("B104").Value

-C104 = Range("C104").Value

-If B104 = C104 Then

-Range("D104").Value = "OK"

-Else

-Range("D104").Value = "NG"

-End If

-End Function

-

-Function test_xlGreater(ByRef num)

-Range("A105").Clear

-Range("B105").Clear

-Range("C105").Clear

-Range("D105").Clear

-Range("A105").Value = "xlGreater"

-Range("B105").Value = 5

-Range("C105").Value = num

-B105 = Range("B105").Value

-C105 = Range("C105").Value

-If B105 = C105 Then

-Range("D105").Value = "OK"

-Else

-Range("D105").Value = "NG"

-End If

-End Function

-

-Function test_xlGreaterEqual(ByRef num)

-Range("A106").Clear

-Range("B106").Clear

-Range("C106").Clear

-Range("D106").Clear

-Range("A106").Value = "xlGreaterEqual"

-Range("B106").Value = 7

-Range("C106").Value = num

-B106 = Range("B106").Value

-C106 = Range("C106").Value

-If B106 = C106 Then

-Range("D106").Value = "OK"

-Else

-Range("D106").Value = "NG"

-End If

-End Function

-

-Function test_xlLess(ByRef num)

-Range("A107").Clear

-Range("B107").Clear

-Range("C107").Clear

-Range("D107").Clear

-Range("A107").Value = "xlLess"

-Range("B107").Value = 6

-Range("C107").Value = num

-B107 = Range("B107").Value

-C107 = Range("C107").Value

-If B107 = C107 Then

-Range("D107").Value = "OK"

-Else

-Range("D107").Value = "NG"

-End If

-End Function

-

-Function test_xlLessEqual(ByRef num)

-Range("A108").Clear

-Range("B108").Clear

-Range("C108").Clear

-Range("D108").Clear

-Range("A108").Value = "xlLessEqual"

-Range("B108").Value = 8

-Range("C108").Value = num

-B108 = Range("B108").Value

-C108 = Range("C108").Value

-If B108 = C108 Then

-Range("D108").Value = "OK"

-Else

-Range("D108").Value = "NG"

-End If

-End Function

-

-Function test_xlNotBetween(ByRef num)

-Range("A109").Clear

-Range("B109").Clear

-Range("C109").Clear

-Range("D109").Clear

-Range("A109").Value = "xlNotBetween"

-Range("B109").Value = 2

-Range("C109").Value = num

-B109 = Range("B109").Value

-C109 = Range("C109").Value

-If B109 = C109 Then

-Range("D109").Value = "OK"

-Else

-Range("D109").Value = "NG"

-End If

-End Function

-

-Function test_xlNotEqual(ByRef num)

-Range("A110").Clear

-Range("B110").Clear

-Range("C110").Clear

-Range("D110").Clear

-Range("A110").Value = "xlNotEqual"

-Range("B110").Value = 4

-Range("C110").Value = num

-B110 = Range("B110").Value

-C110 = Range("C110").Value

-If B110 = C110 Then

-Range("D110").Value = "OK"

-Else

-Range("D110").Value = "NG"

-End If

-End Function

-

-Function test_xlCellValue(ByRef num)

-Range("A111").Clear

-Range("B111").Clear

-Range("C111").Clear

-Range("D111").Clear

-Range("A111").Value = "xlCellValue"

-Range("B111").Value = 1

-Range("C111").Value = num

-B111 = Range("B111").Value

-C111 = Range("C111").Value

-If B111 = C111 Then

-Range("D111").Value = "OK"

-Else

-Range("D111").Value = "NG"

-End If

-End Function

-

-Function test_xlExpression(ByRef num)

-Range("A112").Clear

-Range("B112").Clear

-Range("C112").Clear

-Range("D112").Clear

-Range("A112").Value = "xlExpression"

-Range("B112").Value = 2

-Range("C112").Value = num

-B112 = Range("B112").Value

-C112 = Range("C112").Value

-If B112 = C112 Then

-Range("D112").Value = "OK"

-Else

-Range("D112").Value = "NG"

-End If

-End Function

-

-Function test_xlColumnLabels(ByRef num)

-Range("A113").Clear

-Range("B113").Clear

-Range("C113").Clear

-Range("D113").Clear

-Range("A113").Value = "xlColumnLabels"

-Range("B113").Value = 2

-Range("C113").Value = num

-B113 = Range("B113").Value

-C113 = Range("C113").Value

-If B113 = C113 Then

-Range("D113").Value = "OK"

-Else

-Range("D113").Value = "NG"

-End If

-End Function

-

-Function test_xlMixedLabels(ByRef num)

-Range("A114").Clear

-Range("B114").Clear

-Range("C114").Clear

-Range("D114").Clear

-Range("A114").Value = "xlMixedLabels"

-Range("B114").Value = 3

-Range("C114").Value = num

-B114 = Range("B114").Value

-C114 = Range("C114").Value

-If B114 = C114 Then

-Range("D114").Value = "OK"

-Else

-Range("D114").Value = "NG"

-End If

-End Function

-

-Function test_xlNoLabels(ByRef num)

-Range("A115").Clear

-Range("B115").Clear

-Range("C115").Clear

-Range("D115").Clear

-Range("A115").Value = "xlNoLabels"

-Range("B115").Value = -4142

-Range("C115").Value = num

-B115 = Range("B115").Value

-C115 = Range("C115").Value

-If B115 = C115 Then

-Range("D115").Value = "OK"

-Else

-Range("D115").Value = "NG"

-End If

-End Function

-

-Function test_xlRowLabels(ByRef num)

-Range("A116").Clear

-Range("B116").Clear

-Range("C116").Clear

-Range("D116").Clear

-Range("A116").Value = "xlRowLabels"

-Range("B116").Value = 1

-Range("C116").Value = num

-B116 = Range("B116").Value

-C116 = Range("C116").Value

-If B116 = C116 Then

-Range("D116").Value = "OK"

-Else

-Range("D116").Value = "NG"

-End If

-End Function

-

-Function test_xlHAlignCenter(ByRef num)

-Range("A117").Clear

-Range("B117").Clear

-Range("C117").Clear

-Range("D117").Clear

-Range("A117").Value = "xlHAlignCenter"

-Range("B117").Value = -4108

-Range("C117").Value = num

-B117 = Range("B117").Value

-C117 = Range("C117").Value

-If B117 = C117 Then

-Range("D117").Value = "OK"

-Else

-Range("D117").Value = "NG"

-End If

-End Function

-

-Function test_xlHAlignCenterAcrossSelection(ByRef num)

-Range("A118").Clear

-Range("B118").Clear

-Range("C118").Clear

-Range("D118").Clear

-Range("A118").Value = "xlHAlignCenterAcrossSelection"

-Range("B118").Value = 7

-Range("C118").Value = num

-B118 = Range("B118").Value

-C118 = Range("C118").Value

-If B118 = C118 Then

-Range("D118").Value = "OK"

-Else

-Range("D118").Value = "NG"

-End If

-End Function

-

-Function test_xlHAlignDistributed(ByRef num)

-Range("A119").Clear

-Range("B119").Clear

-Range("C119").Clear

-Range("D119").Clear

-Range("A119").Value = "xlHAlignDistributed"

-Range("B119").Value = -4117

-Range("C119").Value = num

-B119 = Range("B119").Value

-C119 = Range("C119").Value

-If B119 = C119 Then

-Range("D119").Value = "OK"

-Else

-Range("D119").Value = "NG"

-End If

-End Function

-

-Function test_xlHAlignFull(ByRef num)

-Range("A120").Clear

-Range("B120").Clear

-Range("C120").Clear

-Range("D120").Clear

-Range("A120").Value = "xlHAlignFull"

-Range("B120").Value = 5

-Range("C120").Value = num

-B120 = Range("B120").Value

-C120 = Range("C120").Value

-If B120 = C120 Then

-Range("D120").Value = "OK"

-Else

-Range("D120").Value = "NG"

-End If

-End Function

-

-Function test_xlHAlignGeneral(ByRef num)

-Range("A121").Clear

-Range("B121").Clear

-Range("C121").Clear

-Range("D121").Clear

-Range("A121").Value = "xlHAlignGeneral"

-Range("B121").Value = 1

-Range("C121").Value = num

-B121 = Range("B121").Value

-C121 = Range("C121").Value

-If B121 = C121 Then

-Range("D121").Value = "OK"

-Else

-Range("D121").Value = "NG"

-End If

-End Function

-

-Function test_xlHAlignJustify(ByRef num)

-Range("A122").Clear

-Range("B122").Clear

-Range("C122").Clear

-Range("D122").Clear

-Range("A122").Value = "xlHAlignJustify"

-Range("B122").Value = -4130

-Range("C122").Value = num

-B122 = Range("B122").Value

-C122 = Range("C122").Value

-If B122 = C122 Then

-Range("D122").Value = "OK"

-Else

-Range("D122").Value = "NG"

-End If

-End Function

-

-Function test_xlHAlignLeft(ByRef num)

-Range("A123").Clear

-Range("B123").Clear

-Range("C123").Clear

-Range("D123").Clear

-Range("A123").Value = "xlHAlignLeft"

-Range("B123").Value = -4131

-Range("C123").Value = num

-B123 = Range("B123").Value

-C123 = Range("C123").Value

-If B123 = C123 Then

-Range("D123").Value = "OK"

-Else

-Range("D123").Value = "NG"

-End If

-End Function

-

-Function test_xlHAlignRight(ByRef num)

-Range("A124").Clear

-Range("B124").Clear

-Range("C124").Clear

-Range("D124").Clear

-Range("A124").Value = "xlHAlignRight"

-Range("B124").Value = -4152

-Range("C124").Value = num

-B124 = Range("B124").Value

-C124 = Range("C124").Value

-If B124 = C124 Then

-Range("D124").Value = "OK"

-Else

-Range("D124").Value = "NG"

-End If

-End Function

-

-Function test_xlHebrewFullScript(ByRef num)

-Range("A125").Clear

-Range("B125").Clear

-Range("C125").Clear

-Range("D125").Clear

-Range("A125").Value = "xlHebrewFullScript"

-Range("B125").Value = 0

-Range("C125").Value = num

-B125 = Range("B125").Value

-C125 = Range("C125").Value

-If B125 = C125 Then

-Range("D125").Value = "OK"

-Else

-Range("D125").Value = "NG"

-End If

-End Function

-

-Function test_xlHebrewMixedAuthorizedScript(ByRef num)

-Range("A126").Clear

-Range("B126").Clear

-Range("C126").Clear

-Range("D126").Clear

-Range("A126").Value = "xlHebrewMixedAuthorizedScript"

-Range("B126").Value = 3

-Range("C126").Value = num

-B126 = Range("B126").Value

-C126 = Range("C126").Value

-If B126 = C126 Then

-Range("D126").Value = "OK"

-Else

-Range("D126").Value = "NG"

-End If

-End Function

-

-Function test_xlHebrewMixedScript(ByRef num)

-Range("A127").Clear

-Range("B127").Clear

-Range("C127").Clear

-Range("D127").Clear

-Range("A127").Value = "xlHebrewMixedScript"

-Range("B127").Value = 2

-Range("C127").Value = num

-B127 = Range("B127").Value

-C127 = Range("C127").Value

-If B127 = C127 Then

-Range("D127").Value = "OK"

-Else

-Range("D127").Value = "NG"

-End If

-End Function

-

-Function test_xlHebrewPartialScript(ByRef num)

-Range("A128").Clear

-Range("B128").Clear

-Range("C128").Clear

-Range("D128").Clear

-Range("A128").Value = "xlHebrewPartialScript"

-Range("B128").Value = 1

-Range("C128").Value = num

-B128 = Range("B128").Value

-C128 = Range("C128").Value

-If B128 = C128 Then

-Range("D128").Value = "OK"

-Else

-Range("D128").Value = "NG"

-End If

-End Function

-

-Function test_xlAllChanges(ByRef num)

-Range("A129").Clear

-Range("B129").Clear

-Range("C129").Clear

-Range("D129").Clear

-Range("A129").Value = "xlAllChanges"

-Range("B129").Value = 2

-Range("C129").Value = num

-B129 = Range("B129").Value

-C129 = Range("C129").Value

-If B129 = C129 Then

-Range("D129").Value = "OK"

-Else

-Range("D129").Value = "NG"

-End If

-End Function

-

-Function test_xlNotYetReviewed(ByRef num)

-Range("A130").Clear

-Range("B130").Clear

-Range("C130").Clear

-Range("D130").Clear

-Range("A130").Value = "xlNotYetReviewed"

-Range("B130").Value = 3

-Range("C130").Value = num

-B130 = Range("B130").Value

-C130 = Range("C130").Value

-If B130 = C130 Then

-Range("D130").Value = "OK"

-Else

-Range("D130").Value = "NG"

-End If

-End Function

-

-Function test_xlSinceMyLastSave(ByRef num)

-Range("A131").Clear

-Range("B131").Clear

-Range("C131").Clear

-Range("D131").Clear

-Range("A131").Value = "xlSinceMyLastSave"

-Range("B131").Value = 1

-Range("C131").Value = num

-B131 = Range("B131").Value

-C131 = Range("C131").Value

-If B131 = C131 Then

-Range("D131").Value = "OK"

-Else

-Range("D131").Value = "NG"

-End If

-End Function

-

-Function test_xlHtmlCalc(ByRef num)

-Range("A132").Clear

-Range("B132").Clear

-Range("C132").Clear

-Range("D132").Clear

-Range("A132").Value = "xlHtmlCalc"

-Range("B132").Value = 1

-Range("C132").Value = num

-B132 = Range("B132").Value

-C132 = Range("C132").Value

-If B132 = C132 Then

-Range("D132").Value = "OK"

-Else

-Range("D132").Value = "NG"

-End If

-End Function

-

-Function test_xlHtmlChart(ByRef num)

-Range("A133").Clear

-Range("B133").Clear

-Range("C133").Clear

-Range("D133").Clear

-Range("A133").Value = "xlHtmlChart"

-Range("B133").Value = 3

-Range("C133").Value = num

-B133 = Range("B133").Value

-C133 = Range("C133").Value

-If B133 = C133 Then

-Range("D133").Value = "OK"

-Else

-Range("D133").Value = "NG"

-End If

-End Function

-

-Function test_xlHtmlList(ByRef num)

-Range("A134").Clear

-Range("B134").Clear

-Range("C134").Clear

-Range("D134").Clear

-Range("A134").Value = "xlHtmlList"

-Range("B134").Value = 2

-Range("C134").Value = num

-B134 = Range("B134").Value

-C134 = Range("C134").Value

-If B134 = C134 Then

-Range("D134").Value = "OK"

-Else

-Range("D134").Value = "NG"

-End If

-End Function

-

-Function test_xlHtmlStatic(ByRef num)

-Range("A135").Clear

-Range("B135").Clear

-Range("C135").Clear

-Range("D135").Clear

-Range("A135").Value = "xlHtmlStatic"

-Range("B135").Value = 0

-Range("C135").Value = num

-B135 = Range("B135").Value

-C135 = Range("C135").Value

-If B135 = C135 Then

-Range("D135").Value = "OK"

-Else

-Range("D135").Value = "NG"

-End If

-End Function

-

-Function test_xlIMEModeAlpha(ByRef num)

-Range("A136").Clear

-Range("B136").Clear

-Range("C136").Clear

-Range("D136").Clear

-Range("A136").Value = "xlIMEModeAlpha"

-Range("B136").Value = 8

-Range("C136").Value = num

-B136 = Range("B136").Value

-C136 = Range("C136").Value

-If B136 = C136 Then

-Range("D136").Value = "OK"

-Else

-Range("D136").Value = "NG"

-End If

-End Function

-

-Function test_xlIMEModeAlphaFull(ByRef num)

-Range("A137").Clear

-Range("B137").Clear

-Range("C137").Clear

-Range("D137").Clear

-Range("A137").Value = "xlIMEModeAlphaFull"

-Range("B137").Value = 7

-Range("C137").Value = num

-B137 = Range("B137").Value

-C137 = Range("C137").Value

-If B137 = C137 Then

-Range("D137").Value = "OK"

-Else

-Range("D137").Value = "NG"

-End If

-End Function

-

-Function test_xlIMEModeDisable(ByRef num)

-Range("A138").Clear

-Range("B138").Clear

-Range("C138").Clear

-Range("D138").Clear

-Range("A138").Value = "xlIMEModeDisable"

-Range("B138").Value = 3

-Range("C138").Value = num

-B138 = Range("B138").Value

-C138 = Range("C138").Value

-If B138 = C138 Then

-Range("D138").Value = "OK"

-Else

-Range("D138").Value = "NG"

-End If

-End Function

-

-Function test_xlIMEModeHangul(ByRef num)

-Range("A139").Clear

-Range("B139").Clear

-Range("C139").Clear

-Range("D139").Clear

-Range("A139").Value = "xlIMEModeHangul"

-Range("B139").Value = 10

-Range("C139").Value = num

-B139 = Range("B139").Value

-C139 = Range("C139").Value

-If B139 = C139 Then

-Range("D139").Value = "OK"

-Else

-Range("D139").Value = "NG"

-End If

-End Function

-

-Function test_xlIMEModeHangulFull(ByRef num)

-Range("A140").Clear

-Range("B140").Clear

-Range("C140").Clear

-Range("D140").Clear

-Range("A140").Value = "xlIMEModeHangulFull"

-Range("B140").Value = 9

-Range("C140").Value = num

-B140 = Range("B140").Value

-C140 = Range("C140").Value

-If B140 = C140 Then

-Range("D140").Value = "OK"

-Else

-Range("D140").Value = "NG"

-End If

-End Function

-

-Function test_xlIMEModeHiragana(ByRef num)

-Range("A141").Clear

-Range("B141").Clear

-Range("C141").Clear

-Range("D141").Clear

-Range("A141").Value = "xlIMEModeHiragana"

-Range("B141").Value = 4

-Range("C141").Value = num

-B141 = Range("B141").Value

-C141 = Range("C141").Value

-If B141 = C141 Then

-Range("D141").Value = "OK"

-Else

-Range("D141").Value = "NG"

-End If

-End Function

-

-Function test_xlIMEModeKatakana(ByRef num)

-Range("A142").Clear

-Range("B142").Clear

-Range("C142").Clear

-Range("D142").Clear

-Range("A142").Value = "xlIMEModeKatakana"

-Range("B142").Value = 5

-Range("C142").Value = num

-B142 = Range("B142").Value

-C142 = Range("C142").Value

-If B142 = C142 Then

-Range("D142").Value = "OK"

-Else

-Range("D142").Value = "NG"

-End If

-End Function

-

-Function test_xlIMEModeKatakanaHalf(ByRef num)

-Range("A143").Clear

-Range("B143").Clear

-Range("C143").Clear

-Range("D143").Clear

-Range("A143").Value = "xlIMEModeKatakanaHalf"

-Range("B143").Value = 6

-Range("C143").Value = num

-B143 = Range("B143").Value

-C143 = Range("C143").Value

-If B143 = C143 Then

-Range("D143").Value = "OK"

-Else

-Range("D143").Value = "NG"

-End If

-End Function

-

-Function test_xlIMEModeNoControl(ByRef num)

-Range("A144").Clear

-Range("B144").Clear

-Range("C144").Clear

-Range("D144").Clear

-Range("A144").Value = "xlIMEModeNoControl"

-Range("B144").Value = 0

-Range("C144").Value = num

-B144 = Range("B144").Value

-C144 = Range("C144").Value

-If B144 = C144 Then

-Range("D144").Value = "OK"

-Else

-Range("D144").Value = "NG"

-End If

-End Function

-

-Function test_xlIMEModeOff(ByRef num)

-Range("A145").Clear

-Range("B145").Clear

-Range("C145").Clear

-Range("D145").Clear

-Range("A145").Value = "xlIMEModeOff"

-Range("B145").Value = 2

-Range("C145").Value = num

-B145 = Range("B145").Value

-C145 = Range("C145").Value

-If B145 = C145 Then

-Range("D145").Value = "OK"

-Else

-Range("D145").Value = "NG"

-End If

-End Function

-

-Function test_xlIMEModeOn(ByRef num)

-Range("A146").Clear

-Range("B146").Clear

-Range("C146").Clear

-Range("D146").Clear

-Range("A146").Value = "xlIMEModeOn"

-Range("B146").Value = 1

-Range("C146").Value = num

-B146 = Range("B146").Value

-C146 = Range("C146").Value

-If B146 = C146 Then

-Range("D146").Value = "OK"

-Else

-Range("D146").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotTableReport(ByRef num)

-Range("A147").Clear

-Range("B147").Clear

-Range("C147").Clear

-Range("D147").Clear

-Range("A147").Value = "xlPivotTableReport"

-Range("B147").Value = 1

-Range("C147").Value = num

-B147 = Range("B147").Value

-C147 = Range("C147").Value

-If B147 = C147 Then

-Range("D147").Value = "OK"

-Else

-Range("D147").Value = "NG"

-End If

-End Function

-

-Function test_xlQueryTable(ByRef num)

-Range("A148").Clear

-Range("B148").Clear

-Range("C148").Clear

-Range("D148").Clear

-Range("A148").Value = "xlQueryTable"

-Range("B148").Value = 0

-Range("C148").Value = num

-B148 = Range("B148").Value

-C148 = Range("C148").Value

-If B148 = C148 Then

-Range("D148").Value = "OK"

-Else

-Range("D148").Value = "NG"

-End If

-End Function

-

-Function test_xlFormatFromLeftOrAbove(ByRef num)

-Range("A149").Clear

-Range("B149").Clear

-Range("C149").Clear

-Range("D149").Clear

-Range("A149").Value = "xlFormatFromLeftOrAbove"

-Range("B149").Value = 0

-Range("C149").Value = num

-B149 = Range("B149").Value

-C149 = Range("C149").Value

-If B149 = C149 Then

-Range("D149").Value = "OK"

-Else

-Range("D149").Value = "NG"

-End If

-End Function

-

-Function test_xlFormatFromRightOrAbove(ByRef num)

-Range("A150").Clear

-Range("B150").Clear

-Range("C150").Clear

-Range("D150").Clear

-Range("A150").Value = "xlFormatFromRightOrAbove"

-Range("B150").Value = 1

-Range("C150").Value = num

-B150 = Range("B150").Value

-C150 = Range("C150").Value

-If B150 = C150 Then

-Range("D150").Value = "OK"

-Else

-Range("D150").Value = "NG"

-End If

-End Function

-

-Function test_xlShiftDown(ByRef num)

-Range("A151").Clear

-Range("B151").Clear

-Range("C151").Clear

-Range("D151").Clear

-Range("A151").Value = "xlShiftDown"

-Range("B151").Value = -4121

-Range("C151").Value = num

-B151 = Range("B151").Value

-C151 = Range("C151").Value

-If B151 = C151 Then

-Range("D151").Value = "OK"

-Else

-Range("D151").Value = "NG"

-End If

-End Function

-

-Function test_xlShiftToRight(ByRef num)

-Range("A152").Clear

-Range("B152").Clear

-Range("C152").Clear

-Range("D152").Clear

-Range("A152").Value = "xlShiftToRight"

-Range("B152").Value = -4161

-Range("C152").Value = num

-B152 = Range("B152").Value

-C152 = Range("C152").Value

-If B152 = C152 Then

-Range("D152").Value = "OK"

-Else

-Range("D152").Value = "NG"

-End If

-End Function

-

-Function test_xlOutline(ByRef num)

-Range("A153").Clear

-Range("B153").Clear

-Range("C153").Clear

-Range("D153").Clear

-Range("A153").Value = "xlOutline"

-Range("B153").Value = 1

-Range("C153").Value = num

-B153 = Range("B153").Value

-C153 = Range("C153").Value

-If B153 = C153 Then

-Range("D153").Value = "OK"

-Else

-Range("D153").Value = "NG"

-End If

-End Function

-

-Function test_xlTabular(ByRef num)

-Range("A154").Clear

-Range("B154").Clear

-Range("C154").Clear

-Range("D154").Clear

-Range("A154").Value = "xlTabular"

-Range("B154").Value = 0

-Range("C154").Value = num

-B154 = Range("B154").Value

-C154 = Range("C154").Value

-If B154 = C154 Then

-Range("D154").Value = "OK"

-Else

-Range("D154").Value = "NG"

-End If

-End Function

-

-Function test_xlLegendPositionBottom(ByRef num)

-Range("A155").Clear

-Range("B155").Clear

-Range("C155").Clear

-Range("D155").Clear

-Range("A155").Value = "xlLegendPositionBottom"

-Range("B155").Value = -4107

-Range("C155").Value = num

-B155 = Range("B155").Value

-C155 = Range("C155").Value

-If B155 = C155 Then

-Range("D155").Value = "OK"

-Else

-Range("D155").Value = "NG"

-End If

-End Function

-

-Function test_xlLegendPositionCorner(ByRef num)

-Range("A156").Clear

-Range("B156").Clear

-Range("C156").Clear

-Range("D156").Clear

-Range("A156").Value = "xlLegendPositionCorner"

-Range("B156").Value = 2

-Range("C156").Value = num

-B156 = Range("B156").Value

-C156 = Range("C156").Value

-If B156 = C156 Then

-Range("D156").Value = "OK"

-Else

-Range("D156").Value = "NG"

-End If

-End Function

-

-Function test_xlLegendPositionLeft(ByRef num)

-Range("A157").Clear

-Range("B157").Clear

-Range("C157").Clear

-Range("D157").Clear

-Range("A157").Value = "xlLegendPositionLeft"

-Range("B157").Value = -4131

-Range("C157").Value = num

-B157 = Range("B157").Value

-C157 = Range("C157").Value

-If B157 = C157 Then

-Range("D157").Value = "OK"

-Else

-Range("D157").Value = "NG"

-End If

-End Function

-

-Function test_xlLegendPositionRight(ByRef num)

-Range("A158").Clear

-Range("B158").Clear

-Range("C158").Clear

-Range("D158").Clear

-Range("A158").Value = "xlLegendPositionRight"

-Range("B158").Value = -4152

-Range("C158").Value = num

-B158 = Range("B158").Value

-C158 = Range("C158").Value

-If B158 = C158 Then

-Range("D158").Value = "OK"

-Else

-Range("D158").Value = "NG"

-End If

-End Function

-

-Function test_xlLegendPositionTop(ByRef num)

-Range("A159").Clear

-Range("B159").Clear

-Range("C159").Clear

-Range("D159").Clear

-Range("A159").Value = "xlLegendPositionTop"

-Range("B159").Value = -4160

-Range("C159").Value = num

-B159 = Range("B159").Value

-C159 = Range("C159").Value

-If B159 = C159 Then

-Range("D159").Value = "OK"

-Else

-Range("D159").Value = "NG"

-End If

-End Function

-

-Function test_xlContinuous(ByRef num)

-Range("A160").Clear

-Range("B160").Clear

-Range("C160").Clear

-Range("D160").Clear

-Range("A160").Value = "xlContinuous"

-Range("B160").Value = 1

-Range("C160").Value = num

-B160 = Range("B160").Value

-C160 = Range("C160").Value

-If B160 = C160 Then

-Range("D160").Value = "OK"

-Else

-Range("D160").Value = "NG"

-End If

-End Function

-

-Function test_xlDash(ByRef num)

-Range("A161").Clear

-Range("B161").Clear

-Range("C161").Clear

-Range("D161").Clear

-Range("A161").Value = "xlDash"

-Range("B161").Value = -4115

-Range("C161").Value = num

-B161 = Range("B161").Value

-C161 = Range("C161").Value

-If B161 = C161 Then

-Range("D161").Value = "OK"

-Else

-Range("D161").Value = "NG"

-End If

-End Function

-

-Function test_xlDashDot(ByRef num)

-Range("A162").Clear

-Range("B162").Clear

-Range("C162").Clear

-Range("D162").Clear

-Range("A162").Value = "xlDashDot"

-Range("B162").Value = 4

-Range("C162").Value = num

-B162 = Range("B162").Value

-C162 = Range("C162").Value

-If B162 = C162 Then

-Range("D162").Value = "OK"

-Else

-Range("D162").Value = "NG"

-End If

-End Function

-

-Function test_xlDashDotDot(ByRef num)

-Range("A163").Clear

-Range("B163").Clear

-Range("C163").Clear

-Range("D163").Clear

-Range("A163").Value = "xlDashDotDot"

-Range("B163").Value = 5

-Range("C163").Value = num

-B163 = Range("B163").Value

-C163 = Range("C163").Value

-If B163 = C163 Then

-Range("D163").Value = "OK"

-Else

-Range("D163").Value = "NG"

-End If

-End Function

-

-Function test_xlDot(ByRef num)

-Range("A164").Clear

-Range("B164").Clear

-Range("C164").Clear

-Range("D164").Clear

-Range("A164").Value = "xlDot"

-Range("B164").Value = -4118

-Range("C164").Value = num

-B164 = Range("B164").Value

-C164 = Range("C164").Value

-If B164 = C164 Then

-Range("D164").Value = "OK"

-Else

-Range("D164").Value = "NG"

-End If

-End Function

-

-Function test_xlDouble(ByRef num)

-Range("A165").Clear

-Range("B165").Clear

-Range("C165").Clear

-Range("D165").Clear

-Range("A165").Value = "xlDouble"

-Range("B165").Value = -4119

-Range("C165").Value = num

-B165 = Range("B165").Value

-C165 = Range("C165").Value

-If B165 = C165 Then

-Range("D165").Value = "OK"

-Else

-Range("D165").Value = "NG"

-End If

-End Function

-

-Function test_xlLineStyleNone(ByRef num)

-Range("A166").Clear

-Range("B166").Clear

-Range("C166").Clear

-Range("D166").Clear

-Range("A166").Value = "xlLineStyleNone"

-Range("B166").Value = -4142

-Range("C166").Value = num

-B166 = Range("B166").Value

-C166 = Range("C166").Value

-If B166 = C166 Then

-Range("D166").Value = "OK"

-Else

-Range("D166").Value = "NG"

-End If

-End Function

-

-Function test_xlSlantDashDot(ByRef num)

-Range("A167").Clear

-Range("B167").Clear

-Range("C167").Clear

-Range("D167").Clear

-Range("A167").Value = "xlSlantDashDot"

-Range("B167").Value = 13

-Range("C167").Value = num

-B167 = Range("B167").Value

-C167 = Range("C167").Value

-If B167 = C167 Then

-Range("D167").Value = "OK"

-Else

-Range("D167").Value = "NG"

-End If

-End Function

-

-Function test_xlExcelLink(ByRef num)

-Range("A168").Clear

-Range("B168").Clear

-Range("C168").Clear

-Range("D168").Clear

-Range("A168").Value = "xlExcelLink"

-Range("B168").Value = 1

-Range("C168").Value = num

-B168 = Range("B168").Value

-C168 = Range("C168").Value

-If B168 = C168 Then

-Range("D168").Value = "OK"

-Else

-Range("D168").Value = "NG"

-End If

-End Function

-

-Function test_XlOLELink(ByRef num)

-Range("A169").Clear

-Range("B169").Clear

-Range("C169").Clear

-Range("D169").Clear

-Range("A169").Value = "xlOLELink"

-Range("B169").Value = 2

-Range("C169").Value = num

-B169 = Range("B169").Value

-C169 = Range("C169").Value

-If B169 = C169 Then

-Range("D169").Value = "OK"

-Else

-Range("D169").Value = "NG"

-End If

-End Function

-

-Function test_xlPublishers(ByRef num)

-Range("A170").Clear

-Range("B170").Clear

-Range("C170").Clear

-Range("D170").Clear

-Range("A170").Value = "xlPublishers"

-Range("B170").Value = 5

-Range("C170").Value = num

-B170 = Range("B170").Value

-C170 = Range("C170").Value

-If B170 = C170 Then

-Range("D170").Value = "OK"

-Else

-Range("D170").Value = "NG"

-End If

-End Function

-

-Function test_xlSubscribers(ByRef num)

-Range("A171").Clear

-Range("B171").Clear

-Range("C171").Clear

-Range("D171").Clear

-Range("A171").Value = "xlSubscribers"

-Range("B171").Value = 6

-Range("C171").Value = num

-B171 = Range("B171").Value

-C171 = Range("C171").Value

-If B171 = C171 Then

-Range("D171").Value = "OK"

-Else

-Range("D171").Value = "NG"

-End If

-End Function

-

-Function test_xlEditionDate(ByRef num)

-Range("A172").Clear

-Range("B172").Clear

-Range("C172").Clear

-Range("D172").Clear

-Range("A172").Value = "xlEditionDate"

-Range("B172").Value = 2

-Range("C172").Value = num

-B172 = Range("B172").Value

-C172 = Range("C172").Value

-If B172 = C172 Then

-Range("D172").Value = "OK"

-Else

-Range("D172").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkInfoStatus(ByRef num)

-Range("A173").Clear

-Range("B173").Clear

-Range("C173").Clear

-Range("D173").Clear

-Range("A173").Value = "xlLinkInfoStatus"

-Range("B173").Value = 3

-Range("C173").Value = num

-B173 = Range("B173").Value

-C173 = Range("C173").Value

-If B173 = C173 Then

-Range("D173").Value = "OK"

-Else

-Range("D173").Value = "NG"

-End If

-End Function

-

-Function test_xlUpdateState(ByRef num)

-Range("A174").Clear

-Range("B174").Clear

-Range("C174").Clear

-Range("D174").Clear

-Range("A174").Value = "xlUpdateState"

-Range("B174").Value = 1

-Range("C174").Value = num

-B174 = Range("B174").Value

-C174 = Range("C174").Value

-If B174 = C174 Then

-Range("D174").Value = "OK"

-Else

-Range("D174").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkInfoOLELinks(ByRef num)

-Range("A175").Clear

-Range("B175").Clear

-Range("C175").Clear

-Range("D175").Clear

-Range("A175").Value = "xlLinkInfoOLELinks"

-Range("B175").Value = 2

-Range("C175").Value = num

-B175 = Range("B175").Value

-C175 = Range("C175").Value

-If B175 = C175 Then

-Range("D175").Value = "OK"

-Else

-Range("D175").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkInfoPublishers(ByRef num)

-Range("A176").Clear

-Range("B176").Clear

-Range("C176").Clear

-Range("D176").Clear

-Range("A176").Value = "xlLinkInfoPublishers"

-Range("B176").Value = 5

-Range("C176").Value = num

-B176 = Range("B176").Value

-C176 = Range("C176").Value

-If B176 = C176 Then

-Range("D176").Value = "OK"

-Else

-Range("D176").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkInfoSubscribers(ByRef num)

-Range("A177").Clear

-Range("B177").Clear

-Range("C177").Clear

-Range("D177").Clear

-Range("A177").Value = "xlLinkInfoSubscribers"

-Range("B177").Value = 6

-Range("C177").Value = num

-B177 = Range("B177").Value

-C177 = Range("C177").Value

-If B177 = C177 Then

-Range("D177").Value = "OK"

-Else

-Range("D177").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkStatusCopiedValues(ByRef num)

-Range("A178").Clear

-Range("B178").Clear

-Range("C178").Clear

-Range("D178").Clear

-Range("A178").Value = "xlLinkStatusCopiedValues"

-Range("B178").Value = 10

-Range("C178").Value = num

-B178 = Range("B178").Value

-C178 = Range("C178").Value

-If B178 = C178 Then

-Range("D178").Value = "OK"

-Else

-Range("D178").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkStatusIndeterminate(ByRef num)

-Range("A179").Clear

-Range("B179").Clear

-Range("C179").Clear

-Range("D179").Clear

-Range("A179").Value = "xlLinkStatusIndeterminate"

-Range("B179").Value = 5

-Range("C179").Value = num

-B179 = Range("B179").Value

-C179 = Range("C179").Value

-If B179 = C179 Then

-Range("D179").Value = "OK"

-Else

-Range("D179").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkStatusInvalidName(ByRef num)

-Range("A180").Clear

-Range("B180").Clear

-Range("C180").Clear

-Range("D180").Clear

-Range("A180").Value = "xlLinkStatusInvalidName"

-Range("B180").Value = 7

-Range("C180").Value = num

-B180 = Range("B180").Value

-C180 = Range("C180").Value

-If B180 = C180 Then

-Range("D180").Value = "OK"

-Else

-Range("D180").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkStatusMissingFile(ByRef num)

-Range("A181").Clear

-Range("B181").Clear

-Range("C181").Clear

-Range("D181").Clear

-Range("A181").Value = "xlLinkStatusMissingFile"

-Range("B181").Value = 1

-Range("C181").Value = num

-B181 = Range("B181").Value

-C181 = Range("C181").Value

-If B181 = C181 Then

-Range("D181").Value = "OK"

-Else

-Range("D181").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkStatusMissingSheet(ByRef num)

-Range("A182").Clear

-Range("B182").Clear

-Range("C182").Clear

-Range("D182").Clear

-Range("A182").Value = "xlLinkStatusMissingSheet"

-Range("B182").Value = 2

-Range("C182").Value = num

-B182 = Range("B182").Value

-C182 = Range("C182").Value

-If B182 = C182 Then

-Range("D182").Value = "OK"

-Else

-Range("D182").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkStatusNotStarted(ByRef num)

-Range("A183").Clear

-Range("B183").Clear

-Range("C183").Clear

-Range("D183").Clear

-Range("A183").Value = "xlLinkStatusNotStarted"

-Range("B183").Value = 6

-Range("C183").Value = num

-B183 = Range("B183").Value

-C183 = Range("C183").Value

-If B183 = C183 Then

-Range("D183").Value = "OK"

-Else

-Range("D183").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkStatusOK(ByRef num)

-Range("A184").Clear

-Range("B184").Clear

-Range("C184").Clear

-Range("D184").Clear

-Range("A184").Value = "xlLinkStatusOK"

-Range("B184").Value = 0

-Range("C184").Value = num

-B184 = Range("B184").Value

-C184 = Range("C184").Value

-If B184 = C184 Then

-Range("D184").Value = "OK"

-Else

-Range("D184").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkStatusOld(ByRef num)

-Range("A185").Clear

-Range("B185").Clear

-Range("C185").Clear

-Range("D185").Clear

-Range("A185").Value = "xlLinkStatusOld"

-Range("B185").Value = 3

-Range("C185").Value = num

-B185 = Range("B185").Value

-C185 = Range("C185").Value

-If B185 = C185 Then

-Range("D185").Value = "OK"

-Else

-Range("D185").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkStatusSourceNotCalculated(ByRef num)

-Range("A186").Clear

-Range("B186").Clear

-Range("C186").Clear

-Range("D186").Clear

-Range("A186").Value = "xlLinkStatusSourceNotCalculated"

-Range("B186").Value = 4

-Range("C186").Value = num

-B186 = Range("B186").Value

-C186 = Range("C186").Value

-If B186 = C186 Then

-Range("D186").Value = "OK"

-Else

-Range("D186").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkStatusSourceNotOpen(ByRef num)

-Range("A187").Clear

-Range("B187").Clear

-Range("C187").Clear

-Range("D187").Clear

-Range("A187").Value = "xlLinkStatusSourceNotOpen"

-Range("B187").Value = 8

-Range("C187").Value = num

-B187 = Range("B187").Value

-C187 = Range("C187").Value

-If B187 = C187 Then

-Range("D187").Value = "OK"

-Else

-Range("D187").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkStatusSourceOpen(ByRef num)

-Range("A188").Clear

-Range("B188").Clear

-Range("C188").Clear

-Range("D188").Clear

-Range("A188").Value = "xlLinkStatusSourceOpen"

-Range("B188").Value = 9

-Range("C188").Value = num

-B188 = Range("B188").Value

-C188 = Range("C188").Value

-If B188 = C188 Then

-Range("D188").Value = "OK"

-Else

-Range("D188").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkTypeExcelLinks(ByRef num)

-Range("A189").Clear

-Range("B189").Clear

-Range("C189").Clear

-Range("D189").Clear

-Range("A189").Value = "xlLinkTypeExcelLinks"

-Range("B189").Value = 1

-Range("C189").Value = num

-B189 = Range("B189").Value

-C189 = Range("C189").Value

-If B189 = C189 Then

-Range("D189").Value = "OK"

-Else

-Range("D189").Value = "NG"

-End If

-End Function

-

-Function test_xlLinkTypeOLELinks(ByRef num)

-Range("A190").Clear

-Range("B190").Clear

-Range("C190").Clear

-Range("D190").Clear

-Range("A190").Value = "xlLinkTypeOLELinks"

-Range("B190").Value = 2

-Range("C190").Value = num

-B190 = Range("B190").Value

-C190 = Range("C190").Value

-If B190 = C190 Then

-Range("D190").Value = "OK"

-Else

-Range("D190").Value = "NG"

-End If

-End Function

-

-Function test_xlListConflictDialog(ByRef num)

-Range("A191").Clear

-Range("B191").Clear

-Range("C191").Clear

-Range("D191").Clear

-Range("A191").Value = "xlListConflictDialog"

-Range("B191").Value = 0

-Range("C191").Value = num

-B191 = Range("B191").Value

-C191 = Range("C191").Value

-If B191 = C191 Then

-Range("D191").Value = "OK"

-Else

-Range("D191").Value = "NG"

-End If

-End Function

-

-Function test_xlListConflictDiscardAllConflicts(ByRef num)

-Range("A192").Clear

-Range("B192").Clear

-Range("C192").Clear

-Range("D192").Clear

-Range("A192").Value = "xlListConflictDiscardAllConflicts"

-Range("B192").Value = 2

-Range("C192").Value = num

-B192 = Range("B192").Value

-C192 = Range("C192").Value

-If B192 = C192 Then

-Range("D192").Value = "OK"

-Else

-Range("D192").Value = "NG"

-End If

-End Function

-

-Function test_xlListConflictError(ByRef num)

-Range("A193").Clear

-Range("B193").Clear

-Range("C193").Clear

-Range("D193").Clear

-Range("A193").Value = "xlListConflictError"

-Range("B193").Value = 3

-Range("C193").Value = num

-B193 = Range("B193").Value

-C193 = Range("C193").Value

-If B193 = C193 Then

-Range("D193").Value = "OK"

-Else

-Range("D193").Value = "NG"

-End If

-End Function

-

-Function test_xlListConflictRetryAllConflicts(ByRef num)

-Range("A194").Clear

-Range("B194").Clear

-Range("C194").Clear

-Range("D194").Clear

-Range("A194").Value = "xlListConflictRetryAllConflicts"

-Range("B194").Value = 1

-Range("C194").Value = num

-B194 = Range("B194").Value

-C194 = Range("C194").Value

-If B194 = C194 Then

-Range("D194").Value = "OK"

-Else

-Range("D194").Value = "NG"

-End If

-End Function

-

-Function test_xlListDataTypeCheckbox(ByRef num)

-Range("A195").Clear

-Range("B195").Clear

-Range("C195").Clear

-Range("D195").Clear

-Range("A195").Value = "xlListDataTypeCheckbox"

-Range("B195").Value = 9

-Range("C195").Value = num

-B195 = Range("B195").Value

-C195 = Range("C195").Value

-If B195 = C195 Then

-Range("D195").Value = "OK"

-Else

-Range("D195").Value = "NG"

-End If

-End Function

-

-Function test_xlListDataTypeChoice(ByRef num)

-Range("A196").Clear

-Range("B196").Clear

-Range("C196").Clear

-Range("D196").Clear

-Range("A196").Value = "xlListDataTypeChoice"

-Range("B196").Value = 6

-Range("C196").Value = num

-B196 = Range("B196").Value

-C196 = Range("C196").Value

-If B196 = C196 Then

-Range("D196").Value = "OK"

-Else

-Range("D196").Value = "NG"

-End If

-End Function

-

-Function test_xlListDataTypeChoiceMulti(ByRef num)

-Range("A197").Clear

-Range("B197").Clear

-Range("C197").Clear

-Range("D197").Clear

-Range("A197").Value = "xlListDataTypeChoiceMulti"

-Range("B197").Value = 7

-Range("C197").Value = num

-B197 = Range("B197").Value

-C197 = Range("C197").Value

-If B197 = C197 Then

-Range("D197").Value = "OK"

-Else

-Range("D197").Value = "NG"

-End If

-End Function

-

-Function test_xlListDataTypeCounter(ByRef num)

-Range("A198").Clear

-Range("B198").Clear

-Range("C198").Clear

-Range("D198").Clear

-Range("A198").Value = "xlListDataTypeCounter"

-Range("B198").Value = 11

-Range("C198").Value = num

-B198 = Range("B198").Value

-C198 = Range("C198").Value

-If B198 = C198 Then

-Range("D198").Value = "OK"

-Else

-Range("D198").Value = "NG"

-End If

-End Function

-

-Function test_xlListDataTypeCurrency(ByRef num)

-Range("A199").Clear

-Range("B199").Clear

-Range("C199").Clear

-Range("D199").Clear

-Range("A199").Value = "xlListDataTypeCurrency"

-Range("B199").Value = 4

-Range("C199").Value = num

-B199 = Range("B199").Value

-C199 = Range("C199").Value

-If B199 = C199 Then

-Range("D199").Value = "OK"

-Else

-Range("D199").Value = "NG"

-End If

-End Function

-

-Function test_xlListDataTypeDateTime(ByRef num)

-Range("A200").Clear

-Range("B200").Clear

-Range("C200").Clear

-Range("D200").Clear

-Range("A200").Value = "xlListDataTypeDateTime"

-Range("B200").Value = 5

-Range("C200").Value = num

-B200 = Range("B200").Value

-C200 = Range("C200").Value

-If B200 = C200 Then

-Range("D200").Value = "OK"

-Else

-Range("D200").Value = "NG"

-End If

-End Function

-

-Function test_xlListDataTypeHyperLink(ByRef num)

-Range("A201").Clear

-Range("B201").Clear

-Range("C201").Clear

-Range("D201").Clear

-Range("A201").Value = "xlListDataTypeHyperLink"

-Range("B201").Value = 10

-Range("C201").Value = num

-B201 = Range("B201").Value

-C201 = Range("C201").Value

-If B201 = C201 Then

-Range("D201").Value = "OK"

-Else

-Range("D201").Value = "NG"

-End If

-End Function

-

-Function test_xlListDataTypeListLookup(ByRef num)

-Range("A202").Clear

-Range("B202").Clear

-Range("C202").Clear

-Range("D202").Clear

-Range("A202").Value = "xlListDataTypeListLookup"

-Range("B202").Value = 8

-Range("C202").Value = num

-B202 = Range("B202").Value

-C202 = Range("C202").Value

-If B202 = C202 Then

-Range("D202").Value = "OK"

-Else

-Range("D202").Value = "NG"

-End If

-End Function

-

-Function test_xlListDataTypeMultiLineRichText(ByRef num)

-Range("A203").Clear

-Range("B203").Clear

-Range("C203").Clear

-Range("D203").Clear

-Range("A203").Value = "xlListDataTypeMultiLineRichText"

-Range("B203").Value = 12

-Range("C203").Value = num

-B203 = Range("B203").Value

-C203 = Range("C203").Value

-If B203 = C203 Then

-Range("D203").Value = "OK"

-Else

-Range("D203").Value = "NG"

-End If

-End Function

-

-Function test_xlListDataTypeMultiLineText(ByRef num)

-Range("A204").Clear

-Range("B204").Clear

-Range("C204").Clear

-Range("D204").Clear

-Range("A204").Value = "xlListDataTypeMultiLineText"

-Range("B204").Value = 2

-Range("C204").Value = num

-B204 = Range("B204").Value

-C204 = Range("C204").Value

-If B204 = C204 Then

-Range("D204").Value = "OK"

-Else

-Range("D204").Value = "NG"

-End If

-End Function

-

-Function test_xlListDataTypeNone(ByRef num)

-Range("A205").Clear

-Range("B205").Clear

-Range("C205").Clear

-Range("D205").Clear

-Range("A205").Value = "xlListDataTypeNone"

-Range("B205").Value = 0

-Range("C205").Value = num

-B205 = Range("B205").Value

-C205 = Range("C205").Value

-If B205 = C205 Then

-Range("D205").Value = "OK"

-Else

-Range("D205").Value = "NG"

-End If

-End Function

-

-Function test_xlListDataTypeNumber(ByRef num)

-Range("A206").Clear

-Range("B206").Clear

-Range("C206").Clear

-Range("D206").Clear

-Range("A206").Value = "xlListDataTypeNumber"

-Range("B206").Value = 3

-Range("C206").Value = num

-B206 = Range("B206").Value

-C206 = Range("C206").Value

-If B206 = C206 Then

-Range("D206").Value = "OK"

-Else

-Range("D206").Value = "NG"

-End If

-End Function

-

-Function test_xlListDataTypeText(ByRef num)

-Range("A207").Clear

-Range("B207").Clear

-Range("C207").Clear

-Range("D207").Clear

-Range("A207").Value = "xlListDataTypeText"

-Range("B207").Value = 1

-Range("C207").Value = num

-B207 = Range("B207").Value

-C207 = Range("C207").Value

-If B207 = C207 Then

-Range("D207").Value = "OK"

-Else

-Range("D207").Value = "NG"

-End If

-End Function

-

-Function test_xlSrcExternal(ByRef num)

-Range("A208").Clear

-Range("B208").Clear

-Range("C208").Clear

-Range("D208").Clear

-Range("A208").Value = "xlSrcExternal"

-Range("B208").Value = 0

-Range("C208").Value = num

-B208 = Range("B208").Value

-C208 = Range("C208").Value

-If B208 = C208 Then

-Range("D208").Value = "OK"

-Else

-Range("D208").Value = "NG"

-End If

-End Function

-

-Function test_xlSrcRange(ByRef num)

-Range("A209").Clear

-Range("B209").Clear

-Range("C209").Clear

-Range("D209").Clear

-Range("A209").Value = "xlSrcRange"

-Range("B209").Value = 1

-Range("C209").Value = num

-B209 = Range("B209").Value

-C209 = Range("C209").Value

-If B209 = C209 Then

-Range("D209").Value = "OK"

-Else

-Range("D209").Value = "NG"

-End If

-End Function

-

-Function test_xlSrcXml(ByRef num)

-Range("A210").Clear

-Range("B210").Clear

-Range("C210").Clear

-Range("D210").Clear

-Range("A210").Value = "xlSrcXml"

-Range("B210").Value = 2

-Range("C210").Value = num

-B210 = Range("B210").Value

-C210 = Range("C210").Value

-If B210 = C210 Then

-Range("D210").Value = "OK"

-Else

-Range("D210").Value = "NG"

-End If

-End Function

-

-Function test_xlColumnHeader(ByRef num)

-Range("A211").Clear

-Range("B211").Clear

-Range("C211").Clear

-Range("D211").Clear

-Range("A211").Value = "xlColumnHeader"

-Range("B211").Value = -4110

-Range("C211").Value = num

-B211 = Range("B211").Value

-C211 = Range("C211").Value

-If B211 = C211 Then

-Range("D211").Value = "OK"

-Else

-Range("D211").Value = "NG"

-End If

-End Function

-

-Function test_xlColumnItem(ByRef num)

-Range("A212").Clear

-Range("B212").Clear

-Range("C212").Clear

-Range("D212").Clear

-Range("A212").Value = "xlColumnItem"

-Range("B212").Value = 5

-Range("C212").Value = num

-B212 = Range("B212").Value

-C212 = Range("C212").Value

-If B212 = C212 Then

-Range("D212").Value = "OK"

-Else

-Range("D212").Value = "NG"

-End If

-End Function

-

-Function test_xlDataHeader(ByRef num)

-Range("A213").Clear

-Range("B213").Clear

-Range("C213").Clear

-Range("D213").Clear

-Range("A213").Value = "xlDataHeader"

-Range("B213").Value = 3

-Range("C213").Value = num

-B213 = Range("B213").Value

-C213 = Range("C213").Value

-If B213 = C213 Then

-Range("D213").Value = "OK"

-Else

-Range("D213").Value = "NG"

-End If

-End Function

-

-Function test_xlDataItem(ByRef num)

-Range("A214").Clear

-Range("B214").Clear

-Range("C214").Clear

-Range("D214").Clear

-Range("A214").Value = "xlDataItem"

-Range("B214").Value = 7

-Range("C214").Value = num

-B214 = Range("B214").Value

-C214 = Range("C214").Value

-If B214 = C214 Then

-Range("D214").Value = "OK"

-Else

-Range("D214").Value = "NG"

-End If

-End Function

-

-Function test_xlPageHeader(ByRef num)

-Range("A215").Clear

-Range("B215").Clear

-Range("C215").Clear

-Range("D215").Clear

-Range("A215").Value = "xlPageHeader"

-Range("B215").Value = 2

-Range("C215").Value = num

-B215 = Range("B215").Value

-C215 = Range("C215").Value

-If B215 = C215 Then

-Range("D215").Value = "OK"

-Else

-Range("D215").Value = "NG"

-End If

-End Function

-

-Function test_xlPageItem(ByRef num)

-Range("A216").Clear

-Range("B216").Clear

-Range("C216").Clear

-Range("D216").Clear

-Range("A216").Value = "xlPageItem"

-Range("B216").Value = 6

-Range("C216").Value = num

-B216 = Range("B216").Value

-C216 = Range("C216").Value

-If B216 = C216 Then

-Range("D216").Value = "OK"

-Else

-Range("D216").Value = "NG"

-End If

-End Function

-

-Function test_xlRowHeader(ByRef num)

-Range("A217").Clear

-Range("B217").Clear

-Range("C217").Clear

-Range("D217").Clear

-Range("A217").Value = "xlRowHeader"

-Range("B217").Value = -4153

-Range("C217").Value = num

-B217 = Range("B217").Value

-C217 = Range("C217").Value

-If B217 = C217 Then

-Range("D217").Value = "OK"

-Else

-Range("D217").Value = "NG"

-End If

-End Function

-

-Function test_xlRowItem(ByRef num)

-Range("A218").Clear

-Range("B218").Clear

-Range("C218").Clear

-Range("D218").Clear

-Range("A218").Value = "xlRowItem"

-Range("B218").Value = 4

-Range("C218").Value = num

-B218 = Range("B218").Value

-C218 = Range("C218").Value

-If B218 = C218 Then

-Range("D218").Value = "OK"

-Else

-Range("D218").Value = "NG"

-End If

-End Function

-

-Function test_xlTableBody(ByRef num)

-Range("A219").Clear

-Range("B219").Clear

-Range("C219").Clear

-Range("D219").Clear

-Range("A219").Value = "xlTableBody"

-Range("B219").Value = 8

-Range("C219").Value = num

-B219 = Range("B219").Value

-C219 = Range("C219").Value

-If B219 = C219 Then

-Range("D219").Value = "OK"

-Else

-Range("D219").Value = "NG"

-End If

-End Function

-

-Function test_xlPart(ByRef num)

-Range("A220").Clear

-Range("B220").Clear

-Range("C220").Clear

-Range("D220").Clear

-Range("A220").Value = "xlPart"

-Range("B220").Value = 2

-Range("C220").Value = num

-B220 = Range("B220").Value

-C220 = Range("C220").Value

-If B220 = C220 Then

-Range("D220").Value = "OK"

-Else

-Range("D220").Value = "NG"

-End If

-End Function

-

-Function test_xlWhole(ByRef num)

-Range("A221").Clear

-Range("B221").Clear

-Range("C221").Clear

-Range("D221").Clear

-Range("A221").Value = "xlWhole"

-Range("B221").Value = 1

-Range("C221").Value = num

-B221 = Range("B221").Value

-C221 = Range("C221").Value

-If B221 = C221 Then

-Range("D221").Value = "OK"

-Else

-Range("D221").Value = "NG"

-End If

-End Function

-

-Function test_xlMicrosoftAccess(ByRef num)

-Range("A222").Clear

-Range("B222").Clear

-Range("C222").Clear

-Range("D222").Clear

-Range("A222").Value = "xlMicrosoftAccess"

-Range("B222").Value = 4

-Range("C222").Value = num

-B222 = Range("B222").Value

-C222 = Range("C222").Value

-If B222 = C222 Then

-Range("D222").Value = "OK"

-Else

-Range("D222").Value = "NG"

-End If

-End Function

-

-Function test_xlMicrosoftFoxPro(ByRef num)

-Range("A223").Clear

-Range("B223").Clear

-Range("C223").Clear

-Range("D223").Clear

-Range("A223").Value = "xlMicrosoftFoxPro"

-Range("B223").Value = 5

-Range("C223").Value = num

-B223 = Range("B223").Value

-C223 = Range("C223").Value

-If B223 = C223 Then

-Range("D223").Value = "OK"

-Else

-Range("D223").Value = "NG"

-End If

-End Function

-

-Function test_xlMicrosoftMail(ByRef num)

-Range("A224").Clear

-Range("B224").Clear

-Range("C224").Clear

-Range("D224").Clear

-Range("A224").Value = "xlMicrosoftMail"

-Range("B224").Value = 3

-Range("C224").Value = num

-B224 = Range("B224").Value

-C224 = Range("C224").Value

-If B224 = C224 Then

-Range("D224").Value = "OK"

-Else

-Range("D224").Value = "NG"

-End If

-End Function

-

-Function test_xlMicrosoftPowerPoint(ByRef num)

-Range("A225").Clear

-Range("B225").Clear

-Range("C225").Clear

-Range("D225").Clear

-Range("A225").Value = "xlMicrosoftPowerPoint"

-Range("B225").Value = 2

-Range("C225").Value = num

-B225 = Range("B225").Value

-C225 = Range("C225").Value

-If B225 = C225 Then

-Range("D225").Value = "OK"

-Else

-Range("D225").Value = "NG"

-End If

-End Function

-

-Function test_xlMicrosoftProject(ByRef num)

-Range("A226").Clear

-Range("B226").Clear

-Range("C226").Clear

-Range("D226").Clear

-Range("A226").Value = "xlMicrosoftProject"

-Range("B226").Value = 6

-Range("C226").Value = num

-B226 = Range("B226").Value

-C226 = Range("C226").Value

-If B226 = C226 Then

-Range("D226").Value = "OK"

-Else

-Range("D226").Value = "NG"

-End If

-End Function

-

-Function test_xlMicrosoftSchedulePlus(ByRef num)

-Range("A227").Clear

-Range("B227").Clear

-Range("C227").Clear

-Range("D227").Clear

-Range("A227").Value = "xlMicrosoftSchedulePlus"

-Range("B227").Value = 7

-Range("C227").Value = num

-B227 = Range("B227").Value

-C227 = Range("C227").Value

-If B227 = C227 Then

-Range("D227").Value = "OK"

-Else

-Range("D227").Value = "NG"

-End If

-End Function

-

-Function test_xlMicrosoftWord(ByRef num)

-Range("A228").Clear

-Range("B228").Clear

-Range("C228").Clear

-Range("D228").Clear

-Range("A228").Value = "xlMicrosoftWord"

-Range("B228").Value = 1

-Range("C228").Value = num

-B228 = Range("B228").Value

-C228 = Range("C228").Value

-If B228 = C228 Then

-Range("D228").Value = "OK"

-Else

-Range("D228").Value = "NG"

-End If

-End Function

-

-Function test_xlMAPI(ByRef num)

-Range("A229").Clear

-Range("B229").Clear

-Range("C229").Clear

-Range("D229").Clear

-Range("A229").Value = "xlMAPI"

-Range("B229").Value = 1

-Range("C229").Value = num

-B229 = Range("B229").Value

-C229 = Range("C229").Value

-If B229 = C229 Then

-Range("D229").Value = "OK"

-Else

-Range("D229").Value = "NG"

-End If

-End Function

-

-Function test_xlNoMailSystem(ByRef num)

-Range("A230").Clear

-Range("B230").Clear

-Range("C230").Clear

-Range("D230").Clear

-Range("A230").Value = "xlNoMailSystem"

-Range("B230").Value = 0

-Range("C230").Value = num

-B230 = Range("B230").Value

-C230 = Range("C230").Value

-If B230 = C230 Then

-Range("D230").Value = "OK"

-Else

-Range("D230").Value = "NG"

-End If

-End Function

-

-Function test_xlPowerTalk(ByRef num)

-Range("A231").Clear

-Range("B231").Clear

-Range("C231").Clear

-Range("D231").Clear

-Range("A231").Value = "xlPowerTalk"

-Range("B231").Value = 2

-Range("C231").Value = num

-B231 = Range("B231").Value

-C231 = Range("C231").Value

-If B231 = C231 Then

-Range("D231").Value = "OK"

-Else

-Range("D231").Value = "NG"

-End If

-End Function

-

-Function test_xlMarkerStyleAutomatic(ByRef num)

-Range("A232").Clear

-Range("B232").Clear

-Range("C232").Clear

-Range("D232").Clear

-Range("A232").Value = "xlMarkerStyleAutomatic"

-Range("B232").Value = -4105

-Range("C232").Value = num

-B232 = Range("B232").Value

-C232 = Range("C232").Value

-If B232 = C232 Then

-Range("D232").Value = "OK"

-Else

-Range("D232").Value = "NG"

-End If

-End Function

-

-Function test_xlMarkerStyleCircle(ByRef num)

-Range("A233").Clear

-Range("B233").Clear

-Range("C233").Clear

-Range("D233").Clear

-Range("A233").Value = "xlMarkerStyleCircle"

-Range("B233").Value = 8

-Range("C233").Value = num

-B233 = Range("B233").Value

-C233 = Range("C233").Value

-If B233 = C233 Then

-Range("D233").Value = "OK"

-Else

-Range("D233").Value = "NG"

-End If

-End Function

-

-Function test_xlMarkerStyleDash(ByRef num)

-Range("A234").Clear

-Range("B234").Clear

-Range("C234").Clear

-Range("D234").Clear

-Range("A234").Value = "xlMarkerStyleDash"

-Range("B234").Value = -4115

-Range("C234").Value = num

-B234 = Range("B234").Value

-C234 = Range("C234").Value

-If B234 = C234 Then

-Range("D234").Value = "OK"

-Else

-Range("D234").Value = "NG"

-End If

-End Function

-

-Function test_xlMarkerStyleDiamond(ByRef num)

-Range("A235").Clear

-Range("B235").Clear

-Range("C235").Clear

-Range("D235").Clear

-Range("A235").Value = "xlMarkerStyleDiamond"

-Range("B235").Value = 2

-Range("C235").Value = num

-B235 = Range("B235").Value

-C235 = Range("C235").Value

-If B235 = C235 Then

-Range("D235").Value = "OK"

-Else

-Range("D235").Value = "NG"

-End If

-End Function

-

-Function test_xlMarkerStyleDot(ByRef num)

-Range("A236").Clear

-Range("B236").Clear

-Range("C236").Clear

-Range("D236").Clear

-Range("A236").Value = "xlMarkerStyleDot"

-Range("B236").Value = -4118

-Range("C236").Value = num

-B236 = Range("B236").Value

-C236 = Range("C236").Value

-If B236 = C236 Then

-Range("D236").Value = "OK"

-Else

-Range("D236").Value = "NG"

-End If

-End Function

-

-Function test_xlMarkerStyleNone(ByRef num)

-Range("A237").Clear

-Range("B237").Clear

-Range("C237").Clear

-Range("D237").Clear

-Range("A237").Value = "xlMarkerStyleNone"

-Range("B237").Value = -4142

-Range("C237").Value = num

-B237 = Range("B237").Value

-C237 = Range("C237").Value

-If B237 = C237 Then

-Range("D237").Value = "OK"

-Else

-Range("D237").Value = "NG"

-End If

-End Function

-

-Function test_xlMarkerStylePicture(ByRef num)

-Range("A238").Clear

-Range("B238").Clear

-Range("C238").Clear

-Range("D238").Clear

-Range("A238").Value = "xlMarkerStylePicture"

-Range("B238").Value = -4147

-Range("C238").Value = num

-B238 = Range("B238").Value

-C238 = Range("C238").Value

-If B238 = C238 Then

-Range("D238").Value = "OK"

-Else

-Range("D238").Value = "NG"

-End If

-End Function

-

-Function test_xlMarkerStylePlus(ByRef num)

-Range("A239").Clear

-Range("B239").Clear

-Range("C239").Clear

-Range("D239").Clear

-Range("A239").Value = "xlMarkerStylePlus"

-Range("B239").Value = 9

-Range("C239").Value = num

-B239 = Range("B239").Value

-C239 = Range("C239").Value

-If B239 = C239 Then

-Range("D239").Value = "OK"

-Else

-Range("D239").Value = "NG"

-End If

-End Function

-

-Function test_xlMarkerStyleSquare(ByRef num)

-Range("A240").Clear

-Range("B240").Clear

-Range("C240").Clear

-Range("D240").Clear

-Range("A240").Value = "xlMarkerStyleSquare"

-Range("B240").Value = 1

-Range("C240").Value = num

-B240 = Range("B240").Value

-C240 = Range("C240").Value

-If B240 = C240 Then

-Range("D240").Value = "OK"

-Else

-Range("D240").Value = "NG"

-End If

-End Function

-

-Function test_xlMarkerStyleStar(ByRef num)

-Range("A241").Clear

-Range("B241").Clear

-Range("C241").Clear

-Range("D241").Clear

-Range("A241").Value = "xlMarkerStyleStar"

-Range("B241").Value = 5

-Range("C241").Value = num

-B241 = Range("B241").Value

-C241 = Range("C241").Value

-If B241 = C241 Then

-Range("D241").Value = "OK"

-Else

-Range("D241").Value = "NG"

-End If

-End Function

-

-Function test_xlMarkerStyleTiangle(ByRef num)

-Range("A242").Clear

-Range("B242").Clear

-Range("C242").Clear

-Range("D242").Clear

-Range("A242").Value = "xlMarkerStyleTiangle"

-Range("B242").Value = 3

-Range("C242").Value = num

-B242 = Range("B242").Value

-C242 = Range("C242").Value

-If B242 = C242 Then

-Range("D242").Value = "OK"

-Else

-Range("D242").Value = "NG"

-End If

-End Function

-

-Function test_xlMarkerStyleX(ByRef num)

-Range("A243").Clear

-Range("B243").Clear

-Range("C243").Clear

-Range("D243").Clear

-Range("A243").Value = "xlMarkerStyleX"

-Range("B243").Value = -4168

-Range("C243").Value = num

-B243 = Range("B243").Value

-C243 = Range("C243").Value

-If B243 = C243 Then

-Range("D243").Value = "OK"

-Else

-Range("D243").Value = "NG"

-End If

-End Function

-

-Function test_xlNoButton(ByRef num)

-Range("A244").Clear

-Range("B244").Clear

-Range("C244").Clear

-Range("D244").Clear

-Range("A244").Value = "xlNoButton"

-Range("B244").Value = 0

-Range("C244").Value = num

-B244 = Range("B244").Value

-C244 = Range("C244").Value

-If B244 = C244 Then

-Range("D244").Value = "OK"

-Else

-Range("D244").Value = "NG"

-End If

-End Function

-

-Function test_xlPrimaryButton(ByRef num)

-Range("A245").Clear

-Range("B245").Clear

-Range("C245").Clear

-Range("D245").Clear

-Range("A245").Value = "xlPrimaryButton"

-Range("B245").Value = 1

-Range("C245").Value = num

-B245 = Range("B245").Value

-C245 = Range("C245").Value

-If B245 = C245 Then

-Range("D245").Value = "OK"

-Else

-Range("D245").Value = "NG"

-End If

-End Function

-

-Function test_xlSecondaryButton(ByRef num)

-Range("A246").Clear

-Range("B246").Clear

-Range("C246").Clear

-Range("D246").Clear

-Range("A246").Value = "xlSecondaryButton"

-Range("B246").Value = 2

-Range("C246").Value = num

-B246 = Range("B246").Value

-C246 = Range("C246").Value

-If B246 = C246 Then

-Range("D246").Value = "OK"

-Else

-Range("D246").Value = "NG"

-End If

-End Function

-

-Function test_xlDefault(ByRef num)

-Range("A247").Clear

-Range("B247").Clear

-Range("C247").Clear

-Range("D247").Clear

-Range("A247").Value = "xlDefault"

-Range("B247").Value = -4143

-Range("C247").Value = num

-B247 = Range("B247").Value

-C247 = Range("C247").Value

-If B247 = C247 Then

-Range("D247").Value = "OK"

-Else

-Range("D247").Value = "NG"

-End If

-End Function

-

-Function test_xlIBeam(ByRef num)

-Range("A248").Clear

-Range("B248").Clear

-Range("C248").Clear

-Range("D248").Clear

-Range("A248").Value = "xlIBeam"

-Range("B248").Value = 3

-Range("C248").Value = num

-B248 = Range("B248").Value

-C248 = Range("C248").Value

-If B248 = C248 Then

-Range("D248").Value = "OK"

-Else

-Range("D248").Value = "NG"

-End If

-End Function

-

-Function test_xlNorthwestArrow(ByRef num)

-Range("A249").Clear

-Range("B249").Clear

-Range("C249").Clear

-Range("D249").Clear

-Range("A249").Value = "xlNorthwestArrow"

-Range("B249").Value = 1

-Range("C249").Value = num

-B249 = Range("B249").Value

-C249 = Range("C249").Value

-If B249 = C249 Then

-Range("D249").Value = "OK"

-Else

-Range("D249").Value = "NG"

-End If

-End Function

-

-Function test_xlWait(ByRef num)

-Range("A250").Clear

-Range("B250").Clear

-Range("C250").Clear

-Range("D250").Clear

-Range("A250").Value = "xlWait"

-Range("B250").Value = 2

-Range("C250").Value = num

-B250 = Range("B250").Value

-C250 = Range("C250").Value

-If B250 = C250 Then

-Range("D250").Value = "OK"

-Else

-Range("D250").Value = "NG"

-End If

-End Function

-

-Function test_XlOLEControl(ByRef num)

-Range("A251").Clear

-Range("B251").Clear

-Range("C251").Clear

-Range("D251").Clear

-Range("A251").Value = "XlOLEControl"

-Range("B251").Value = 2

-Range("C251").Value = num

-B251 = Range("B251").Value

-C251 = Range("C251").Value

-If B251 = C251 Then

-Range("D251").Value = "OK"

-Else

-Range("D251").Value = "NG"

-End If

-End Function

-

-Function test_XlOLEEmbed(ByRef num)

-Range("A252").Clear

-Range("B252").Clear

-Range("C252").Clear

-Range("D252").Clear

-Range("A252").Value = "XlOLEEmbed"

-Range("B252").Value = 1

-Range("C252").Value = num

-B252 = Range("B252").Value

-C252 = Range("C252").Value

-If B252 = C252 Then

-Range("D252").Value = "OK"

-Else

-Range("D252").Value = "NG"

-End If

-End Function

-

-

-

-Function test_XlVerbOpen(ByRef num)

-Range("A254").Clear

-Range("B254").Clear

-Range("C254").Clear

-Range("D254").Clear

-Range("A254").Value = "XlVerbOpen"

-Range("B254").Value = 2

-Range("C254").Value = num

-B254 = Range("B254").Value

-C254 = Range("C254").Value

-If B254 = C254 Then

-Range("D254").Value = "OK"

-Else

-Range("D254").Value = "NG"

-End If

-End Function

-

-Function test_XlVerbPrimary(ByRef num)

-Range("A255").Clear

-Range("B255").Clear

-Range("C255").Clear

-Range("D255").Clear

-Range("A255").Value = "XlVerbPrimary"

-Range("B255").Value = 1

-Range("C255").Value = num

-B255 = Range("B255").Value

-C255 = Range("C255").Value

-If B255 = C255 Then

-Range("D255").Value = "OK"

-Else

-Range("D255").Value = "NG"

-End If

-End Function

-

-Function test_xlFitToPage(ByRef num)

-Range("A256").Clear

-Range("B256").Clear

-Range("C256").Clear

-Range("D256").Clear

-Range("A256").Value = "xlFitToPage"

-Range("B256").Value = 2

-Range("C256").Value = num

-B256 = Range("B256").Value

-C256 = Range("C256").Value

-If B256 = C256 Then

-Range("D256").Value = "OK"

-Else

-Range("D256").Value = "NG"

-End If

-End Function

-

-Function test_xlFullPage(ByRef num)

-Range("A257").Clear

-Range("B257").Clear

-Range("C257").Clear

-Range("D257").Clear

-Range("A257").Value = "xlFullPage"

-Range("B257").Value = 3

-Range("C257").Value = num

-B257 = Range("B257").Value

-C257 = Range("C257").Value

-If B257 = C257 Then

-Range("D257").Value = "OK"

-Else

-Range("D257").Value = "NG"

-End If

-End Function

-

-Function test_xlScreenSize(ByRef num)

-Range("A258").Clear

-Range("B258").Clear

-Range("C258").Clear

-Range("D258").Clear

-Range("A258").Value = "xlScreenSize"

-Range("B258").Value = 1

-Range("C258").Value = num

-B258 = Range("B258").Value

-C258 = Range("C258").Value

-If B258 = C258 Then

-Range("D258").Value = "OK"

-Else

-Range("D258").Value = "NG"

-End If

-End Function

-

-Function test_xlDownThenOver(ByRef num)

-Range("A259").Clear

-Range("B259").Clear

-Range("C259").Clear

-Range("D259").Clear

-Range("A259").Value = "xlDownThenOver"

-Range("B259").Value = 1

-Range("C259").Value = num

-B259 = Range("B259").Value

-C259 = Range("C259").Value

-If B259 = C259 Then

-Range("D259").Value = "OK"

-Else

-Range("D259").Value = "NG"

-End If

-End Function

-

-Function test_xlOverThenDown(ByRef num)

-Range("A260").Clear

-Range("B260").Clear

-Range("C260").Clear

-Range("D260").Clear

-Range("A260").Value = "xlOverThenDown"

-Range("B260").Value = 2

-Range("C260").Value = num

-B260 = Range("B260").Value

-C260 = Range("C260").Value

-If B260 = C260 Then

-Range("D260").Value = "OK"

-Else

-Range("D260").Value = "NG"

-End If

-End Function

-

-Function test_xlDownward(ByRef num)

-Range("A261").Clear

-Range("B261").Clear

-Range("C261").Clear

-Range("D261").Clear

-Range("A261").Value = "xlDownward"

-Range("B261").Value = -4170

-Range("C261").Value = num

-B261 = Range("B261").Value

-C261 = Range("C261").Value

-If B261 = C261 Then

-Range("D261").Value = "OK"

-Else

-Range("D261").Value = "NG"

-End If

-End Function

-

-Function test_xlHorizontal(ByRef num)

-Range("A262").Clear

-Range("B262").Clear

-Range("C262").Clear

-Range("D262").Clear

-Range("A262").Value = "xlHorizontal"

-Range("B262").Value = -4128

-Range("C262").Value = num

-B262 = Range("B262").Value

-C262 = Range("C262").Value

-If B262 = C262 Then

-Range("D262").Value = "OK"

-Else

-Range("D262").Value = "NG"

-End If

-End Function

-

-Function test_xlUpward(ByRef num)

-Range("A263").Clear

-Range("B263").Clear

-Range("C263").Clear

-Range("D263").Clear

-Range("A263").Value = "xlUpward"

-Range("B263").Value = -4171

-Range("C263").Value = num

-B263 = Range("B263").Value

-C263 = Range("C263").Value

-If B263 = C263 Then

-Range("D263").Value = "OK"

-Else

-Range("D263").Value = "NG"

-End If

-End Function

-

-Function test_xlVertical(ByRef num)

-Range("A264").Clear

-Range("B264").Clear

-Range("C264").Clear

-Range("D264").Clear

-Range("A264").Value = "xlVertical"

-Range("B264").Value = -4166

-Range("C264").Value = num

-B264 = Range("B264").Value

-C264 = Range("C264").Value

-If B264 = C264 Then

-Range("D264").Value = "OK"

-Else

-Range("D264").Value = "NG"

-End If

-End Function

-

-Function test_xlBlanks(ByRef num)

-Range("A265").Clear

-Range("B265").Clear

-Range("C265").Clear

-Range("D265").Clear

-Range("A265").Value = "xlBlanks"

-Range("B265").Value = 4

-Range("C265").Value = num

-B265 = Range("B265").Value

-C265 = Range("C265").Value

-If B265 = C265 Then

-Range("D265").Value = "OK"

-Else

-Range("D265").Value = "NG"

-End If

-End Function

-

-Function test_xlButton(ByRef num)

-Range("A266").Clear

-Range("B266").Clear

-Range("C266").Clear

-Range("D266").Clear

-Range("A266").Value = "xlButton"

-Range("B266").Value = 15

-Range("C266").Value = num

-B266 = Range("B266").Value

-C266 = Range("C266").Value

-If B266 = C266 Then

-Range("D266").Value = "OK"

-Else

-Range("D266").Value = "NG"

-End If

-End Function

-

-Function test_xlDataAndLabel(ByRef num)

-Range("A267").Clear

-Range("B267").Clear

-Range("C267").Clear

-Range("D267").Clear

-Range("A267").Value = "xlDataAndLabel"

-Range("B267").Value = 0

-Range("C267").Value = num

-B267 = Range("B267").Value

-C267 = Range("C267").Value

-If B267 = C267 Then

-Range("D267").Value = "OK"

-Else

-Range("D267").Value = "NG"

-End If

-End Function

-

-Function test_xlDataOnly(ByRef num)

-Range("A268").Clear

-Range("B268").Clear

-Range("C268").Clear

-Range("D268").Clear

-Range("A268").Value = "xlDataOnly"

-Range("B268").Value = 2

-Range("C268").Value = num

-B268 = Range("B268").Value

-C268 = Range("C268").Value

-If B268 = C268 Then

-Range("D268").Value = "OK"

-Else

-Range("D268").Value = "NG"

-End If

-End Function

-

-Function test_xlFirstRow(ByRef num)

-Range("A269").Clear

-Range("B269").Clear

-Range("C269").Clear

-Range("D269").Clear

-Range("A269").Value = "xlFirstRow"

-Range("B269").Value = 256

-Range("C269").Value = num

-B269 = Range("B269").Value

-C269 = Range("C269").Value

-If B269 = C269 Then

-Range("D269").Value = "OK"

-Else

-Range("D269").Value = "NG"

-End If

-End Function

-

-Function test_xlLabelOnly(ByRef num)

-Range("A270").Clear

-Range("B270").Clear

-Range("C270").Clear

-Range("D270").Clear

-Range("A270").Value = "xlLabelOnly"

-Range("B270").Value = 1

-Range("C270").Value = num

-B270 = Range("B270").Value

-C270 = Range("C270").Value

-If B270 = C270 Then

-Range("D270").Value = "OK"

-Else

-Range("D270").Value = "NG"

-End If

-End Function

-

-Function test_xlOrigin(ByRef num)

-Range("A271").Clear

-Range("B271").Clear

-Range("C271").Clear

-Range("D271").Clear

-Range("A271").Value = "xlOrigin"

-Range("B271").Value = 3

-Range("C271").Value = num

-B271 = Range("B271").Value

-C271 = Range("C271").Value

-If B271 = C271 Then

-Range("D271").Value = "OK"

-Else

-Range("D271").Value = "NG"

-End If

-End Function

-

-Function test_XlPageBreakAutomatic(ByRef num)

-Range("A272").Clear

-Range("B272").Clear

-Range("C272").Clear

-Range("D272").Clear

-Range("A272").Value = "XlPageBreakAutomatic"

-Range("B272").Value = -4105

-Range("C272").Value = num

-B272 = Range("B272").Value

-C272 = Range("C272").Value

-If B272 = C272 Then

-Range("D272").Value = "OK"

-Else

-Range("D272").Value = "NG"

-End If

-End Function

-

-Function test_XlPageBreakManual(ByRef num)

-Range("A273").Clear

-Range("B273").Clear

-Range("C273").Clear

-Range("D273").Clear

-Range("A273").Value = "XlPageBreakManual"

-Range("B273").Value = -4135

-Range("C273").Value = num

-B273 = Range("B273").Value

-C273 = Range("C273").Value

-If B273 = C273 Then

-Range("D273").Value = "OK"

-Else

-Range("D273").Value = "NG"

-End If

-End Function

-

-Function test_XlPageBreakNone(ByRef num)

-Range("A274").Clear

-Range("B274").Clear

-Range("C274").Clear

-Range("D274").Clear

-Range("A274").Value = "XlPageBreakNone"

-Range("B274").Value = -4142

-Range("C274").Value = num

-B274 = Range("B274").Value

-C274 = Range("C274").Value

-If B274 = C274 Then

-Range("D274").Value = "OK"

-Else

-Range("D274").Value = "NG"

-End If

-End Function

-

-Function test_xlPageBreakFull(ByRef num)

-Range("A275").Clear

-Range("B275").Clear

-Range("C275").Clear

-Range("D275").Clear

-Range("A275").Value = "xlPageBreakFull"

-Range("B275").Value = 1

-Range("C275").Value = num

-B275 = Range("B275").Value

-C275 = Range("C275").Value

-If B275 = C275 Then

-Range("D275").Value = "OK"

-Else

-Range("D275").Value = "NG"

-End If

-End Function

-

-Function test_xlPageBreakPartial(ByRef num)

-Range("A276").Clear

-Range("B276").Clear

-Range("C276").Clear

-Range("D276").Clear

-Range("A276").Value = "xlPageBreakPartial"

-Range("B276").Value = 2

-Range("C276").Value = num

-B276 = Range("B276").Value

-C276 = Range("C276").Value

-If B276 = C276 Then

-Range("D276").Value = "OK"

-Else

-Range("D276").Value = "NG"

-End If

-End Function

-

-Function test_xlLandscape(ByRef num)

-Range("A277").Clear

-Range("B277").Clear

-Range("C277").Clear

-Range("D277").Clear

-Range("A277").Value = "xlLandscape"

-Range("B277").Value = 2

-Range("C277").Value = num

-B277 = Range("B277").Value

-C277 = Range("C277").Value

-If B277 = C277 Then

-Range("D277").Value = "OK"

-Else

-Range("D277").Value = "NG"

-End If

-End Function

-

-Function test_xlPortrait(ByRef num)

-Range("A278").Clear

-Range("B278").Clear

-Range("C278").Clear

-Range("D278").Clear

-Range("A278").Value = "xlPortrait"

-Range("B278").Value = 1

-Range("C278").Value = num

-B278 = Range("B278").Value

-C278 = Range("C278").Value

-If B278 = C278 Then

-Range("D278").Value = "OK"

-Else

-Range("D278").Value = "NG"

-End If

-End Function

-

-Function test_xlPaper10x14(ByRef num)

-Range("A279").Clear

-Range("B279").Clear

-Range("C279").Clear

-Range("D279").Clear

-Range("A279").Value = "xlPaper10x14"

-Range("B279").Value = 16

-Range("C279").Value = num

-B279 = Range("B279").Value

-C279 = Range("C279").Value

-If B279 = C279 Then

-Range("D279").Value = "OK"

-Else

-Range("D279").Value = "NG"

-End If

-End Function

-

-Function test_xlPaper11x17(ByRef num)

-Range("A280").Clear

-Range("B280").Clear

-Range("C280").Clear

-Range("D280").Clear

-Range("A280").Value = "xlPaper11x17"

-Range("B280").Value = 17

-Range("C280").Value = num

-B280 = Range("B280").Value

-C280 = Range("C280").Value

-If B280 = C280 Then

-Range("D280").Value = "OK"

-Else

-Range("D280").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperA3(ByRef num)

-Range("A281").Clear

-Range("B281").Clear

-Range("C281").Clear

-Range("D281").Clear

-Range("A281").Value = "xlPaperA3"

-Range("B281").Value = 8

-Range("C281").Value = num

-B281 = Range("B281").Value

-C281 = Range("C281").Value

-If B281 = C281 Then

-Range("D281").Value = "OK"

-Else

-Range("D281").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperA4Small(ByRef num)

-Range("A282").Clear

-Range("B282").Clear

-Range("C282").Clear

-Range("D282").Clear

-Range("A282").Value = "xlPaperA4Small"

-Range("B282").Value = 9

-Range("C282").Value = num

-B282 = Range("B282").Value

-C282 = Range("C282").Value

-If B282 = C282 Then

-Range("D282").Value = "OK"

-Else

-Range("D282").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperA5(ByRef num)

-Range("A283").Clear

-Range("B283").Clear

-Range("C283").Clear

-Range("D283").Clear

-Range("A283").Value = "xlPaperA5"

-Range("B283").Value = 10

-Range("C283").Value = num

-B283 = Range("B283").Value

-C283 = Range("C283").Value

-If B283 = C283 Then

-Range("D283").Value = "OK"

-Else

-Range("D283").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperB4(ByRef num)

-Range("A284").Clear

-Range("B284").Clear

-Range("C284").Clear

-Range("D284").Clear

-Range("A284").Value = "xlPaperB4"

-Range("B284").Value = 12

-Range("C284").Value = num

-B284 = Range("B284").Value

-C284 = Range("C284").Value

-If B284 = C284 Then

-Range("D284").Value = "OK"

-Else

-Range("D284").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperB5(ByRef num)

-Range("A285").Clear

-Range("B285").Clear

-Range("C285").Clear

-Range("D285").Clear

-Range("A285").Value = "xlPaperB5"

-Range("B285").Value = 13

-Range("C285").Value = num

-B285 = Range("B285").Value

-C285 = Range("C285").Value

-If B285 = C285 Then

-Range("D285").Value = "OK"

-Else

-Range("D285").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperCsheet(ByRef num)

-Range("A286").Clear

-Range("B286").Clear

-Range("C286").Clear

-Range("D286").Clear

-Range("A286").Value = "xlPaperCsheet"

-Range("B286").Value = 24

-Range("C286").Value = num

-B286 = Range("B286").Value

-C286 = Range("C286").Value

-If B286 = C286 Then

-Range("D286").Value = "OK"

-Else

-Range("D286").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperDsheet(ByRef num)

-Range("A287").Clear

-Range("B287").Clear

-Range("C287").Clear

-Range("D287").Clear

-Range("A287").Value = "xlPaperDsheet"

-Range("B287").Value = 25

-Range("C287").Value = num

-B287 = Range("B287").Value

-C287 = Range("C287").Value

-If B287 = C287 Then

-Range("D287").Value = "OK"

-Else

-Range("D287").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelope10(ByRef num)

-Range("A288").Clear

-Range("B288").Clear

-Range("C288").Clear

-Range("D288").Clear

-Range("A288").Value = "xlPaperEnvelope10"

-Range("B288").Value = 20

-Range("C288").Value = num

-B288 = Range("B288").Value

-C288 = Range("C288").Value

-If B288 = C288 Then

-Range("D288").Value = "OK"

-Else

-Range("D288").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelope11(ByRef num)

-Range("A289").Clear

-Range("B289").Clear

-Range("C289").Clear

-Range("D289").Clear

-Range("A289").Value = "xlPaperEnvelope11"

-Range("B289").Value = 21

-Range("C289").Value = num

-B289 = Range("B289").Value

-C289 = Range("C289").Value

-If B289 = C289 Then

-Range("D289").Value = "OK"

-Else

-Range("D289").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelope12(ByRef num)

-Range("A290").Clear

-Range("B290").Clear

-Range("C290").Clear

-Range("D290").Clear

-Range("A290").Value = "xlPaperEnvelope12"

-Range("B290").Value = 22

-Range("C290").Value = num

-B290 = Range("B290").Value

-C290 = Range("C290").Value

-If B290 = C290 Then

-Range("D290").Value = "OK"

-Else

-Range("D290").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelope14(ByRef num)

-Range("A291").Clear

-Range("B291").Clear

-Range("C291").Clear

-Range("D291").Clear

-Range("A291").Value = "xlPaperEnvelope14"

-Range("B291").Value = 23

-Range("C291").Value = num

-B291 = Range("B291").Value

-C291 = Range("C291").Value

-If B291 = C291 Then

-Range("D291").Value = "OK"

-Else

-Range("D291").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelope9(ByRef num)

-Range("A292").Clear

-Range("B292").Clear

-Range("C292").Clear

-Range("D292").Clear

-Range("A292").Value = "xlPaperEnvelope9"

-Range("B292").Value = 19

-Range("C292").Value = num

-B292 = Range("B292").Value

-C292 = Range("C292").Value

-If B292 = C292 Then

-Range("D292").Value = "OK"

-Else

-Range("D292").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelopeB4(ByRef num)

-Range("A293").Clear

-Range("B293").Clear

-Range("C293").Clear

-Range("D293").Clear

-Range("A293").Value = "xlPaperEnvelopeB4"

-Range("B293").Value = 33

-Range("C293").Value = num

-B293 = Range("B293").Value

-C293 = Range("C293").Value

-If B293 = C293 Then

-Range("D293").Value = "OK"

-Else

-Range("D293").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelopeB5(ByRef num)

-Range("A294").Clear

-Range("B294").Clear

-Range("C294").Clear

-Range("D294").Clear

-Range("A294").Value = "xlPaperEnvelopeB5"

-Range("B294").Value = 34

-Range("C294").Value = num

-B294 = Range("B294").Value

-C294 = Range("C294").Value

-If B294 = C294 Then

-Range("D294").Value = "OK"

-Else

-Range("D294").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelopeB6(ByRef num)

-Range("A295").Clear

-Range("B295").Clear

-Range("C295").Clear

-Range("D295").Clear

-Range("A295").Value = "xlPaperEnvelopeB6"

-Range("B295").Value = 35

-Range("C295").Value = num

-B295 = Range("B295").Value

-C295 = Range("C295").Value

-If B295 = C295 Then

-Range("D295").Value = "OK"

-Else

-Range("D295").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelopeC3(ByRef num)

-Range("A296").Clear

-Range("B296").Clear

-Range("C296").Clear

-Range("D296").Clear

-Range("A296").Value = "xlPaperEnvelopeC3"

-Range("B296").Value = 29

-Range("C296").Value = num

-B296 = Range("B296").Value

-C296 = Range("C296").Value

-If B296 = C296 Then

-Range("D296").Value = "OK"

-Else

-Range("D296").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelopeC4(ByRef num)

-Range("A297").Clear

-Range("B297").Clear

-Range("C297").Clear

-Range("D297").Clear

-Range("A297").Value = "xlPaperEnvelopeC4"

-Range("B297").Value = 30

-Range("C297").Value = num

-B297 = Range("B297").Value

-C297 = Range("C297").Value

-If B297 = C297 Then

-Range("D297").Value = "OK"

-Else

-Range("D297").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelopeC5(ByRef num)

-Range("A298").Clear

-Range("B298").Clear

-Range("C298").Clear

-Range("D298").Clear

-Range("A298").Value = "xlPaperEnvelopeC5"

-Range("B298").Value = 28

-Range("C298").Value = num

-B298 = Range("B298").Value

-C298 = Range("C298").Value

-If B298 = C298 Then

-Range("D298").Value = "OK"

-Else

-Range("D298").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelopeC6(ByRef num)

-Range("A299").Clear

-Range("B299").Clear

-Range("C299").Clear

-Range("D299").Clear

-Range("A299").Value = "xlPaperEnvelopeC6"

-Range("B299").Value = 31

-Range("C299").Value = num

-B299 = Range("B299").Value

-C299 = Range("C299").Value

-If B299 = C299 Then

-Range("D299").Value = "OK"

-Else

-Range("D299").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelopeC65(ByRef num)

-Range("A300").Clear

-Range("B300").Clear

-Range("C300").Clear

-Range("D300").Clear

-Range("A300").Value = "xlPaperEnvelopeC65"

-Range("B300").Value = 32

-Range("C300").Value = num

-B300 = Range("B300").Value

-C300 = Range("C300").Value

-If B300 = C300 Then

-Range("D300").Value = "OK"

-Else

-Range("D300").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelopeDL(ByRef num)

-Range("A301").Clear

-Range("B301").Clear

-Range("C301").Clear

-Range("D301").Clear

-Range("A301").Value = "xlPaperEnvelopeDL"

-Range("B301").Value = 27

-Range("C301").Value = num

-B301 = Range("B301").Value

-C301 = Range("C301").Value

-If B301 = C301 Then

-Range("D301").Value = "OK"

-Else

-Range("D301").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelopeItaly(ByRef num)

-Range("A302").Clear

-Range("B302").Clear

-Range("C302").Clear

-Range("D302").Clear

-Range("A302").Value = "xlPaperEnvelopeItaly"

-Range("B302").Value = 36

-Range("C302").Value = num

-B302 = Range("B302").Value

-C302 = Range("C302").Value

-If B302 = C302 Then

-Range("D302").Value = "OK"

-Else

-Range("D302").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelopeMonarch(ByRef num)

-Range("A303").Clear

-Range("B303").Clear

-Range("C303").Clear

-Range("D303").Clear

-Range("A303").Value = "xlPaperEnvelopeMonarch"

-Range("B303").Value = 37

-Range("C303").Value = num

-B303 = Range("B303").Value

-C303 = Range("C303").Value

-If B303 = C303 Then

-Range("D303").Value = "OK"

-Else

-Range("D303").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEnvelopePersonal(ByRef num)

-Range("A304").Clear

-Range("B304").Clear

-Range("C304").Clear

-Range("D304").Clear

-Range("A304").Value = "xlPaperEnvelopePersonal"

-Range("B304").Value = 38

-Range("C304").Value = num

-B304 = Range("B304").Value

-C304 = Range("C304").Value

-If B304 = C304 Then

-Range("D304").Value = "OK"

-Else

-Range("D304").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperEsheet(ByRef num)

-Range("A305").Clear

-Range("B305").Clear

-Range("C305").Clear

-Range("D305").Clear

-Range("A305").Value = "xlPaperEsheet"

-Range("B305").Value = 26

-Range("C305").Value = num

-B305 = Range("B305").Value

-C305 = Range("C305").Value

-If B305 = C305 Then

-Range("D305").Value = "OK"

-Else

-Range("D305").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperExective(ByRef num)

-Range("A306").Clear

-Range("B306").Clear

-Range("C306").Clear

-Range("D306").Clear

-Range("A306").Value = "xlPaperExective"

-Range("B306").Value = 7

-Range("C306").Value = num

-B306 = Range("B306").Value

-C306 = Range("C306").Value

-If B306 = C306 Then

-Range("D306").Value = "OK"

-Else

-Range("D306").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperFanfoldLegalGerman(ByRef num)

-Range("A307").Clear

-Range("B307").Clear

-Range("C307").Clear

-Range("D307").Clear

-Range("A307").Value = "xlPaperFanfoldLegalGerman"

-Range("B307").Value = 41

-Range("C307").Value = num

-B307 = Range("B307").Value

-C307 = Range("C307").Value

-If B307 = C307 Then

-Range("D307").Value = "OK"

-Else

-Range("D307").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperFanfoldStdGerman(ByRef num)

-Range("A308").Clear

-Range("B308").Clear

-Range("C308").Clear

-Range("D308").Clear

-Range("A308").Value = "xlPaperFanfoldStdGerman"

-Range("B308").Value = 40

-Range("C308").Value = num

-B308 = Range("B308").Value

-C308 = Range("C308").Value

-If B308 = C308 Then

-Range("D308").Value = "OK"

-Else

-Range("D308").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperFanfoldUS(ByRef num)

-Range("A309").Clear

-Range("B309").Clear

-Range("C309").Clear

-Range("D309").Clear

-Range("A309").Value = "xlPaperFanfoldUS"

-Range("B309").Value = 39

-Range("C309").Value = num

-B309 = Range("B309").Value

-C309 = Range("C309").Value

-If B309 = C309 Then

-Range("D309").Value = "OK"

-Else

-Range("D309").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperFolio(ByRef num)

-Range("A310").Clear

-Range("B310").Clear

-Range("C310").Clear

-Range("D310").Clear

-Range("A310").Value = "xlPaperFolio"

-Range("B310").Value = 14

-Range("C310").Value = num

-B310 = Range("B310").Value

-C310 = Range("C310").Value

-If B310 = C310 Then

-Range("D310").Value = "OK"

-Else

-Range("D310").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperLedger(ByRef num)

-Range("A311").Clear

-Range("B311").Clear

-Range("C311").Clear

-Range("D311").Clear

-Range("A311").Value = "xlPaperLedger"

-Range("B311").Value = 4

-Range("C311").Value = num

-B311 = Range("B311").Value

-C311 = Range("C311").Value

-If B311 = C311 Then

-Range("D311").Value = "OK"

-Else

-Range("D311").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperLegal(ByRef num)

-Range("A312").Clear

-Range("B312").Clear

-Range("C312").Clear

-Range("D312").Clear

-Range("A312").Value = "xlPaperLegal"

-Range("B312").Value = 5

-Range("C312").Value = num

-B312 = Range("B312").Value

-C312 = Range("C312").Value

-If B312 = C312 Then

-Range("D312").Value = "OK"

-Else

-Range("D312").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperLetter(ByRef num)

-Range("A313").Clear

-Range("B313").Clear

-Range("C313").Clear

-Range("D313").Clear

-Range("A313").Value = "xlPaperLetter"

-Range("B313").Value = 1

-Range("C313").Value = num

-B313 = Range("B313").Value

-C313 = Range("C313").Value

-If B313 = C313 Then

-Range("D313").Value = "OK"

-Else

-Range("D313").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperLetterSmall(ByRef num)

-Range("A314").Clear

-Range("B314").Clear

-Range("C314").Clear

-Range("D314").Clear

-Range("A314").Value = "xlPaperLetterSmall"

-Range("B314").Value = 2

-Range("C314").Value = num

-B314 = Range("B314").Value

-C314 = Range("C314").Value

-If B314 = C314 Then

-Range("D314").Value = "OK"

-Else

-Range("D314").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperNote(ByRef num)

-Range("A315").Clear

-Range("B315").Clear

-Range("C315").Clear

-Range("D315").Clear

-Range("A315").Value = "xlPaperNote"

-Range("B315").Value = 18

-Range("C315").Value = num

-B315 = Range("B315").Value

-C315 = Range("C315").Value

-If B315 = C315 Then

-Range("D315").Value = "OK"

-Else

-Range("D315").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperQuarto(ByRef num)

-Range("A316").Clear

-Range("B316").Clear

-Range("C316").Clear

-Range("D316").Clear

-Range("A316").Value = "xlPaperQuarto"

-Range("B316").Value = 15

-Range("C316").Value = num

-B316 = Range("B316").Value

-C316 = Range("C316").Value

-If B316 = C316 Then

-Range("D316").Value = "OK"

-Else

-Range("D316").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperStatement(ByRef num)

-Range("A317").Clear

-Range("B317").Clear

-Range("C317").Clear

-Range("D317").Clear

-Range("A317").Value = "xlPaperStatement"

-Range("B317").Value = 6

-Range("C317").Value = num

-B317 = Range("B317").Value

-C317 = Range("C317").Value

-If B317 = C317 Then

-Range("D317").Value = "OK"

-Else

-Range("D317").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperTabloid(ByRef num)

-Range("A318").Clear

-Range("B318").Clear

-Range("C318").Clear

-Range("D318").Clear

-Range("A318").Value = "xlPaperTabloid"

-Range("B318").Value = 3

-Range("C318").Value = num

-B318 = Range("B318").Value

-C318 = Range("C318").Value

-If B318 = C318 Then

-Range("D318").Value = "OK"

-Else

-Range("D318").Value = "NG"

-End If

-End Function

-

-Function test_xlPaperUser(ByRef num)

-Range("A319").Clear

-Range("B319").Clear

-Range("C319").Clear

-Range("D319").Clear

-Range("A319").Value = "xlPaperUser"

-Range("B319").Value = 256

-Range("C319").Value = num

-B319 = Range("B319").Value

-C319 = Range("C319").Value

-If B319 = C319 Then

-Range("D319").Value = "OK"

-Else

-Range("D319").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeBigInt(ByRef num)

-Range("A320").Clear

-Range("B320").Clear

-Range("C320").Clear

-Range("D320").Clear

-Range("A320").Value = "xlParameterTypeBigInt"

-Range("B320").Value = -5

-Range("C320").Value = num

-B320 = Range("B320").Value

-C320 = Range("C320").Value

-If B320 = C320 Then

-Range("D320").Value = "OK"

-Else

-Range("D320").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeBinary(ByRef num)

-Range("A321").Clear

-Range("B321").Clear

-Range("C321").Clear

-Range("D321").Clear

-Range("A321").Value = "xlParameterTypeBinary"

-Range("B321").Value = -2

-Range("C321").Value = num

-B321 = Range("B321").Value

-C321 = Range("C321").Value

-If B321 = C321 Then

-Range("D321").Value = "OK"

-Else

-Range("D321").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeBit(ByRef num)

-Range("A322").Clear

-Range("B322").Clear

-Range("C322").Clear

-Range("D322").Clear

-Range("A322").Value = "xlParameterTypeBit"

-Range("B322").Value = -7

-Range("C322").Value = num

-B322 = Range("B322").Value

-C322 = Range("C322").Value

-If B322 = C322 Then

-Range("D322").Value = "OK"

-Else

-Range("D322").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeChar(ByRef num)

-Range("A323").Clear

-Range("B323").Clear

-Range("C323").Clear

-Range("D323").Clear

-Range("A323").Value = "xlParameterTypeChar"

-Range("B323").Value = 1

-Range("C323").Value = num

-B323 = Range("B323").Value

-C323 = Range("C323").Value

-If B323 = C323 Then

-Range("D323").Value = "OK"

-Else

-Range("D323").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeData(ByRef num)

-Range("A324").Clear

-Range("B324").Clear

-Range("C324").Clear

-Range("D324").Clear

-Range("A324").Value = "xlParameterTypeData"

-Range("B324").Value = 9

-Range("C324").Value = num

-B324 = Range("B324").Value

-C324 = Range("C324").Value

-If B324 = C324 Then

-Range("D324").Value = "OK"

-Else

-Range("D324").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeDecimal(ByRef num)

-Range("A325").Clear

-Range("B325").Clear

-Range("C325").Clear

-Range("D325").Clear

-Range("A325").Value = "xlParameterTypeDecimal"

-Range("B325").Value = 3

-Range("C325").Value = num

-B325 = Range("B325").Value

-C325 = Range("C325").Value

-If B325 = C325 Then

-Range("D325").Value = "OK"

-Else

-Range("D325").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeDouble(ByRef num)

-Range("A326").Clear

-Range("B326").Clear

-Range("C326").Clear

-Range("D326").Clear

-Range("A326").Value = "xlParameterTypeDouble"

-Range("B326").Value = 8

-Range("C326").Value = num

-B326 = Range("B326").Value

-C326 = Range("C326").Value

-If B326 = C326 Then

-Range("D326").Value = "OK"

-Else

-Range("D326").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeFloat(ByRef num)

-Range("A327").Clear

-Range("B327").Clear

-Range("C327").Clear

-Range("D327").Clear

-Range("A327").Value = "xlParameterTypeFloat"

-Range("B327").Value = 6

-Range("C327").Value = num

-B327 = Range("B327").Value

-C327 = Range("C327").Value

-If B327 = C327 Then

-Range("D327").Value = "OK"

-Else

-Range("D327").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeInteger(ByRef num)

-Range("A328").Clear

-Range("B328").Clear

-Range("C328").Clear

-Range("D328").Clear

-Range("A328").Value = "xlParameterTypeInteger"

-Range("B328").Value = 4

-Range("C328").Value = num

-B328 = Range("B328").Value

-C328 = Range("C328").Value

-If B328 = C328 Then

-Range("D328").Value = "OK"

-Else

-Range("D328").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeLongVarBinary(ByRef num)

-Range("A329").Clear

-Range("B329").Clear

-Range("C329").Clear

-Range("D329").Clear

-Range("A329").Value = "xlParameterTypeLongVarBinary"

-Range("B329").Value = -4

-Range("C329").Value = num

-B329 = Range("B329").Value

-C329 = Range("C329").Value

-If B329 = C329 Then

-Range("D329").Value = "OK"

-Else

-Range("D329").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeLongVarChar(ByRef num)

-Range("A330").Clear

-Range("B330").Clear

-Range("C330").Clear

-Range("D330").Clear

-Range("A330").Value = "xlParameterTypeLongVarChar"

-Range("B330").Value = -1

-Range("C330").Value = num

-B330 = Range("B330").Value

-C330 = Range("C330").Value

-If B330 = C330 Then

-Range("D330").Value = "OK"

-Else

-Range("D330").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeNumeric(ByRef num)

-Range("A331").Clear

-Range("B331").Clear

-Range("C331").Clear

-Range("D331").Clear

-Range("A331").Value = "xlParameterTypeNumeric"

-Range("B331").Value = 2

-Range("C331").Value = num

-B331 = Range("B331").Value

-C331 = Range("C331").Value

-If B331 = C331 Then

-Range("D331").Value = "OK"

-Else

-Range("D331").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeReal(ByRef num)

-Range("A332").Clear

-Range("B332").Clear

-Range("C332").Clear

-Range("D332").Clear

-Range("A332").Value = "xlParameterTypeReal"

-Range("B332").Value = 7

-Range("C332").Value = num

-B332 = Range("B332").Value

-C332 = Range("C332").Value

-If B332 = C332 Then

-Range("D332").Value = "OK"

-Else

-Range("D332").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeSmallInt(ByRef num)

-Range("A333").Clear

-Range("B333").Clear

-Range("C333").Clear

-Range("D333").Clear

-Range("A333").Value = "xlParameterTypeSmallInt"

-Range("B333").Value = 5

-Range("C333").Value = num

-B333 = Range("B333").Value

-C333 = Range("C333").Value

-If B333 = C333 Then

-Range("D333").Value = "OK"

-Else

-Range("D333").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeTime(ByRef num)

-Range("A334").Clear

-Range("B334").Clear

-Range("C334").Clear

-Range("D334").Clear

-Range("A334").Value = "xlParameterTypeTime"

-Range("B334").Value = 10

-Range("C334").Value = num

-B334 = Range("B334").Value

-C334 = Range("C334").Value

-If B334 = C334 Then

-Range("D334").Value = "OK"

-Else

-Range("D334").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeTimestamp(ByRef num)

-Range("A335").Clear

-Range("B335").Clear

-Range("C335").Clear

-Range("D335").Clear

-Range("A335").Value = "xlParameterTypeTimestamp"

-Range("B335").Value = 11

-Range("C335").Value = num

-B335 = Range("B335").Value

-C335 = Range("C335").Value

-If B335 = C335 Then

-Range("D335").Value = "OK"

-Else

-Range("D335").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeTinyInt(ByRef num)

-Range("A336").Clear

-Range("B336").Clear

-Range("C336").Clear

-Range("D336").Clear

-Range("A336").Value = "xlParameterTypeTinyInt"

-Range("B336").Value = -6

-Range("C336").Value = num

-B336 = Range("B336").Value

-C336 = Range("C336").Value

-If B336 = C336 Then

-Range("D336").Value = "OK"

-Else

-Range("D336").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeUnknown(ByRef num)

-Range("A337").Clear

-Range("B337").Clear

-Range("C337").Clear

-Range("D337").Clear

-Range("A337").Value = "xlParameterTypeUnknown"

-Range("B337").Value = 0

-Range("C337").Value = num

-B337 = Range("B337").Value

-C337 = Range("C337").Value

-If B337 = C337 Then

-Range("D337").Value = "OK"

-Else

-Range("D337").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeVarBinary(ByRef num)

-Range("A338").Clear

-Range("B338").Clear

-Range("C338").Clear

-Range("D338").Clear

-Range("A338").Value = "xlParameterTypeVarBinary"

-Range("B338").Value = -3

-Range("C338").Value = num

-B338 = Range("B338").Value

-C338 = Range("C338").Value

-If B338 = C338 Then

-Range("D338").Value = "OK"

-Else

-Range("D338").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeVarChar(ByRef num)

-Range("A339").Clear

-Range("B339").Clear

-Range("C339").Clear

-Range("D339").Clear

-Range("A339").Value = "xlParameterTypeVarChar"

-Range("B339").Value = 12

-Range("C339").Value = num

-B339 = Range("B339").Value

-C339 = Range("C339").Value

-If B339 = C339 Then

-Range("D339").Value = "OK"

-Else

-Range("D339").Value = "NG"

-End If

-End Function

-

-Function test_xlParameterTypeWChar(ByRef num)

-Range("A340").Clear

-Range("B340").Clear

-Range("C340").Clear

-Range("D340").Clear

-Range("A340").Value = "xlParameterTypeWChar"

-Range("B340").Value = -8

-Range("C340").Value = num

-B340 = Range("B340").Value

-C340 = Range("C340").Value

-If B340 = C340 Then

-Range("D340").Value = "OK"

-Else

-Range("D340").Value = "NG"

-End If

-End Function

-

-Function test_xlConstant(ByRef num)

-Range("A341").Clear

-Range("B341").Clear

-Range("C341").Clear

-Range("D341").Clear

-Range("A341").Value = "xlConstant"

-Range("B341").Value = 1

-Range("C341").Value = num

-B341 = Range("B341").Value

-C341 = Range("C341").Value

-If B341 = C341 Then

-Range("D341").Value = "OK"

-Else

-Range("D341").Value = "NG"

-End If

-End Function

-

-Function test_xlPrompt(ByRef num)

-Range("A342").Clear

-Range("B342").Clear

-Range("C342").Clear

-Range("D342").Clear

-Range("A342").Value = "xlPrompt"

-Range("B342").Value = 0

-Range("C342").Value = num

-B342 = Range("B342").Value

-C342 = Range("C342").Value

-If B342 = C342 Then

-Range("D342").Value = "OK"

-Else

-Range("D342").Value = "NG"

-End If

-End Function

-

-Function test_xlRange(ByRef num)

-Range("A343").Clear

-Range("B343").Clear

-Range("C343").Clear

-Range("D343").Clear

-Range("A343").Value = "xlRange"

-Range("B343").Value = 2

-Range("C343").Value = num

-B343 = Range("B343").Value

-C343 = Range("C343").Value

-If B343 = C343 Then

-Range("D343").Value = "OK"

-Else

-Range("D343").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteSpecialOperationAdd(ByRef num)

-Range("A344").Clear

-Range("B344").Clear

-Range("C344").Clear

-Range("D344").Clear

-Range("A344").Value = "xlPasteSpecialOperationAdd"

-Range("B344").Value = 2

-Range("C344").Value = num

-B344 = Range("B344").Value

-C344 = Range("C344").Value

-If B344 = C344 Then

-Range("D344").Value = "OK"

-Else

-Range("D344").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteSpecialOperationDivide(ByRef num)

-Range("A345").Clear

-Range("B345").Clear

-Range("C345").Clear

-Range("D345").Clear

-Range("A345").Value = "xlPasteSpecialOperationDivide"

-Range("B345").Value = 5

-Range("C345").Value = num

-B345 = Range("B345").Value

-C345 = Range("C345").Value

-If B345 = C345 Then

-Range("D345").Value = "OK"

-Else

-Range("D345").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteSpecialOperationMultiply(ByRef num)

-Range("A346").Clear

-Range("B346").Clear

-Range("C346").Clear

-Range("D346").Clear

-Range("A346").Value = "xlPasteSpecialOperationMultiply"

-Range("B346").Value = 4

-Range("C346").Value = num

-B346 = Range("B346").Value

-C346 = Range("C346").Value

-If B346 = C346 Then

-Range("D346").Value = "OK"

-Else

-Range("D346").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteSpecialOperationNone(ByRef num)

-Range("A347").Clear

-Range("B347").Clear

-Range("C347").Clear

-Range("D347").Clear

-Range("A347").Value = "xlPasteSpecialOperationNone"

-Range("B347").Value = -4142

-Range("C347").Value = num

-B347 = Range("B347").Value

-C347 = Range("C347").Value

-If B347 = C347 Then

-Range("D347").Value = "OK"

-Else

-Range("D347").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteSpecialOperationSubstract(ByRef num)

-Range("A348").Clear

-Range("B348").Clear

-Range("C348").Clear

-Range("D348").Clear

-Range("A348").Value = "xlPasteSpecialOperationSubstract"

-Range("B348").Value = 3

-Range("C348").Value = num

-B348 = Range("B348").Value

-C348 = Range("C348").Value

-If B348 = C348 Then

-Range("D348").Value = "OK"

-Else

-Range("D348").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteAll(ByRef num)

-Range("A349").Clear

-Range("B349").Clear

-Range("C349").Clear

-Range("D349").Clear

-Range("A349").Value = "xlPasteAll"

-Range("B349").Value = -4104

-Range("C349").Value = num

-B349 = Range("B349").Value

-C349 = Range("C349").Value

-If B349 = C349 Then

-Range("D349").Value = "OK"

-Else

-Range("D349").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteAllExceptBorders(ByRef num)

-Range("A350").Clear

-Range("B350").Clear

-Range("C350").Clear

-Range("D350").Clear

-Range("A350").Value = "xlPasteAllExceptBorders"

-Range("B350").Value = 7

-Range("C350").Value = num

-B350 = Range("B350").Value

-C350 = Range("C350").Value

-If B350 = C350 Then

-Range("D350").Value = "OK"

-Else

-Range("D350").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteAllColumnWidths(ByRef num)

-Range("A351").Clear

-Range("B351").Clear

-Range("C351").Clear

-Range("D351").Clear

-Range("A351").Value = "xlPasteAllColumnWidths"

-Range("B351").Value = 8

-Range("C351").Value = num

-B351 = Range("B351").Value

-C351 = Range("C351").Value

-If B351 = C351 Then

-Range("D351").Value = "OK"

-Else

-Range("D351").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteComments(ByRef num)

-Range("A352").Clear

-Range("B352").Clear

-Range("C352").Clear

-Range("D352").Clear

-Range("A352").Value = "xlPasteComments"

-Range("B352").Value = -4144

-Range("C352").Value = num

-B352 = Range("B352").Value

-C352 = Range("C352").Value

-If B352 = C352 Then

-Range("D352").Value = "OK"

-Else

-Range("D352").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteFormats(ByRef num)

-Range("A353").Clear

-Range("B353").Clear

-Range("C353").Clear

-Range("D353").Clear

-Range("A353").Value = "xlPasteFormats"

-Range("B353").Value = -4122

-Range("C353").Value = num

-B353 = Range("B353").Value

-C353 = Range("C353").Value

-If B353 = C353 Then

-Range("D353").Value = "OK"

-Else

-Range("D353").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteFormulas(ByRef num)

-Range("A354").Clear

-Range("B354").Clear

-Range("C354").Clear

-Range("D354").Clear

-Range("A354").Value = "xlPasteFormulas"

-Range("B354").Value = -4123

-Range("C354").Value = num

-B354 = Range("B354").Value

-C354 = Range("C354").Value

-If B354 = C354 Then

-Range("D354").Value = "OK"

-Else

-Range("D354").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteFormulasAndNumberFormats(ByRef num)

-Range("A355").Clear

-Range("B355").Clear

-Range("C355").Clear

-Range("D355").Clear

-Range("A355").Value = "xlPasteFormulasAndNumberFormats"

-Range("B355").Value = 11

-Range("C355").Value = num

-B355 = Range("B355").Value

-C355 = Range("C355").Value

-If B355 = C355 Then

-Range("D355").Value = "OK"

-Else

-Range("D355").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteValidation(ByRef num)

-Range("A356").Clear

-Range("B356").Clear

-Range("C356").Clear

-Range("D356").Clear

-Range("A356").Value = "xlPasteValidation"

-Range("B356").Value = 6

-Range("C356").Value = num

-B356 = Range("B356").Value

-C356 = Range("C356").Value

-If B356 = C356 Then

-Range("D356").Value = "OK"

-Else

-Range("D356").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteValues(ByRef num)

-Range("A357").Clear

-Range("B357").Clear

-Range("C357").Clear

-Range("D357").Clear

-Range("A357").Value = "xlPasteValues"

-Range("B357").Value = -4163

-Range("C357").Value = num

-B357 = Range("B357").Value

-C357 = Range("C357").Value

-If B357 = C357 Then

-Range("D357").Value = "OK"

-Else

-Range("D357").Value = "NG"

-End If

-End Function

-

-Function test_xlPasteValuesAndNumberFormats(ByRef num)

-Range("A358").Clear

-Range("B358").Clear

-Range("C358").Clear

-Range("D358").Clear

-Range("A358").Value = "xlPasteValuesAndNumberFormats"

-Range("B358").Value = 12

-Range("C358").Value = num

-B358 = Range("B358").Value

-C358 = Range("C358").Value

-If B358 = C358 Then

-Range("D358").Value = "OK"

-Else

-Range("D358").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternAutomatic(ByRef num)

-Range("A359").Clear

-Range("B359").Clear

-Range("C359").Clear

-Range("D359").Clear

-Range("A359").Value = "xlPatternAutomatic"

-Range("B359").Value = -4105

-Range("C359").Value = num

-B359 = Range("B359").Value

-C359 = Range("C359").Value

-If B359 = C359 Then

-Range("D359").Value = "OK"

-Else

-Range("D359").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternChecker(ByRef num)

-Range("A360").Clear

-Range("B360").Clear

-Range("C360").Clear

-Range("D360").Clear

-Range("A360").Value = "xlPatternChecker"

-Range("B360").Value = 9

-Range("C360").Value = num

-B360 = Range("B360").Value

-C360 = Range("C360").Value

-If B360 = C360 Then

-Range("D360").Value = "OK"

-Else

-Range("D360").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternCrissCross(ByRef num)

-Range("A361").Clear

-Range("B361").Clear

-Range("C361").Clear

-Range("D361").Clear

-Range("A361").Value = "xlPatternCrissCross"

-Range("B361").Value = 16

-Range("C361").Value = num

-B361 = Range("B361").Value

-C361 = Range("C361").Value

-If B361 = C361 Then

-Range("D361").Value = "OK"

-Else

-Range("D361").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternDown(ByRef num)

-Range("A362").Clear

-Range("B362").Clear

-Range("C362").Clear

-Range("D362").Clear

-Range("A362").Value = "xlPatternDown"

-Range("B362").Value = -4121

-Range("C362").Value = num

-B362 = Range("B362").Value

-C362 = Range("C362").Value

-If B362 = C362 Then

-Range("D362").Value = "OK"

-Else

-Range("D362").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternGray16(ByRef num)

-Range("A363").Clear

-Range("B363").Clear

-Range("C363").Clear

-Range("D363").Clear

-Range("A363").Value = "xlPatternGray16"

-Range("B363").Value = 17

-Range("C363").Value = num

-B363 = Range("B363").Value

-C363 = Range("C363").Value

-If B363 = C363 Then

-Range("D363").Value = "OK"

-Else

-Range("D363").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternGray25(ByRef num)

-Range("A364").Clear

-Range("B364").Clear

-Range("C364").Clear

-Range("D364").Clear

-Range("A364").Value = "xlPatternGray25"

-Range("B364").Value = -4124

-Range("C364").Value = num

-B364 = Range("B364").Value

-C364 = Range("C364").Value

-If B364 = C364 Then

-Range("D364").Value = "OK"

-Else

-Range("D364").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternGray50(ByRef num)

-Range("A365").Clear

-Range("B365").Clear

-Range("C365").Clear

-Range("D365").Clear

-Range("A365").Value = "xlPatternGray50"

-Range("B365").Value = -4125

-Range("C365").Value = num

-B365 = Range("B365").Value

-C365 = Range("C365").Value

-If B365 = C365 Then

-Range("D365").Value = "OK"

-Else

-Range("D365").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternGray75(ByRef num)

-Range("A366").Clear

-Range("B366").Clear

-Range("C366").Clear

-Range("D366").Clear

-Range("A366").Value = "xlPatternGray75"

-Range("B366").Value = -4126

-Range("C366").Value = num

-B366 = Range("B366").Value

-C366 = Range("C366").Value

-If B366 = C366 Then

-Range("D366").Value = "OK"

-Else

-Range("D366").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternGray8(ByRef num)

-Range("A367").Clear

-Range("B367").Clear

-Range("C367").Clear

-Range("D367").Clear

-Range("A367").Value = "xlPatternGray8"

-Range("B367").Value = 18

-Range("C367").Value = num

-B367 = Range("B367").Value

-C367 = Range("C367").Value

-If B367 = C367 Then

-Range("D367").Value = "OK"

-Else

-Range("D367").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternGrid(ByRef num)

-Range("A368").Clear

-Range("B368").Clear

-Range("C368").Clear

-Range("D368").Clear

-Range("A368").Value = "xlPatternGrid"

-Range("B368").Value = 15

-Range("C368").Value = num

-B368 = Range("B368").Value

-C368 = Range("C368").Value

-If B368 = C368 Then

-Range("D368").Value = "OK"

-Else

-Range("D368").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternHorizontal(ByRef num)

-Range("A369").Clear

-Range("B369").Clear

-Range("C369").Clear

-Range("D369").Clear

-Range("A369").Value = "xlPatternHorizontal"

-Range("B369").Value = -4128

-Range("C369").Value = num

-B369 = Range("B369").Value

-C369 = Range("C369").Value

-If B369 = C369 Then

-Range("D369").Value = "OK"

-Else

-Range("D369").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternLightDown(ByRef num)

-Range("A370").Clear

-Range("B370").Clear

-Range("C370").Clear

-Range("D370").Clear

-Range("A370").Value = "xlPatternLightDown"

-Range("B370").Value = 13

-Range("C370").Value = num

-B370 = Range("B370").Value

-C370 = Range("C370").Value

-If B370 = C370 Then

-Range("D370").Value = "OK"

-Else

-Range("D370").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternLightHorizontal(ByRef num)

-Range("A371").Clear

-Range("B371").Clear

-Range("C371").Clear

-Range("D371").Clear

-Range("A371").Value = "xlPatternLightHorizontal"

-Range("B371").Value = 11

-Range("C371").Value = num

-B371 = Range("B371").Value

-C371 = Range("C371").Value

-If B371 = C371 Then

-Range("D371").Value = "OK"

-Else

-Range("D371").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternLightUp(ByRef num)

-Range("A372").Clear

-Range("B372").Clear

-Range("C372").Clear

-Range("D372").Clear

-Range("A372").Value = "xlPatternLightUp"

-Range("B372").Value = 14

-Range("C372").Value = num

-B372 = Range("B372").Value

-C372 = Range("C372").Value

-If B372 = C372 Then

-Range("D372").Value = "OK"

-Else

-Range("D372").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternLightVertical(ByRef num)

-Range("A373").Clear

-Range("B373").Clear

-Range("C373").Clear

-Range("D373").Clear

-Range("A373").Value = "xlPatternLightVertical"

-Range("B373").Value = 12

-Range("C373").Value = num

-B373 = Range("B373").Value

-C373 = Range("C373").Value

-If B373 = C373 Then

-Range("D373").Value = "OK"

-Else

-Range("D373").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternNone(ByRef num)

-Range("A374").Clear

-Range("B374").Clear

-Range("C374").Clear

-Range("D374").Clear

-Range("A374").Value = "xlPatternNone"

-Range("B374").Value = -4142

-Range("C374").Value = num

-B374 = Range("B374").Value

-C374 = Range("C374").Value

-If B374 = C374 Then

-Range("D374").Value = "OK"

-Else

-Range("D374").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternSemiGray75(ByRef num)

-Range("A375").Clear

-Range("B375").Clear

-Range("C375").Clear

-Range("D375").Clear

-Range("A375").Value = "xlPatternSemiGray75"

-Range("B375").Value = 10

-Range("C375").Value = num

-B375 = Range("B375").Value

-C375 = Range("C375").Value

-If B375 = C375 Then

-Range("D375").Value = "OK"

-Else

-Range("D375").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternSolid(ByRef num)

-Range("A376").Clear

-Range("B376").Clear

-Range("C376").Clear

-Range("D376").Clear

-Range("A376").Value = "xlPatternSolid"

-Range("B376").Value = 1

-Range("C376").Value = num

-B376 = Range("B376").Value

-C376 = Range("C376").Value

-If B376 = C376 Then

-Range("D376").Value = "OK"

-Else

-Range("D376").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternUp(ByRef num)

-Range("A377").Clear

-Range("B377").Clear

-Range("C377").Clear

-Range("D377").Clear

-Range("A377").Value = "xlPatternUp"

-Range("B377").Value = -4162

-Range("C377").Value = num

-B377 = Range("B377").Value

-C377 = Range("C377").Value

-If B377 = C377 Then

-Range("D377").Value = "OK"

-Else

-Range("D377").Value = "NG"

-End If

-End Function

-

-Function test_xlPatternVertical(ByRef num)

-Range("A378").Clear

-Range("B378").Clear

-Range("C378").Clear

-Range("D378").Clear

-Range("A378").Value = "xlPatternVertical"

-Range("B378").Value = -4166

-Range("C378").Value = num

-B378 = Range("B378").Value

-C378 = Range("C378").Value

-If B378 = C378 Then

-Range("D378").Value = "OK"

-Else

-Range("D378").Value = "NG"

-End If

-End Function

-

-Function test_XlPhoneticAlignCenter(ByRef num)

-Range("A379").Clear

-Range("B379").Clear

-Range("C379").Clear

-Range("D379").Clear

-Range("A379").Value = "XlPhoneticAlignCenter"

-Range("B379").Value = 2

-Range("C379").Value = num

-B379 = Range("B379").Value

-C379 = Range("C379").Value

-If B379 = C379 Then

-Range("D379").Value = "OK"

-Else

-Range("D379").Value = "NG"

-End If

-End Function

-

-Function test_XlPhoneticAlignDistributed(ByRef num)

-Range("A380").Clear

-Range("B380").Clear

-Range("C380").Clear

-Range("D380").Clear

-Range("A380").Value = "XlPhoneticAlignDistributed"

-Range("B380").Value = 3

-Range("C380").Value = num

-B380 = Range("B380").Value

-C380 = Range("C380").Value

-If B380 = C380 Then

-Range("D380").Value = "OK"

-Else

-Range("D380").Value = "NG"

-End If

-End Function

-

-Function test_XlPhoneticAlignLeft(ByRef num)

-Range("A381").Clear

-Range("B381").Clear

-Range("C381").Clear

-Range("D381").Clear

-Range("A381").Value = "XlPhoneticAlignLeft"

-Range("B381").Value = 1

-Range("C381").Value = num

-B381 = Range("B381").Value

-C381 = Range("C381").Value

-If B381 = C381 Then

-Range("D381").Value = "OK"

-Else

-Range("D381").Value = "NG"

-End If

-End Function

-

-Function test_XlPhoneticAlignNoControl(ByRef num)

-Range("A382").Clear

-Range("B382").Clear

-Range("C382").Clear

-Range("D382").Clear

-Range("A382").Value = "XlPhoneticAlignNoControl"

-Range("B382").Value = 0

-Range("C382").Value = num

-B382 = Range("B382").Value

-C382 = Range("C382").Value

-If B382 = C382 Then

-Range("D382").Value = "OK"

-Else

-Range("D382").Value = "NG"

-End If

-End Function

-

-Function test_xlPrinter(ByRef num)

-Range("A383").Clear

-Range("B383").Clear

-Range("C383").Clear

-Range("D383").Clear

-Range("A383").Value = "xlPrinter"

-Range("B383").Value = 2

-Range("C383").Value = num

-B383 = Range("B383").Value

-C383 = Range("C383").Value

-If B383 = C383 Then

-Range("D383").Value = "OK"

-Else

-Range("D383").Value = "NG"

-End If

-End Function

-

-Function test_xlScreen(ByRef num)

-Range("A384").Clear

-Range("B384").Clear

-Range("C384").Clear

-Range("D384").Clear

-Range("A384").Value = "xlScreen"

-Range("B384").Value = 1

-Range("C384").Value = num

-B384 = Range("B384").Value

-C384 = Range("C384").Value

-If B384 = C384 Then

-Range("D384").Value = "OK"

-Else

-Range("D384").Value = "NG"

-End If

-End Function

-

-Function test_xlBMP(ByRef num)

-Range("A385").Clear

-Range("B385").Clear

-Range("C385").Clear

-Range("D385").Clear

-Range("A385").Value = "xlBMP"

-Range("B385").Value = 1

-Range("C385").Value = num

-B385 = Range("B385").Value

-C385 = Range("C385").Value

-If B385 = C385 Then

-Range("D385").Value = "OK"

-Else

-Range("D385").Value = "NG"

-End If

-End Function

-

-Function test_xlCGM(ByRef num)

-Range("A386").Clear

-Range("B386").Clear

-Range("C386").Clear

-Range("D386").Clear

-Range("A386").Value = "xlCGM"

-Range("B386").Value = 7

-Range("C386").Value = num

-B386 = Range("B386").Value

-C386 = Range("C386").Value

-If B386 = C386 Then

-Range("D386").Value = "OK"

-Else

-Range("D386").Value = "NG"

-End If

-End Function

-

-Function test_xlDRW(ByRef num)

-Range("A387").Clear

-Range("B387").Clear

-Range("C387").Clear

-Range("D387").Clear

-Range("A387").Value = "xlDRW"

-Range("B387").Value = 4

-Range("C387").Value = num

-B387 = Range("B387").Value

-C387 = Range("C387").Value

-If B387 = C387 Then

-Range("D387").Value = "OK"

-Else

-Range("D387").Value = "NG"

-End If

-End Function

-

-Function test_xlDXF(ByRef num)

-Range("A388").Clear

-Range("B388").Clear

-Range("C388").Clear

-Range("D388").Clear

-Range("A388").Value = "xlDXF"

-Range("B388").Value = 5

-Range("C388").Value = num

-B388 = Range("B388").Value

-C388 = Range("C388").Value

-If B388 = C388 Then

-Range("D388").Value = "OK"

-Else

-Range("D388").Value = "NG"

-End If

-End Function

-

-Function test_xlEPS(ByRef num)

-Range("A389").Clear

-Range("B389").Clear

-Range("C389").Clear

-Range("D389").Clear

-Range("A389").Value = "xlEPS"

-Range("B389").Value = 8

-Range("C389").Value = num

-B389 = Range("B389").Value

-C389 = Range("C389").Value

-If B389 = C389 Then

-Range("D389").Value = "OK"

-Else

-Range("D389").Value = "NG"

-End If

-End Function

-

-Function test_xlHGL(ByRef num)

-Range("A390").Clear

-Range("B390").Clear

-Range("C390").Clear

-Range("D390").Clear

-Range("A390").Value = "xlHGL"

-Range("B390").Value = 6

-Range("C390").Value = num

-B390 = Range("B390").Value

-C390 = Range("C390").Value

-If B390 = C390 Then

-Range("D390").Value = "OK"

-Else

-Range("D390").Value = "NG"

-End If

-End Function

-

-Function test_xlPCT(ByRef num)

-Range("A391").Clear

-Range("B391").Clear

-Range("C391").Clear

-Range("D391").Clear

-Range("A391").Value = "xlPCT"

-Range("B391").Value = 13

-Range("C391").Value = num

-B391 = Range("B391").Value

-C391 = Range("C391").Value

-If B391 = C391 Then

-Range("D391").Value = "OK"

-Else

-Range("D391").Value = "NG"

-End If

-End Function

-

-Function test_xlPCX(ByRef num)

-Range("A392").Clear

-Range("B392").Clear

-Range("C392").Clear

-Range("D392").Clear

-Range("A392").Value = "xlPCX"

-Range("B392").Value = 10

-Range("C392").Value = num

-B392 = Range("B392").Value

-C392 = Range("C392").Value

-If B392 = C392 Then

-Range("D392").Value = "OK"

-Else

-Range("D392").Value = "NG"

-End If

-End Function

-

-Function test_xlPIC(ByRef num)

-Range("A393").Clear

-Range("B393").Clear

-Range("C393").Clear

-Range("D393").Clear

-Range("A393").Value = "xlPIC"

-Range("B393").Value = 11

-Range("C393").Value = num

-B393 = Range("B393").Value

-C393 = Range("C393").Value

-If B393 = C393 Then

-Range("D393").Value = "OK"

-Else

-Range("D393").Value = "NG"

-End If

-End Function

-

-Function test_xlPLT(ByRef num)

-Range("A394").Clear

-Range("B394").Clear

-Range("C394").Clear

-Range("D394").Clear

-Range("A394").Value = "xlPLT"

-Range("B394").Value = 12

-Range("C394").Value = num

-B394 = Range("B394").Value

-C394 = Range("C394").Value

-If B394 = C394 Then

-Range("D394").Value = "OK"

-Else

-Range("D394").Value = "NG"

-End If

-End Function

-

-Function test_xlTIF(ByRef num)

-Range("A395").Clear

-Range("B395").Clear

-Range("C395").Clear

-Range("D395").Clear

-Range("A395").Value = "xlTIF"

-Range("B395").Value = 9

-Range("C395").Value = num

-B395 = Range("B395").Value

-C395 = Range("C395").Value

-If B395 = C395 Then

-Range("D395").Value = "OK"

-Else

-Range("D395").Value = "NG"

-End If

-End Function

-

-Function test_xlWMF(ByRef num)

-Range("A396").Clear

-Range("B396").Clear

-Range("C396").Clear

-Range("D396").Clear

-Range("A396").Value = "xlWMF"

-Range("B396").Value = 2

-Range("C396").Value = num

-B396 = Range("B396").Value

-C396 = Range("C396").Value

-If B396 = C396 Then

-Range("D396").Value = "OK"

-Else

-Range("D396").Value = "NG"

-End If

-End Function

-

-Function test_xlWPG(ByRef num)

-Range("A397").Clear

-Range("B397").Clear

-Range("C397").Clear

-Range("D397").Clear

-Range("A397").Value = "xlWPG"

-Range("B397").Value = 3

-Range("C397").Value = num

-B397 = Range("B397").Value

-C397 = Range("C397").Value

-If B397 = C397 Then

-Range("D397").Value = "OK"

-Else

-Range("D397").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotCellBlankCell(ByRef num)

-Range("A398").Clear

-Range("B398").Clear

-Range("C398").Clear

-Range("D398").Clear

-Range("A398").Value = "xlPivotCellBlankCell"

-Range("B398").Value = 0

-Range("C398").Value = num

-B398 = Range("B398").Value

-C398 = Range("C398").Value

-If B398 = C398 Then

-Range("D398").Value = "OK"

-Else

-Range("D398").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotCellCustomSubtotal(ByRef num)

-Range("A399").Clear

-Range("B399").Clear

-Range("C399").Clear

-Range("D399").Clear

-Range("A399").Value = "xlPivotCellCustomSubtotal"

-Range("B399").Value = 7

-Range("C399").Value = num

-B399 = Range("B399").Value

-C399 = Range("C399").Value

-If B399 = C399 Then

-Range("D399").Value = "OK"

-Else

-Range("D399").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotCellDataField(ByRef num)

-Range("A400").Clear

-Range("B400").Clear

-Range("C400").Clear

-Range("D400").Clear

-Range("A400").Value = "xlPivotCellDataField"

-Range("B400").Value = 4

-Range("C400").Value = num

-B400 = Range("B400").Value

-C400 = Range("C400").Value

-If B400 = C400 Then

-Range("D400").Value = "OK"

-Else

-Range("D400").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotCellDataPivotField(ByRef num)

-Range("A401").Clear

-Range("B401").Clear

-Range("C401").Clear

-Range("D401").Clear

-Range("A401").Value = "xlPivotCellDataPivotField"

-Range("B401").Value = 8

-Range("C401").Value = num

-B401 = Range("B401").Value

-C401 = Range("C401").Value

-If B401 = C401 Then

-Range("D401").Value = "OK"

-Else

-Range("D401").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotCellGrandTotal(ByRef num)

-Range("A402").Clear

-Range("B402").Clear

-Range("C402").Clear

-Range("D402").Clear

-Range("A402").Value = "xlPivotCellGrandTotal"

-Range("B402").Value = 3

-Range("C402").Value = num

-B402 = Range("B402").Value

-C402 = Range("C402").Value

-If B402 = C402 Then

-Range("D402").Value = "OK"

-Else

-Range("D402").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotCellPageFieldItem(ByRef num)

-Range("A403").Clear

-Range("B403").Clear

-Range("C403").Clear

-Range("D403").Clear

-Range("A403").Value = "xlPivotCellPageFieldItem"

-Range("B403").Value = 6

-Range("C403").Value = num

-B403 = Range("B403").Value

-C403 = Range("C403").Value

-If B403 = C403 Then

-Range("D403").Value = "OK"

-Else

-Range("D403").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotCellPivotField(ByRef num)

-Range("A404").Clear

-Range("B404").Clear

-Range("C404").Clear

-Range("D404").Clear

-Range("A404").Value = "xlPivotCellPivotField"

-Range("B404").Value = 5

-Range("C404").Value = num

-B404 = Range("B404").Value

-C404 = Range("C404").Value

-If B404 = C404 Then

-Range("D404").Value = "OK"

-Else

-Range("D404").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotCellPivotItem(ByRef num)

-Range("A405").Clear

-Range("B405").Clear

-Range("C405").Clear

-Range("D405").Clear

-Range("A405").Value = "xlPivotCellPivotItem"

-Range("B405").Value = 1

-Range("C405").Value = num

-B405 = Range("B405").Value

-C405 = Range("C405").Value

-If B405 = C405 Then

-Range("D405").Value = "OK"

-Else

-Range("D405").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotCellSubtotal(ByRef num)

-Range("A406").Clear

-Range("B406").Clear

-Range("C406").Clear

-Range("D406").Clear

-Range("A406").Value = "xlPivotCellSubtotal"

-Range("B406").Value = 2

-Range("C406").Value = num

-B406 = Range("B406").Value

-C406 = Range("C406").Value

-If B406 = C406 Then

-Range("D406").Value = "OK"

-Else

-Range("D406").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotCellValue(ByRef num)

-Range("A407").Clear

-Range("B407").Clear

-Range("C407").Clear

-Range("D407").Clear

-Range("A407").Value = "xlPivotCellValue"

-Range("B407").Value = 0

-Range("C407").Value = num

-B407 = Range("B407").Value

-C407 = Range("C407").Value

-If B407 = C407 Then

-Range("D407").Value = "OK"

-Else

-Range("D407").Value = "NG"

-End If

-End Function

-

-Function test_xlDifferenceFrom(ByRef num)

-Range("A408").Clear

-Range("B408").Clear

-Range("C408").Clear

-Range("D408").Clear

-Range("A408").Value = "xlDifferenceFrom"

-Range("B408").Value = 2

-Range("C408").Value = num

-B408 = Range("B408").Value

-C408 = Range("C408").Value

-If B408 = C408 Then

-Range("D408").Value = "OK"

-Else

-Range("D408").Value = "NG"

-End If

-End Function

-

-Function test_xlIndex(ByRef num)

-Range("A409").Clear

-Range("B409").Clear

-Range("C409").Clear

-Range("D409").Clear

-Range("A409").Value = "xlIndex"

-Range("B409").Value = 9

-Range("C409").Value = num

-B409 = Range("B409").Value

-C409 = Range("C409").Value

-If B409 = C409 Then

-Range("D409").Value = "OK"

-Else

-Range("D409").Value = "NG"

-End If

-End Function

-

-Function test_xlNoAdditionalCalculation(ByRef num)

-Range("A410").Clear

-Range("B410").Clear

-Range("C410").Clear

-Range("D410").Clear

-Range("A410").Value = "xlNoAdditionalCalculation"

-Range("B410").Value = -4143

-Range("C410").Value = num

-B410 = Range("B410").Value

-C410 = Range("C410").Value

-If B410 = C410 Then

-Range("D410").Value = "OK"

-Else

-Range("D410").Value = "NG"

-End If

-End Function

-

-Function test_xlPercentDifferenceFrom(ByRef num)

-Range("A411").Clear

-Range("B411").Clear

-Range("C411").Clear

-Range("D411").Clear

-Range("A411").Value = "xlPercentDifferenceFrom"

-Range("B411").Value = 4

-Range("C411").Value = num

-B411 = Range("B411").Value

-C411 = Range("C411").Value

-If B411 = C411 Then

-Range("D411").Value = "OK"

-Else

-Range("D411").Value = "NG"

-End If

-End Function

-

-Function test_xlPercentOf(ByRef num)

-Range("A412").Clear

-Range("B412").Clear

-Range("C412").Clear

-Range("D412").Clear

-Range("A412").Value = "xlPercentOf"

-Range("B412").Value = 3

-Range("C412").Value = num

-B412 = Range("B412").Value

-C412 = Range("C412").Value

-If B412 = C412 Then

-Range("D412").Value = "OK"

-Else

-Range("D412").Value = "NG"

-End If

-End Function

-

-Function test_xlPercentOfColumn(ByRef num)

-Range("A413").Clear

-Range("B413").Clear

-Range("C413").Clear

-Range("D413").Clear

-Range("A413").Value = "xlPercentOfColumn"

-Range("B413").Value = 7

-Range("C413").Value = num

-B413 = Range("B413").Value

-C413 = Range("C413").Value

-If B413 = C413 Then

-Range("D413").Value = "OK"

-Else

-Range("D413").Value = "NG"

-End If

-End Function

-

-Function test_xlPercentOfRow(ByRef num)

-Range("A414").Clear

-Range("B414").Clear

-Range("C414").Clear

-Range("D414").Clear

-Range("A414").Value = "xlPercentOfRow"

-Range("B414").Value = 6

-Range("C414").Value = num

-B414 = Range("B414").Value

-C414 = Range("C414").Value

-If B414 = C414 Then

-Range("D414").Value = "OK"

-Else

-Range("D414").Value = "NG"

-End If

-End Function

-

-Function test_xlPercentOfTotal(ByRef num)

-Range("A415").Clear

-Range("B415").Clear

-Range("C415").Clear

-Range("D415").Clear

-Range("A415").Value = "xlPercentOfTotal"

-Range("B415").Value = 8

-Range("C415").Value = num

-B415 = Range("B415").Value

-C415 = Range("C415").Value

-If B415 = C415 Then

-Range("D415").Value = "OK"

-Else

-Range("D415").Value = "NG"

-End If

-End Function

-

-Function test_xlRunningTotal(ByRef num)

-Range("A416").Clear

-Range("B416").Clear

-Range("C416").Clear

-Range("D416").Clear

-Range("A416").Value = "xlRunningTotal"

-Range("B416").Value = 5

-Range("C416").Value = num

-B416 = Range("B416").Value

-C416 = Range("C416").Value

-If B416 = C416 Then

-Range("D416").Value = "OK"

-Else

-Range("D416").Value = "NG"

-End If

-End Function

-

-Function test_xlDate(ByRef num)

-Range("A417").Clear

-Range("B417").Clear

-Range("C417").Clear

-Range("D417").Clear

-Range("A417").Value = "xlDate"

-Range("B417").Value = 2

-Range("C417").Value = num

-B417 = Range("B417").Value

-C417 = Range("C417").Value

-If B417 = C417 Then

-Range("D417").Value = "OK"

-Else

-Range("D417").Value = "NG"

-End If

-End Function

-

-Function test_xlNumber(ByRef num)

-Range("A418").Clear

-Range("B418").Clear

-Range("C418").Clear

-Range("D418").Clear

-Range("A418").Value = "xlNumber"

-Range("B418").Value = -4145

-Range("C418").Value = num

-B418 = Range("B418").Value

-C418 = Range("C418").Value

-If B418 = C418 Then

-Range("D418").Value = "OK"

-Else

-Range("D418").Value = "NG"

-End If

-End Function

-

-Function test_xlText(ByRef num)

-Range("A419").Clear

-Range("B419").Clear

-Range("C419").Clear

-Range("D419").Clear

-Range("A419").Value = "xlText"

-Range("B419").Value = -4158

-Range("C419").Value = num

-B419 = Range("B419").Value

-C419 = Range("C419").Value

-If B419 = C419 Then

-Range("D419").Value = "OK"

-Else

-Range("D419").Value = "NG"

-End If

-End Function

-

-Function test_xlColumnField(ByRef num)

-Range("A420").Clear

-Range("B420").Clear

-Range("C420").Clear

-Range("D420").Clear

-Range("A420").Value = "xlColumnField"

-Range("B420").Value = 2

-Range("C420").Value = num

-B420 = Range("B420").Value

-C420 = Range("C420").Value

-If B420 = C420 Then

-Range("D420").Value = "OK"

-Else

-Range("D420").Value = "NG"

-End If

-End Function

-

-Function test_xlDataField(ByRef num)

-Range("A421").Clear

-Range("B421").Clear

-Range("C421").Clear

-Range("D421").Clear

-Range("A421").Value = "xlDataField"

-Range("B421").Value = 4

-Range("C421").Value = num

-B421 = Range("B421").Value

-C421 = Range("C421").Value

-If B421 = C421 Then

-Range("D421").Value = "OK"

-Else

-Range("D421").Value = "NG"

-End If

-End Function

-

-Function test_xlHidden(ByRef num)

-Range("A422").Clear

-Range("B422").Clear

-Range("C422").Clear

-Range("D422").Clear

-Range("A422").Value = "xlHidden"

-Range("B422").Value = 0

-Range("C422").Value = num

-B422 = Range("B422").Value

-C422 = Range("C422").Value

-If B422 = C422 Then

-Range("D422").Value = "OK"

-Else

-Range("D422").Value = "NG"

-End If

-End Function

-

-Function test_xlPageField(ByRef num)

-Range("A423").Clear

-Range("B423").Clear

-Range("C423").Clear

-Range("D423").Clear

-Range("A423").Value = "xlPageField"

-Range("B423").Value = 3

-Range("C423").Value = num

-B423 = Range("B423").Value

-C423 = Range("C423").Value

-If B423 = C423 Then

-Range("D423").Value = "OK"

-Else

-Range("D423").Value = "NG"

-End If

-End Function

-

-Function test_xlRowField(ByRef num)

-Range("A424").Clear

-Range("B424").Clear

-Range("C424").Clear

-Range("D424").Clear

-Range("A424").Value = "xlRowField"

-Range("B424").Value = 1

-Range("C424").Value = num

-B424 = Range("B424").Value

-C424 = Range("C424").Value

-If B424 = C424 Then

-Range("D424").Value = "OK"

-Else

-Range("D424").Value = "NG"

-End If

-End Function

-

-Function test_xlPTClassic(ByRef num)

-Range("A425").Clear

-Range("B425").Clear

-Range("C425").Clear

-Range("D425").Clear

-Range("A425").Value = "xlPTClassic"

-Range("B425").Value = 20

-Range("C425").Value = num

-B425 = Range("B425").Value

-C425 = Range("C425").Value

-If B425 = C425 Then

-Range("D425").Value = "OK"

-Else

-Range("D425").Value = "NG"

-End If

-End Function

-

-Function test_xlPTNone(ByRef num)

-Range("A426").Clear

-Range("B426").Clear

-Range("C426").Clear

-Range("D426").Clear

-Range("A426").Value = "xlPTNone"

-Range("B426").Value = 21

-Range("C426").Value = num

-B426 = Range("B426").Value

-C426 = Range("C426").Value

-If B426 = C426 Then

-Range("D426").Value = "OK"

-Else

-Range("D426").Value = "NG"

-End If

-End Function

-

-Function test_xlReport1(ByRef num)

-Range("A427").Clear

-Range("B427").Clear

-Range("C427").Clear

-Range("D427").Clear

-Range("A427").Value = "xlReport1"

-Range("B427").Value = 0

-Range("C427").Value = num

-B427 = Range("B427").Value

-C427 = Range("C427").Value

-If B427 = C427 Then

-Range("D427").Value = "OK"

-Else

-Range("D427").Value = "NG"

-End If

-End Function

-

-Function test_xlReport10(ByRef num)

-Range("A428").Clear

-Range("B428").Clear

-Range("C428").Clear

-Range("D428").Clear

-Range("A428").Value = "xlReport10"

-Range("B428").Value = 9

-Range("C428").Value = num

-B428 = Range("B428").Value

-C428 = Range("C428").Value

-If B428 = C428 Then

-Range("D428").Value = "OK"

-Else

-Range("D428").Value = "NG"

-End If

-End Function

-

-Function test_xlReport2(ByRef num)

-Range("A429").Clear

-Range("B429").Clear

-Range("C429").Clear

-Range("D429").Clear

-Range("A429").Value = "xlReport2"

-Range("B429").Value = 1

-Range("C429").Value = num

-B429 = Range("B429").Value

-C429 = Range("C429").Value

-If B429 = C429 Then

-Range("D429").Value = "OK"

-Else

-Range("D429").Value = "NG"

-End If

-End Function

-

-Function test_xlReport3(ByRef num)

-Range("A430").Clear

-Range("B430").Clear

-Range("C430").Clear

-Range("D430").Clear

-Range("A430").Value = "xlReport3"

-Range("B430").Value = 2

-Range("C430").Value = num

-B430 = Range("B430").Value

-C430 = Range("C430").Value

-If B430 = C430 Then

-Range("D430").Value = "OK"

-Else

-Range("D430").Value = "NG"

-End If

-End Function

-

-Function test_xlReport4(ByRef num)

-Range("A431").Clear

-Range("B431").Clear

-Range("C431").Clear

-Range("D431").Clear

-Range("A431").Value = "xlReport4"

-Range("B431").Value = 3

-Range("C431").Value = num

-B431 = Range("B431").Value

-C431 = Range("C431").Value

-If B431 = C431 Then

-Range("D431").Value = "OK"

-Else

-Range("D431").Value = "NG"

-End If

-End Function

-

-Function test_xlReport5(ByRef num)

-Range("A432").Clear

-Range("B432").Clear

-Range("C432").Clear

-Range("D432").Clear

-Range("A432").Value = "xlReport5"

-Range("B432").Value = 4

-Range("C432").Value = num

-B432 = Range("B432").Value

-C432 = Range("C432").Value

-If B432 = C432 Then

-Range("D432").Value = "OK"

-Else

-Range("D432").Value = "NG"

-End If

-End Function

-

-Function test_xlReport6(ByRef num)

-Range("A433").Clear

-Range("B433").Clear

-Range("C433").Clear

-Range("D433").Clear

-Range("A433").Value = "xlReport6"

-Range("B433").Value = 5

-Range("C433").Value = num

-B433 = Range("B433").Value

-C433 = Range("C433").Value

-If B433 = C433 Then

-Range("D433").Value = "OK"

-Else

-Range("D433").Value = "NG"

-End If

-End Function

-

-Function test_xlReport7(ByRef num)

-Range("A434").Clear

-Range("B434").Clear

-Range("C434").Clear

-Range("D434").Clear

-Range("A434").Value = "xlReport7"

-Range("B434").Value = 6

-Range("C434").Value = num

-B434 = Range("B434").Value

-C434 = Range("C434").Value

-If B434 = C434 Then

-Range("D434").Value = "OK"

-Else

-Range("D434").Value = "NG"

-End If

-End Function

-

-Function test_xlReport8(ByRef num)

-Range("A435").Clear

-Range("B435").Clear

-Range("C435").Clear

-Range("D435").Clear

-Range("A435").Value = "xlReport8"

-Range("B435").Value = 7

-Range("C435").Value = num

-B435 = Range("B435").Value

-C435 = Range("C435").Value

-If B435 = C435 Then

-Range("D435").Value = "OK"

-Else

-Range("D435").Value = "NG"

-End If

-End Function

-

-Function test_xlReport9(ByRef num)

-Range("A436").Clear

-Range("B436").Clear

-Range("C436").Clear

-Range("D436").Clear

-Range("A436").Value = "xlReport9"

-Range("B436").Value = 8

-Range("C436").Value = num

-B436 = Range("B436").Value

-C436 = Range("C436").Value

-If B436 = C436 Then

-Range("D436").Value = "OK"

-Else

-Range("D436").Value = "NG"

-End If

-End Function

-

-Function test_xlTable1(ByRef num)

-Range("A437").Clear

-Range("B437").Clear

-Range("C437").Clear

-Range("D437").Clear

-Range("A437").Value = "xlTable1"

-Range("B437").Value = 10

-Range("C437").Value = num

-B437 = Range("B437").Value

-C437 = Range("C437").Value

-If B437 = C437 Then

-Range("D437").Value = "OK"

-Else

-Range("D437").Value = "NG"

-End If

-End Function

-

-Function test_xlTable10(ByRef num)

-Range("A438").Clear

-Range("B438").Clear

-Range("C438").Clear

-Range("D438").Clear

-Range("A438").Value = "xlTable10"

-Range("B438").Value = 19

-Range("C438").Value = num

-B438 = Range("B438").Value

-C438 = Range("C438").Value

-If B438 = C438 Then

-Range("D438").Value = "OK"

-Else

-Range("D438").Value = "NG"

-End If

-End Function

-

-Function test_xlTable2(ByRef num)

-Range("A439").Clear

-Range("B439").Clear

-Range("C439").Clear

-Range("D439").Clear

-Range("A439").Value = "xlTable2"

-Range("B439").Value = 11

-Range("C439").Value = num

-B439 = Range("B439").Value

-C439 = Range("C439").Value

-If B439 = C439 Then

-Range("D439").Value = "OK"

-Else

-Range("D439").Value = "NG"

-End If

-End Function

-

-Function test_xlTable3(ByRef num)

-Range("A440").Clear

-Range("B440").Clear

-Range("C440").Clear

-Range("D440").Clear

-Range("A440").Value = "xlTable3"

-Range("B440").Value = 12

-Range("C440").Value = num

-B440 = Range("B440").Value

-C440 = Range("C440").Value

-If B440 = C440 Then

-Range("D440").Value = "OK"

-Else

-Range("D440").Value = "NG"

-End If

-End Function

-

-Function test_xlTable4(ByRef num)

-Range("A441").Clear

-Range("B441").Clear

-Range("C441").Clear

-Range("D441").Clear

-Range("A441").Value = "xlTable4"

-Range("B441").Value = 13

-Range("C441").Value = num

-B441 = Range("B441").Value

-C441 = Range("C441").Value

-If B441 = C441 Then

-Range("D441").Value = "OK"

-Else

-Range("D441").Value = "NG"

-End If

-End Function

-

-Function test_xlTable5(ByRef num)

-Range("A442").Clear

-Range("B442").Clear

-Range("C442").Clear

-Range("D442").Clear

-Range("A442").Value = "xlTable5"

-Range("B442").Value = 14

-Range("C442").Value = num

-B442 = Range("B442").Value

-C442 = Range("C442").Value

-If B442 = C442 Then

-Range("D442").Value = "OK"

-Else

-Range("D442").Value = "NG"

-End If

-End Function

-

-Function test_xlTable6(ByRef num)

-Range("A443").Clear

-Range("B443").Clear

-Range("C443").Clear

-Range("D443").Clear

-Range("A443").Value = "xlTable6"

-Range("B443").Value = 15

-Range("C443").Value = num

-B443 = Range("B443").Value

-C443 = Range("C443").Value

-If B443 = C443 Then

-Range("D443").Value = "OK"

-Else

-Range("D443").Value = "NG"

-End If

-End Function

-

-Function test_xlTable7(ByRef num)

-Range("A444").Clear

-Range("B444").Clear

-Range("C444").Clear

-Range("D444").Clear

-Range("A444").Value = "xlTable7"

-Range("B444").Value = 16

-Range("C444").Value = num

-B444 = Range("B444").Value

-C444 = Range("C444").Value

-If B444 = C444 Then

-Range("D444").Value = "OK"

-Else

-Range("D444").Value = "NG"

-End If

-End Function

-

-Function test_xlTable8(ByRef num)

-Range("A445").Clear

-Range("B445").Clear

-Range("C445").Clear

-Range("D445").Clear

-Range("A445").Value = "xlTable8"

-Range("B445").Value = 17

-Range("C445").Value = num

-B445 = Range("B445").Value

-C445 = Range("C445").Value

-If B445 = C445 Then

-Range("D445").Value = "OK"

-Else

-Range("D445").Value = "NG"

-End If

-End Function

-

-Function test_xlTable9(ByRef num)

-Range("A446").Clear

-Range("B446").Clear

-Range("C446").Clear

-Range("D446").Clear

-Range("A446").Value = "xlTable9"

-Range("B446").Value = 18

-Range("C446").Value = num

-B446 = Range("B446").Value

-C446 = Range("C446").Value

-If B446 = C446 Then

-Range("D446").Value = "OK"

-Else

-Range("D446").Value = "NG"

-End If

-End Function

-

-Function test_xlMissingItemsDefault(ByRef num)

-Range("A447").Clear

-Range("B447").Clear

-Range("C447").Clear

-Range("D447").Clear

-Range("A447").Value = "xlMissingItemsDefault"

-Range("B447").Value = -1

-Range("C447").Value = num

-B447 = Range("B447").Value

-C447 = Range("C447").Value

-If B447 = C447 Then

-Range("D447").Value = "OK"

-Else

-Range("D447").Value = "NG"

-End If

-End Function

-

-Function test_xlMissingItemsMax(ByRef num)

-Range("A448").Clear

-Range("B448").Clear

-Range("C448").Clear

-Range("D448").Clear

-Range("A448").Value = "xlMissingItemsMax"

-Range("B448").Value = 32500

-Range("C448").Value = num

-B448 = Range("B448").Value

-C448 = Range("C448").Value

-If B448 = C448 Then

-Range("D448").Value = "OK"

-Else

-Range("D448").Value = "NG"

-End If

-End Function

-

-Function test_xlMissingItemsNone(ByRef num)

-Range("A449").Clear

-Range("B449").Clear

-Range("C449").Clear

-Range("D449").Clear

-Range("A449").Value = "xlMissingItemsNone"

-Range("B449").Value = 0

-Range("C449").Value = num

-B449 = Range("B449").Value

-C449 = Range("C449").Value

-If B449 = C449 Then

-Range("D449").Value = "OK"

-Else

-Range("D449").Value = "NG"

-End If

-End Function

-

-Function test_xlConsolidation(ByRef num)

-Range("A450").Clear

-Range("B450").Clear

-Range("C450").Clear

-Range("D450").Clear

-Range("A450").Value = "xlConsolidation"

-Range("B450").Value = 3

-Range("C450").Value = num

-B450 = Range("B450").Value

-C450 = Range("C450").Value

-If B450 = C450 Then

-Range("D450").Value = "OK"

-Else

-Range("D450").Value = "NG"

-End If

-End Function

-

-Function test_xlDatabase(ByRef num)

-Range("A451").Clear

-Range("B451").Clear

-Range("C451").Clear

-Range("D451").Clear

-Range("A451").Value = "xlDatabase"

-Range("B451").Value = 1

-Range("C451").Value = num

-B451 = Range("B451").Value

-C451 = Range("C451").Value

-If B451 = C451 Then

-Range("D451").Value = "OK"

-Else

-Range("D451").Value = "NG"

-End If

-End Function

-

-Function test_xlExternal(ByRef num)

-Range("A452").Clear

-Range("B452").Clear

-Range("C452").Clear

-Range("D452").Clear

-Range("A452").Value = "xlExternal"

-Range("B452").Value = 2

-Range("C452").Value = num

-B452 = Range("B452").Value

-C452 = Range("C452").Value

-If B452 = C452 Then

-Range("D452").Value = "OK"

-Else

-Range("D452").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotTable(ByRef num)

-Range("A453").Clear

-Range("B453").Clear

-Range("C453").Clear

-Range("D453").Clear

-Range("A453").Value = "xlPivotTable"

-Range("B453").Value = -4148

-Range("C453").Value = num

-B453 = Range("B453").Value

-C453 = Range("C453").Value

-If B453 = C453 Then

-Range("D453").Value = "OK"

-Else

-Range("D453").Value = "NG"

-End If

-End Function

-

-Function test_xlScenario(ByRef num)

-Range("A454").Clear

-Range("B454").Clear

-Range("C454").Clear

-Range("D454").Clear

-Range("A454").Value = "xlScenario"

-Range("B454").Value = 4

-Range("C454").Value = num

-B454 = Range("B454").Value

-C454 = Range("C454").Value

-If B454 = C454 Then

-Range("D454").Value = "OK"

-Else

-Range("D454").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotTableVersion10(ByRef num)

-Range("A455").Clear

-Range("B455").Clear

-Range("C455").Clear

-Range("D455").Clear

-Range("A455").Value = "xlPivotTableVersion10"

-Range("B455").Value = 1

-Range("C455").Value = num

-B455 = Range("B455").Value

-C455 = Range("C455").Value

-If B455 = C455 Then

-Range("D455").Value = "OK"

-Else

-Range("D455").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotTableVersion2000(ByRef num)

-Range("A456").Clear

-Range("B456").Clear

-Range("C456").Clear

-Range("D456").Clear

-Range("A456").Value = "xlPivotTableVersion2000"

-Range("B456").Value = 0

-Range("C456").Value = num

-B456 = Range("B456").Value

-C456 = Range("C456").Value

-If B456 = C456 Then

-Range("D456").Value = "OK"

-Else

-Range("D456").Value = "NG"

-End If

-End Function

-

-Function test_xlPivotTableCurrent(ByRef num)

-Range("A457").Clear

-Range("B457").Clear

-Range("C457").Clear

-Range("D457").Clear

-Range("A457").Value = "xlPivotTableCurrent"

-Range("B457").Value = -1

-Range("C457").Value = num

-B457 = Range("B457").Value

-C457 = Range("C457").Value

-If B457 = C457 Then

-Range("D457").Value = "OK"

-Else

-Range("D457").Value = "NG"

-End If

-End Function

-

-Function test_xlFreeFloating(ByRef num)

-Range("A458").Clear

-Range("B458").Clear

-Range("C458").Clear

-Range("D458").Clear

-Range("A458").Value = "xlFreeFloating"

-Range("B458").Value = 3

-Range("C458").Value = num

-B458 = Range("B458").Value

-C458 = Range("C458").Value

-If B458 = C458 Then

-Range("D458").Value = "OK"

-Else

-Range("D458").Value = "NG"

-End If

-End Function

-

-Function test_xlMove(ByRef num)

-Range("A459").Clear

-Range("B459").Clear

-Range("C459").Clear

-Range("D459").Clear

-Range("A459").Value = "xlMove"

-Range("B459").Value = 2

-Range("C459").Value = num

-B459 = Range("B459").Value

-C459 = Range("C459").Value

-If B459 = C459 Then

-Range("D459").Value = "OK"

-Else

-Range("D459").Value = "NG"

-End If

-End Function

-

-Function test_xlMoveAndSize(ByRef num)

-Range("A460").Clear

-Range("B460").Clear

-Range("C460").Clear

-Range("D460").Clear

-Range("A460").Value = "xlMoveAndSize"

-Range("B460").Value = 1

-Range("C460").Value = num

-B460 = Range("B460").Value

-C460 = Range("C460").Value

-If B460 = C460 Then

-Range("D460").Value = "OK"

-Else

-Range("D460").Value = "NG"

-End If

-End Function

-

-Function test_xlMacintosh(ByRef num)

-Range("A461").Clear

-Range("B461").Clear

-Range("C461").Clear

-Range("D461").Clear

-Range("A461").Value = "xlMacintosh"

-Range("B461").Value = 1

-Range("C461").Value = num

-B461 = Range("B461").Value

-C461 = Range("C461").Value

-If B461 = C461 Then

-Range("D461").Value = "OK"

-Else

-Range("D461").Value = "NG"

-End If

-End Function

-

-Function test_xlMSDOS(ByRef num)

-Range("A462").Clear

-Range("B462").Clear

-Range("C462").Clear

-Range("D462").Clear

-Range("A462").Value = "xlMSDOS"

-Range("B462").Value = 3

-Range("C462").Value = num

-B462 = Range("B462").Value

-C462 = Range("C462").Value

-If B462 = C462 Then

-Range("D462").Value = "OK"

-Else

-Range("D462").Value = "NG"

-End If

-End Function

-

-Function test_xlWindows(ByRef num)

-Range("A463").Clear

-Range("B463").Clear

-Range("C463").Clear

-Range("D463").Clear

-Range("A463").Value = "xlWindows"

-Range("B463").Value = 2

-Range("C463").Value = num

-B463 = Range("B463").Value

-C463 = Range("C463").Value

-If B463 = C463 Then

-Range("D463").Value = "OK"

-Else

-Range("D463").Value = "NG"

-End If

-End Function

-

-Function test_xlPrintErrorsBlank(ByRef num)

-Range("A464").Clear

-Range("B464").Clear

-Range("C464").Clear

-Range("D464").Clear

-Range("A464").Value = "xlPrintErrorsBlank"

-Range("B464").Value = 1

-Range("C464").Value = num

-B464 = Range("B464").Value

-C464 = Range("C464").Value

-If B464 = C464 Then

-Range("D464").Value = "OK"

-Else

-Range("D464").Value = "NG"

-End If

-End Function

-

-Function test_xlPrintErrorsDash(ByRef num)

-Range("A465").Clear

-Range("B465").Clear

-Range("C465").Clear

-Range("D465").Clear

-Range("A465").Value = "xlPrintErrorsDash"

-Range("B465").Value = 2

-Range("C465").Value = num

-B465 = Range("B465").Value

-C465 = Range("C465").Value

-If B465 = C465 Then

-Range("D465").Value = "OK"

-Else

-Range("D465").Value = "NG"

-End If

-End Function

-

-Function test_xlPrintErrorsDisplayed(ByRef num)

-Range("A466").Clear

-Range("B466").Clear

-Range("C466").Clear

-Range("D466").Clear

-Range("A466").Value = "xlPrintErrorsDisplayed"

-Range("B466").Value = 0

-Range("C466").Value = num

-B466 = Range("B466").Value

-C466 = Range("C466").Value

-If B466 = C466 Then

-Range("D466").Value = "OK"

-Else

-Range("D466").Value = "NG"

-End If

-End Function

-

-Function test_xlPrintErrorsNA(ByRef num)

-Range("A467").Clear

-Range("B467").Clear

-Range("C467").Clear

-Range("D467").Clear

-Range("A467").Value = "xlPrintErrorsNA"

-Range("B467").Value = 3

-Range("C467").Value = num

-B467 = Range("B467").Value

-C467 = Range("C467").Value

-If B467 = C467 Then

-Range("D467").Value = "OK"

-Else

-Range("D467").Value = "NG"

-End If

-End Function

-

-Function test_xlPrintLocation(ByRef num)

-Range("A468").Clear

-Range("B468").Clear

-Range("C468").Clear

-Range("D468").Clear

-Range("A468").Value = "xlPrintLocation"

-Range("B468").Value = 16

-Range("C468").Value = num

-B468 = Range("B468").Value

-C468 = Range("C468").Value

-If B468 = C468 Then

-Range("D468").Value = "OK"

-Else

-Range("D468").Value = "NG"

-End If

-End Function

-

-Function test_xlPrintNoComments(ByRef num)

-Range("A469").Clear

-Range("B469").Clear

-Range("C469").Clear

-Range("D469").Clear

-Range("A469").Value = "xlPrintNoComments"

-Range("B469").Value = -4142

-Range("C469").Value = num

-B469 = Range("B469").Value

-C469 = Range("C469").Value

-If B469 = C469 Then

-Range("D469").Value = "OK"

-Else

-Range("D469").Value = "NG"

-End If

-End Function

-

-Function test_xlPrintSheetEnd(ByRef num)

-Range("A470").Clear

-Range("B470").Clear

-Range("C470").Clear

-Range("D470").Clear

-Range("A470").Value = "xlPrintSheetEnd"

-Range("B470").Value = 1

-Range("C470").Value = num

-B470 = Range("B470").Value

-C470 = Range("C470").Value

-If B470 = C470 Then

-Range("D470").Value = "OK"

-Else

-Range("D470").Value = "NG"

-End If

-End Function

-

-Function test_xlPriorityHigh(ByRef num)

-Range("A471").Clear

-Range("B471").Clear

-Range("C471").Clear

-Range("D471").Clear

-Range("A471").Value = "xlPriorityHigh"

-Range("B471").Value = -4127

-Range("C471").Value = num

-B471 = Range("B471").Value

-C471 = Range("C471").Value

-If B471 = C471 Then

-Range("D471").Value = "OK"

-Else

-Range("D471").Value = "NG"

-End If

-End Function

-

-Function test_xlPriorityLow(ByRef num)

-Range("A472").Clear

-Range("B472").Clear

-Range("C472").Clear

-Range("D472").Clear

-Range("A472").Value = "xlPriorityLow"

-Range("B472").Value = -4134

-Range("C472").Value = num

-B472 = Range("B472").Value

-C472 = Range("C472").Value

-If B472 = C472 Then

-Range("D472").Value = "OK"

-Else

-Range("D472").Value = "NG"

-End If

-End Function

-

-Function test_xlPriorityNormal(ByRef num)

-Range("A473").Clear

-Range("B473").Clear

-Range("C473").Clear

-Range("D473").Clear

-Range("A473").Value = "xlPriorityNormal"

-Range("B473").Value = -4143

-Range("C473").Value = num

-B473 = Range("B473").Value

-C473 = Range("C473").Value

-If B473 = C473 Then

-Range("D473").Value = "OK"

-Else

-Range("D473").Value = "NG"

-End If

-End Function

-

-Function test_xlADORecordset(ByRef num)

-Range("A474").Clear

-Range("B474").Clear

-Range("C474").Clear

-Range("D474").Clear

-Range("A474").Value = "xlADORecordset"

-Range("B474").Value = 7

-Range("C474").Value = num

-B474 = Range("B474").Value

-C474 = Range("C474").Value

-If B474 = C474 Then

-Range("D474").Value = "OK"

-Else

-Range("D474").Value = "NG"

-End If

-End Function

-

-Function test_xlDAORecordset(ByRef num)

-Range("A475").Clear

-Range("B475").Clear

-Range("C475").Clear

-Range("D475").Clear

-Range("A475").Value = "xlDAORecordset"

-Range("B475").Value = 2

-Range("C475").Value = num

-B475 = Range("B475").Value

-C475 = Range("C475").Value

-If B475 = C475 Then

-Range("D475").Value = "OK"

-Else

-Range("D475").Value = "NG"

-End If

-End Function

-

-Function test_xlODBCQuery(ByRef num)

-Range("A476").Clear

-Range("B476").Clear

-Range("C476").Clear

-Range("D476").Clear

-Range("A476").Value = "xlODBCQuery"

-Range("B476").Value = 1

-Range("C476").Value = num

-B476 = Range("B476").Value

-C476 = Range("C476").Value

-If B476 = C476 Then

-Range("D476").Value = "OK"

-Else

-Range("D476").Value = "NG"

-End If

-End Function

-

-Function test_xlOLEDBQuery(ByRef num)

-Range("A477").Clear

-Range("B477").Clear

-Range("C477").Clear

-Range("D477").Clear

-Range("A477").Value = "xlOLEDBQuery"

-Range("B477").Value = 5

-Range("C477").Value = num

-B477 = Range("B477").Value

-C477 = Range("C477").Value

-If B477 = C477 Then

-Range("D477").Value = "OK"

-Else

-Range("D477").Value = "NG"

-End If

-End Function

-

-Function test_xlTextImport(ByRef num)

-Range("A478").Clear

-Range("B478").Clear

-Range("C478").Clear

-Range("D478").Clear

-Range("A478").Value = "xlTextImport"

-Range("B478").Value = 6

-Range("C478").Value = num

-B478 = Range("B478").Value

-C478 = Range("C478").Value

-If B478 = C478 Then

-Range("D478").Value = "OK"

-Else

-Range("D478").Value = "NG"

-End If

-End Function

-

-Function test_xlWebQuery(ByRef num)

-Range("A479").Clear

-Range("B479").Clear

-Range("C479").Clear

-Range("D479").Clear

-Range("A479").Value = "xlWebQuery"

-Range("B479").Value = 4

-Range("C479").Value = num

-B479 = Range("B479").Value

-C479 = Range("C479").Value

-If B479 = C479 Then

-Range("D479").Value = "OK"

-Else

-Range("D479").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormat3DEffects1(ByRef num)

-Range("A480").Clear

-Range("B480").Clear

-Range("C480").Clear

-Range("D480").Clear

-Range("A480").Value = "xlRangeAutoFormat3DEffects1"

-Range("B480").Value = 13

-Range("C480").Value = num

-B480 = Range("B480").Value

-C480 = Range("C480").Value

-If B480 = C480 Then

-Range("D480").Value = "OK"

-Else

-Range("D480").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormat3DEffects2(ByRef num)

-Range("A481").Clear

-Range("B481").Clear

-Range("C481").Clear

-Range("D481").Clear

-Range("A481").Value = "xlRangeAutoFormat3DEffects2"

-Range("B481").Value = 14

-Range("C481").Value = num

-B481 = Range("B481").Value

-C481 = Range("C481").Value

-If B481 = C481 Then

-Range("D481").Value = "OK"

-Else

-Range("D481").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatAccounting1(ByRef num)

-Range("A482").Clear

-Range("B482").Clear

-Range("C482").Clear

-Range("D482").Clear

-Range("A482").Value = "xlRangeAutoFormatAccounting1"

-Range("B482").Value = 4

-Range("C482").Value = num

-B482 = Range("B482").Value

-C482 = Range("C482").Value

-If B482 = C482 Then

-Range("D482").Value = "OK"

-Else

-Range("D482").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatAccounting2(ByRef num)

-Range("A483").Clear

-Range("B483").Clear

-Range("C483").Clear

-Range("D483").Clear

-Range("A483").Value = "xlRangeAutoFormatAccounting2"

-Range("B483").Value = 5

-Range("C483").Value = num

-B483 = Range("B483").Value

-C483 = Range("C483").Value

-If B483 = C483 Then

-Range("D483").Value = "OK"

-Else

-Range("D483").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatAccounting3(ByRef num)

-Range("A484").Clear

-Range("B484").Clear

-Range("C484").Clear

-Range("D484").Clear

-Range("A484").Value = "xlRangeAutoFormatAccounting3"

-Range("B484").Value = 6

-Range("C484").Value = num

-B484 = Range("B484").Value

-C484 = Range("C484").Value

-If B484 = C484 Then

-Range("D484").Value = "OK"

-Else

-Range("D484").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatAccounting4(ByRef num)

-Range("A485").Clear

-Range("B485").Clear

-Range("C485").Clear

-Range("D485").Clear

-Range("A485").Value = "xlRangeAutoFormatAccounting4"

-Range("B485").Value = 17

-Range("C485").Value = num

-B485 = Range("B485").Value

-C485 = Range("C485").Value

-If B485 = C485 Then

-Range("D485").Value = "OK"

-Else

-Range("D485").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatClassic1(ByRef num)

-Range("A486").Clear

-Range("B486").Clear

-Range("C486").Clear

-Range("D486").Clear

-Range("A486").Value = "xlRangeAutoFormatClassic1"

-Range("B486").Value = 1

-Range("C486").Value = num

-B486 = Range("B486").Value

-C486 = Range("C486").Value

-If B486 = C486 Then

-Range("D486").Value = "OK"

-Else

-Range("D486").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatClassic2(ByRef num)

-Range("A487").Clear

-Range("B487").Clear

-Range("C487").Clear

-Range("D487").Clear

-Range("A487").Value = "xlRangeAutoFormatClassic2"

-Range("B487").Value = 2

-Range("C487").Value = num

-B487 = Range("B487").Value

-C487 = Range("C487").Value

-If B487 = C487 Then

-Range("D487").Value = "OK"

-Else

-Range("D487").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatClassic3(ByRef num)

-Range("A488").Clear

-Range("B488").Clear

-Range("C488").Clear

-Range("D488").Clear

-Range("A488").Value = "xlRangeAutoFormatClassic3"

-Range("B488").Value = 3

-Range("C488").Value = num

-B488 = Range("B488").Value

-C488 = Range("C488").Value

-If B488 = C488 Then

-Range("D488").Value = "OK"

-Else

-Range("D488").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatClassicPivotTable(ByRef num)

-Range("A489").Clear

-Range("B489").Clear

-Range("C489").Clear

-Range("D489").Clear

-Range("A489").Value = "xlRangeAutoFormatClassicPivotTable"

-Range("B489").Value = 31

-Range("C489").Value = num

-B489 = Range("B489").Value

-C489 = Range("C489").Value

-If B489 = C489 Then

-Range("D489").Value = "OK"

-Else

-Range("D489").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatColor1(ByRef num)

-Range("A490").Clear

-Range("B490").Clear

-Range("C490").Clear

-Range("D490").Clear

-Range("A490").Value = "xlRangeAutoFormatColor1"

-Range("B490").Value = 7

-Range("C490").Value = num

-B490 = Range("B490").Value

-C490 = Range("C490").Value

-If B490 = C490 Then

-Range("D490").Value = "OK"

-Else

-Range("D490").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatColor2(ByRef num)

-Range("A491").Clear

-Range("B491").Clear

-Range("C491").Clear

-Range("D491").Clear

-Range("A491").Value = "xlRangeAutoFormatColor2"

-Range("B491").Value = 8

-Range("C491").Value = num

-B491 = Range("B491").Value

-C491 = Range("C491").Value

-If B491 = C491 Then

-Range("D491").Value = "OK"

-Else

-Range("D491").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatColor3(ByRef num)

-Range("A492").Clear

-Range("B492").Clear

-Range("C492").Clear

-Range("D492").Clear

-Range("A492").Value = "xlRangeAutoFormatColor3"

-Range("B492").Value = 9

-Range("C492").Value = num

-B492 = Range("B492").Value

-C492 = Range("C492").Value

-If B492 = C492 Then

-Range("D492").Value = "OK"

-Else

-Range("D492").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatList1(ByRef num)

-Range("A493").Clear

-Range("B493").Clear

-Range("C493").Clear

-Range("D493").Clear

-Range("A493").Value = "xlRangeAutoFormatList1"

-Range("B493").Value = 10

-Range("C493").Value = num

-B493 = Range("B493").Value

-C493 = Range("C493").Value

-If B493 = C493 Then

-Range("D493").Value = "OK"

-Else

-Range("D493").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatList2(ByRef num)

-Range("A494").Clear

-Range("B494").Clear

-Range("C494").Clear

-Range("D494").Clear

-Range("A494").Value = "xlRangeAutoFormatList2"

-Range("B494").Value = 11

-Range("C494").Value = num

-B494 = Range("B494").Value

-C494 = Range("C494").Value

-If B494 = C494 Then

-Range("D494").Value = "OK"

-Else

-Range("D494").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatList3(ByRef num)

-Range("A495").Clear

-Range("B495").Clear

-Range("C495").Clear

-Range("D495").Clear

-Range("A495").Value = "xlRangeAutoFormatList3"

-Range("B495").Value = 12

-Range("C495").Value = num

-B495 = Range("B495").Value

-C495 = Range("C495").Value

-If B495 = C495 Then

-Range("D495").Value = "OK"

-Else

-Range("D495").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatLocalFormat1(ByRef num)

-Range("A496").Clear

-Range("B496").Clear

-Range("C496").Clear

-Range("D496").Clear

-Range("A496").Value = "xlRangeAutoFormatLocalFormat1"

-Range("B496").Value = 15

-Range("C496").Value = num

-B496 = Range("B496").Value

-C496 = Range("C496").Value

-If B496 = C496 Then

-Range("D496").Value = "OK"

-Else

-Range("D496").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatLocalFormat2(ByRef num)

-Range("A497").Clear

-Range("B497").Clear

-Range("C497").Clear

-Range("D497").Clear

-Range("A497").Value = "xlRangeAutoFormatLocalFormat2"

-Range("B497").Value = 16

-Range("C497").Value = num

-B497 = Range("B497").Value

-C497 = Range("C497").Value

-If B497 = C497 Then

-Range("D497").Value = "OK"

-Else

-Range("D497").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatLocalFormat3(ByRef num)

-Range("A498").Clear

-Range("B498").Clear

-Range("C498").Clear

-Range("D498").Clear

-Range("A498").Value = "xlRangeAutoFormatLocalFormat3"

-Range("B498").Value = 19

-Range("C498").Value = num

-B498 = Range("B498").Value

-C498 = Range("C498").Value

-If B498 = C498 Then

-Range("D498").Value = "OK"

-Else

-Range("D498").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatLocalFormat4(ByRef num)

-Range("A499").Clear

-Range("B499").Clear

-Range("C499").Clear

-Range("D499").Clear

-Range("A499").Value = "xlRangeAutoFormatLocalFormat4"

-Range("B499").Value = 20

-Range("C499").Value = num

-B499 = Range("B499").Value

-C499 = Range("C499").Value

-If B499 = C499 Then

-Range("D499").Value = "OK"

-Else

-Range("D499").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatNone(ByRef num)

-Range("A500").Clear

-Range("B500").Clear

-Range("C500").Clear

-Range("D500").Clear

-Range("A500").Value = "xlRangeAutoFormatNone"

-Range("B500").Value = -4142

-Range("C500").Value = num

-B500 = Range("B500").Value

-C500 = Range("C500").Value

-If B500 = C500 Then

-Range("D500").Value = "OK"

-Else

-Range("D500").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatPTNone(ByRef num)

-Range("A501").Clear

-Range("B501").Clear

-Range("C501").Clear

-Range("D501").Clear

-Range("A501").Value = "xlRangeAutoFormatPTNone"

-Range("B501").Value = 42

-Range("C501").Value = num

-B501 = Range("B501").Value

-C501 = Range("C501").Value

-If B501 = C501 Then

-Range("D501").Value = "OK"

-Else

-Range("D501").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatReport1(ByRef num)

-Range("A502").Clear

-Range("B502").Clear

-Range("C502").Clear

-Range("D502").Clear

-Range("A502").Value = "xlRangeAutoFormatReport1"

-Range("B502").Value = 21

-Range("C502").Value = num

-B502 = Range("B502").Value

-C502 = Range("C502").Value

-If B502 = C502 Then

-Range("D502").Value = "OK"

-Else

-Range("D502").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatReport10(ByRef num)

-Range("A503").Clear

-Range("B503").Clear

-Range("C503").Clear

-Range("D503").Clear

-Range("A503").Value = "xlRangeAutoFormatReport10"

-Range("B503").Value = 30

-Range("C503").Value = num

-B503 = Range("B503").Value

-C503 = Range("C503").Value

-If B503 = C503 Then

-Range("D503").Value = "OK"

-Else

-Range("D503").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatReport2(ByRef num)

-Range("A504").Clear

-Range("B504").Clear

-Range("C504").Clear

-Range("D504").Clear

-Range("A504").Value = "xlRangeAutoFormatReport2"

-Range("B504").Value = 22

-Range("C504").Value = num

-B504 = Range("B504").Value

-C504 = Range("C504").Value

-If B504 = C504 Then

-Range("D504").Value = "OK"

-Else

-Range("D504").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatReport3(ByRef num)

-Range("A505").Clear

-Range("B505").Clear

-Range("C505").Clear

-Range("D505").Clear

-Range("A505").Value = "xlRangeAutoFormatReport3"

-Range("B505").Value = 23

-Range("C505").Value = num

-B505 = Range("B505").Value

-C505 = Range("C505").Value

-If B505 = C505 Then

-Range("D505").Value = "OK"

-Else

-Range("D505").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatReport4(ByRef num)

-Range("A506").Clear

-Range("B506").Clear

-Range("C506").Clear

-Range("D506").Clear

-Range("A506").Value = "xlRangeAutoFormatReport4"

-Range("B506").Value = 24

-Range("C506").Value = num

-B506 = Range("B506").Value

-C506 = Range("C506").Value

-If B506 = C506 Then

-Range("D506").Value = "OK"

-Else

-Range("D506").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatReport5(ByRef num)

-Range("A507").Clear

-Range("B507").Clear

-Range("C507").Clear

-Range("D507").Clear

-Range("A507").Value = "xlRangeAutoFormatReport5"

-Range("B507").Value = 25

-Range("C507").Value = num

-B507 = Range("B507").Value

-C507 = Range("C507").Value

-If B507 = C507 Then

-Range("D507").Value = "OK"

-Else

-Range("D507").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatReport6(ByRef num)

-Range("A508").Clear

-Range("B508").Clear

-Range("C508").Clear

-Range("D508").Clear

-Range("A508").Value = "xlRangeAutoFormatReport6"

-Range("B508").Value = 26

-Range("C508").Value = num

-B508 = Range("B508").Value

-C508 = Range("C508").Value

-If B508 = C508 Then

-Range("D508").Value = "OK"

-Else

-Range("D508").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatReport7(ByRef num)

-Range("A509").Clear

-Range("B509").Clear

-Range("C509").Clear

-Range("D509").Clear

-Range("A509").Value = "xlRangeAutoFormatReport7"

-Range("B509").Value = 27

-Range("C509").Value = num

-B509 = Range("B509").Value

-C509 = Range("C509").Value

-If B509 = C509 Then

-Range("D509").Value = "OK"

-Else

-Range("D509").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatReport8(ByRef num)

-Range("A510").Clear

-Range("B510").Clear

-Range("C510").Clear

-Range("D510").Clear

-Range("A510").Value = "xlRangeAutoFormatReport8"

-Range("B510").Value = 28

-Range("C510").Value = num

-B510 = Range("B510").Value

-C510 = Range("C510").Value

-If B510 = C510 Then

-Range("D510").Value = "OK"

-Else

-Range("D510").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatReport9(ByRef num)

-Range("A511").Clear

-Range("B511").Clear

-Range("C511").Clear

-Range("D511").Clear

-Range("A511").Value = "xlRangeAutoFormatReport9"

-Range("B511").Value = 29

-Range("C511").Value = num

-B511 = Range("B511").Value

-C511 = Range("C511").Value

-If B511 = C511 Then

-Range("D511").Value = "OK"

-Else

-Range("D511").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatSimple(ByRef num)

-Range("A512").Clear

-Range("B512").Clear

-Range("C512").Clear

-Range("D512").Clear

-Range("A512").Value = "xlRangeAutoFormatSimple"

-Range("B512").Value = -4154

-Range("C512").Value = num

-B512 = Range("B512").Value

-C512 = Range("C512").Value

-If B512 = C512 Then

-Range("D512").Value = "OK"

-Else

-Range("D512").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatTable1(ByRef num)

-Range("A513").Clear

-Range("B513").Clear

-Range("C513").Clear

-Range("D513").Clear

-Range("A513").Value = "xlRangeAutoFormatTable1"

-Range("B513").Value = 32

-Range("C513").Value = num

-B513 = Range("B513").Value

-C513 = Range("C513").Value

-If B513 = C513 Then

-Range("D513").Value = "OK"

-Else

-Range("D513").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatTable10(ByRef num)

-Range("A514").Clear

-Range("B514").Clear

-Range("C514").Clear

-Range("D514").Clear

-Range("A514").Value = "xlRangeAutoFormatTable10"

-Range("B514").Value = 41

-Range("C514").Value = num

-B514 = Range("B514").Value

-C514 = Range("C514").Value

-If B514 = C514 Then

-Range("D514").Value = "OK"

-Else

-Range("D514").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatTable2(ByRef num)

-Range("A515").Clear

-Range("B515").Clear

-Range("C515").Clear

-Range("D515").Clear

-Range("A515").Value = "xlRangeAutoFormatTable2"

-Range("B515").Value = 33

-Range("C515").Value = num

-B515 = Range("B515").Value

-C515 = Range("C515").Value

-If B515 = C515 Then

-Range("D515").Value = "OK"

-Else

-Range("D515").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatTable3(ByRef num)

-Range("A516").Clear

-Range("B516").Clear

-Range("C516").Clear

-Range("D516").Clear

-Range("A516").Value = "xlRangeAutoFormatTable3"

-Range("B516").Value = 34

-Range("C516").Value = num

-B516 = Range("B516").Value

-C516 = Range("C516").Value

-If B516 = C516 Then

-Range("D516").Value = "OK"

-Else

-Range("D516").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatTable4(ByRef num)

-Range("A517").Clear

-Range("B517").Clear

-Range("C517").Clear

-Range("D517").Clear

-Range("A517").Value = "xlRangeAutoFormatTable4"

-Range("B517").Value = 35

-Range("C517").Value = num

-B517 = Range("B517").Value

-C517 = Range("C517").Value

-If B517 = C517 Then

-Range("D517").Value = "OK"

-Else

-Range("D517").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatTable5(ByRef num)

-Range("A518").Clear

-Range("B518").Clear

-Range("C518").Clear

-Range("D518").Clear

-Range("A518").Value = "xlRangeAutoFormatTable5"

-Range("B518").Value = 36

-Range("C518").Value = num

-B518 = Range("B518").Value

-C518 = Range("C518").Value

-If B518 = C518 Then

-Range("D518").Value = "OK"

-Else

-Range("D518").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatTable6(ByRef num)

-Range("A519").Clear

-Range("B519").Clear

-Range("C519").Clear

-Range("D519").Clear

-Range("A519").Value = "xlRangeAutoFormatTable6"

-Range("B519").Value = 37

-Range("C519").Value = num

-B519 = Range("B519").Value

-C519 = Range("C519").Value

-If B519 = C519 Then

-Range("D519").Value = "OK"

-Else

-Range("D519").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatTable7(ByRef num)

-Range("A520").Clear

-Range("B520").Clear

-Range("C520").Clear

-Range("D520").Clear

-Range("A520").Value = "xlRangeAutoFormatTable7"

-Range("B520").Value = 38

-Range("C520").Value = num

-B520 = Range("B520").Value

-C520 = Range("C520").Value

-If B520 = C520 Then

-Range("D520").Value = "OK"

-Else

-Range("D520").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatTable8(ByRef num)

-Range("A521").Clear

-Range("B521").Clear

-Range("C521").Clear

-Range("D521").Clear

-Range("A521").Value = "xlRangeAutoFormatTable8"

-Range("B521").Value = 39

-Range("C521").Value = num

-B521 = Range("B521").Value

-C521 = Range("C521").Value

-If B521 = C521 Then

-Range("D521").Value = "OK"

-Else

-Range("D521").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeAutoFormatTable9(ByRef num)

-Range("A522").Clear

-Range("B522").Clear

-Range("C522").Clear

-Range("D522").Clear

-Range("A522").Value = "xlRangeAutoFormatTable9"

-Range("B522").Value = 40

-Range("C522").Value = num

-B522 = Range("B522").Value

-C522 = Range("C522").Value

-If B522 = C522 Then

-Range("D522").Value = "OK"

-Else

-Range("D522").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeValueDefault(ByRef num)

-Range("A523").Clear

-Range("B523").Clear

-Range("C523").Clear

-Range("D523").Clear

-Range("A523").Value = "xlRangeValueDefault"

-Range("B523").Value = 10

-Range("C523").Value = num

-B523 = Range("B523").Value

-C523 = Range("C523").Value

-If B523 = C523 Then

-Range("D523").Value = "OK"

-Else

-Range("D523").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeValueMSPersistXML(ByRef num)

-Range("A524").Clear

-Range("B524").Clear

-Range("C524").Clear

-Range("D524").Clear

-Range("A524").Value = "xlRangeValueMSPersistXML"

-Range("B524").Value = 12

-Range("C524").Value = num

-B524 = Range("B524").Value

-C524 = Range("C524").Value

-If B524 = C524 Then

-Range("D524").Value = "OK"

-Else

-Range("D524").Value = "NG"

-End If

-End Function

-

-Function test_xlRangeValueXMLSpreadsheet(ByRef num)

-Range("A525").Clear

-Range("B525").Clear

-Range("C525").Clear

-Range("D525").Clear

-Range("A525").Value = "xlRangeValueXMLSpreadsheet"

-Range("B525").Value = 11

-Range("C525").Value = num

-B525 = Range("B525").Value

-C525 = Range("C525").Value

-If B525 = C525 Then

-Range("D525").Value = "OK"

-Else

-Range("D525").Value = "NG"

-End If

-End Function

-

-Function test_xlA1(ByRef num)

-Range("A526").Clear

-Range("B526").Clear

-Range("C526").Clear

-Range("D526").Clear

-Range("A526").Value = "xlA1"

-Range("B526").Value = 1

-Range("C526").Value = num

-B526 = Range("B526").Value

-C526 = Range("C526").Value

-If B526 = C526 Then

-Range("D526").Value = "OK"

-Else

-Range("D526").Value = "NG"

-End If

-End Function

-

-Function test_xlR1C1(ByRef num)

-Range("A527").Clear

-Range("B527").Clear

-Range("C527").Clear

-Range("D527").Clear

-Range("A527").Value = "xlR1C1"

-Range("B527").Value = -4150

-Range("C527").Value = num

-B527 = Range("B527").Value

-C527 = Range("C527").Value

-If B527 = C527 Then

-Range("D527").Value = "OK"

-Else

-Range("D527").Value = "NG"

-End If

-End Function

-

-Function test_xlAbsolute(ByRef num)

-Range("A528").Clear

-Range("B528").Clear

-Range("C528").Clear

-Range("D528").Clear

-Range("A528").Value = "xlAbsolute"

-Range("B528").Value = 1

-Range("C528").Value = num

-B528 = Range("B528").Value

-C528 = Range("C528").Value

-If B528 = C528 Then

-Range("D528").Value = "OK"

-Else

-Range("D528").Value = "NG"

-End If

-End Function

-

-Function test_xlAbsRowRelColumn(ByRef num)

-Range("A529").Clear

-Range("B529").Clear

-Range("C529").Clear

-Range("D529").Clear

-Range("A529").Value = "xlAbsRowRelColumn"

-Range("B529").Value = 2

-Range("C529").Value = num

-B529 = Range("B529").Value

-C529 = Range("C529").Value

-If B529 = C529 Then

-Range("D529").Value = "OK"

-Else

-Range("D529").Value = "NG"

-End If

-End Function

-

-Function test_xlRelative(ByRef num)

-Range("A530").Clear

-Range("B530").Clear

-Range("C530").Clear

-Range("D530").Clear

-Range("A530").Value = "xlRelative"

-Range("B530").Value = 4

-Range("C530").Value = num

-B530 = Range("B530").Value

-C530 = Range("C530").Value

-If B530 = C530 Then

-Range("D530").Value = "OK"

-Else

-Range("D530").Value = "NG"

-End If

-End Function

-

-Function test_xlRelRowAbsColumn(ByRef num)

-Range("A531").Clear

-Range("B531").Clear

-Range("C531").Clear

-Range("D531").Clear

-Range("A531").Value = "xlRelRowAbsColumn"

-Range("B531").Value = 3

-Range("C531").Value = num

-B531 = Range("B531").Value

-C531 = Range("C531").Value

-If B531 = C531 Then

-Range("D531").Value = "OK"

-Else

-Range("D531").Value = "NG"

-End If

-End Function

-

-Function test_xlAlways(ByRef num)

-Range("A532").Clear

-Range("B532").Clear

-Range("C532").Clear

-Range("D532").Clear

-Range("A532").Value = "xlAlways"

-Range("B532").Value = 1

-Range("C532").Value = num

-B532 = Range("B532").Value

-C532 = Range("C532").Value

-If B532 = C532 Then

-Range("D532").Value = "OK"

-Else

-Range("D532").Value = "NG"

-End If

-End Function

-

-Function test_xlAsRequired(ByRef num)

-Range("A533").Clear

-Range("B533").Clear

-Range("C533").Clear

-Range("D533").Clear

-Range("A533").Value = "xlAsRequired"

-Range("B533").Value = 0

-Range("C533").Value = num

-B533 = Range("B533").Value

-C533 = Range("C533").Value

-If B533 = C533 Then

-Range("D533").Value = "OK"

-Else

-Range("D533").Value = "NG"

-End If

-End Function

-

-Function test_xlNever(ByRef num)

-Range("A534").Clear

-Range("B534").Clear

-Range("C534").Clear

-Range("D534").Clear

-Range("A534").Value = "xlNever"

-Range("B534").Value = 2

-Range("C534").Value = num

-B534 = Range("B534").Value

-C534 = Range("C534").Value

-If B534 = C534 Then

-Range("D534").Value = "OK"

-Else

-Range("D534").Value = "NG"

-End If

-End Function

-

-Function test_xlAllAtOnce(ByRef num)

-Range("A535").Clear

-Range("B535").Clear

-Range("C535").Clear

-Range("D535").Clear

-Range("A535").Value = "xlAllAtOnce"

-Range("B535").Value = 2

-Range("C535").Value = num

-B535 = Range("B535").Value

-C535 = Range("C535").Value

-If B535 = C535 Then

-Range("D535").Value = "OK"

-Else

-Range("D535").Value = "NG"

-End If

-End Function

-

-Function test_xlOneAfterAnother(ByRef num)

-Range("A536").Clear

-Range("B536").Clear

-Range("C536").Clear

-Range("D536").Clear

-Range("A536").Value = "xlOneAfterAnother"

-Range("B536").Value = 1

-Range("C536").Value = num

-B536 = Range("B536").Value

-C536 = Range("C536").Value

-If B536 = C536 Then

-Range("D536").Value = "OK"

-Else

-Range("D536").Value = "NG"

-End If

-End Function

-

-Function test_xlNotYetRouted(ByRef num)

-Range("A537").Clear

-Range("B537").Clear

-Range("C537").Clear

-Range("D537").Clear

-Range("A537").Value = "xlNotYetRouted"

-Range("B537").Value = 0

-Range("C537").Value = num

-B537 = Range("B537").Value

-C537 = Range("C537").Value

-If B537 = C537 Then

-Range("D537").Value = "OK"

-Else

-Range("D537").Value = "NG"

-End If

-End Function

-

-Function test_xlRoutingComplete(ByRef num)

-Range("A538").Clear

-Range("B538").Clear

-Range("C538").Clear

-Range("D538").Clear

-Range("A538").Value = "xlRoutingComplete"

-Range("B538").Value = 2

-Range("C538").Value = num

-B538 = Range("B538").Value

-C538 = Range("C538").Value

-If B538 = C538 Then

-Range("D538").Value = "OK"

-Else

-Range("D538").Value = "NG"

-End If

-End Function

-

-Function test_xlRoutingInProgress(ByRef num)

-Range("A539").Clear

-Range("B539").Clear

-Range("C539").Clear

-Range("D539").Clear

-Range("A539").Value = "xlRoutingInProgress"

-Range("B539").Value = 1

-Range("C539").Value = num

-B539 = Range("B539").Value

-C539 = Range("C539").Value

-If B539 = C539 Then

-Range("D539").Value = "OK"

-Else

-Range("D539").Value = "NG"

-End If

-End Function

-

-Function test_xlColumns(ByRef num)

-Range("A540").Clear

-Range("B540").Clear

-Range("C540").Clear

-Range("D540").Clear

-Range("A540").Value = "xlColumns"

-Range("B540").Value = 2

-Range("C540").Value = num

-B540 = Range("B540").Value

-C540 = Range("C540").Value

-If B540 = C540 Then

-Range("D540").Value = "OK"

-Else

-Range("D540").Value = "NG"

-End If

-End Function

-

-Function test_xlRows(ByRef num)

-Range("A541").Clear

-Range("B541").Clear

-Range("C541").Clear

-Range("D541").Clear

-Range("A541").Value = "xlRows"

-Range("B541").Value = 1

-Range("C541").Value = num

-B541 = Range("B541").Value

-C541 = Range("C541").Value

-If B541 = C541 Then

-Range("D541").Value = "OK"

-Else

-Range("D541").Value = "NG"

-End If

-End Function

-

-Function test_xlAutoActivate(ByRef num)

-Range("A542").Clear

-Range("B542").Clear

-Range("C542").Clear

-Range("D542").Clear

-Range("A542").Value = "xlAutoActivate"

-Range("B542").Value = 3

-Range("C542").Value = num

-B542 = Range("B542").Value

-C542 = Range("C542").Value

-If B542 = C542 Then

-Range("D542").Value = "OK"

-Else

-Range("D542").Value = "NG"

-End If

-End Function

-

-Function test_xlAutoClose(ByRef num)

-Range("A543").Clear

-Range("B543").Clear

-Range("C543").Clear

-Range("D543").Clear

-Range("A543").Value = "xlAutoClose"

-Range("B543").Value = 2

-Range("C543").Value = num

-B543 = Range("B543").Value

-C543 = Range("C543").Value

-If B543 = C543 Then

-Range("D543").Value = "OK"

-Else

-Range("D543").Value = "NG"

-End If

-End Function

-

-Function test_xlAutoDeactivate(ByRef num)

-Range("A544").Clear

-Range("B544").Clear

-Range("C544").Clear

-Range("D544").Clear

-Range("A544").Value = "xlAutoDeactivate"

-Range("B544").Value = 4

-Range("C544").Value = num

-B544 = Range("B544").Value

-C544 = Range("C544").Value

-If B544 = C544 Then

-Range("D544").Value = "OK"

-Else

-Range("D544").Value = "NG"

-End If

-End Function

-

-Function test_xlAutoOpen(ByRef num)

-Range("A545").Clear

-Range("B545").Clear

-Range("C545").Clear

-Range("D545").Clear

-Range("A545").Value = "xlAutoOpen"

-Range("B545").Value = 1

-Range("C545").Value = num

-B545 = Range("B545").Value

-C545 = Range("C545").Value

-If B545 = C545 Then

-Range("D545").Value = "OK"

-Else

-Range("D545").Value = "NG"

-End If

-End Function

-

-Function test_xlDoNotSaveChanges(ByRef num)

-Range("A546").Clear

-Range("B546").Clear

-Range("C546").Clear

-Range("D546").Clear

-Range("A546").Value = "xlDoNotSaveChanges"

-Range("B546").Value = 2

-Range("C546").Value = num

-B546 = Range("B546").Value

-C546 = Range("C546").Value

-If B546 = C546 Then

-Range("D546").Value = "OK"

-Else

-Range("D546").Value = "NG"

-End If

-End Function

-

-Function test_xlSaveChanges(ByRef num)

-Range("A547").Clear

-Range("B547").Clear

-Range("C547").Clear

-Range("D547").Clear

-Range("A547").Value = "xlSaveChanges"

-Range("B547").Value = 1

-Range("C547").Value = num

-B547 = Range("B547").Value

-C547 = Range("C547").Value

-If B547 = C547 Then

-Range("D547").Value = "OK"

-Else

-Range("D547").Value = "NG"

-End If

-End Function

-

-Function test_xlExclusive(ByRef num)

-Range("A548").Clear

-Range("B548").Clear

-Range("C548").Clear

-Range("D548").Clear

-Range("A548").Value = "xlExclusive"

-Range("B548").Value = 3

-Range("C548").Value = num

-B548 = Range("B548").Value

-C548 = Range("C548").Value

-If B548 = C548 Then

-Range("D548").Value = "OK"

-Else

-Range("D548").Value = "NG"

-End If

-End Function

-

-Function test_xlNoChange(ByRef num)

-Range("A549").Clear

-Range("B549").Clear

-Range("C549").Clear

-Range("D549").Clear

-Range("A549").Value = "xlNoChange"

-Range("B549").Value = 1

-Range("C549").Value = num

-B549 = Range("B549").Value

-C549 = Range("C549").Value

-If B549 = C549 Then

-Range("D549").Value = "OK"

-Else

-Range("D549").Value = "NG"

-End If

-End Function

-

-Function test_xlShared(ByRef num)

-Range("A550").Clear

-Range("B550").Clear

-Range("C550").Clear

-Range("D550").Clear

-Range("A550").Value = "xlShared"

-Range("B550").Value = 2

-Range("C550").Value = num

-B550 = Range("B550").Value

-C550 = Range("C550").Value

-If B550 = C550 Then

-Range("D550").Value = "OK"

-Else

-Range("D550").Value = "NG"

-End If

-End Function

-

-Function test_xlLocalSessionsChanges(ByRef num)

-Range("A551").Clear

-Range("B551").Clear

-Range("C551").Clear

-Range("D551").Clear

-Range("A551").Value = "xlLocalSessionsChanges"

-Range("B551").Value = 2

-Range("C551").Value = num

-B551 = Range("B551").Value

-C551 = Range("C551").Value

-If B551 = C551 Then

-Range("D551").Value = "OK"

-Else

-Range("D551").Value = "NG"

-End If

-End Function

-

-Function test_xlOtherSessionsChanges(ByRef num)

-Range("A552").Clear

-Range("B552").Clear

-Range("C552").Clear

-Range("D552").Clear

-Range("A552").Value = "xlOtherSessionsChanges"

-Range("B552").Value = 3

-Range("C552").Value = num

-B552 = Range("B552").Value

-C552 = Range("C552").Value

-If B552 = C552 Then

-Range("D552").Value = "OK"

-Else

-Range("D552").Value = "NG"

-End If

-End Function

-

-Function test_xlUserResolution(ByRef num)

-Range("A553").Clear

-Range("B553").Clear

-Range("C553").Clear

-Range("D553").Clear

-Range("A553").Value = "xlUserResolution"

-Range("B553").Value = 1

-Range("C553").Value = num

-B553 = Range("B553").Value

-C553 = Range("C553").Value

-If B553 = C553 Then

-Range("D553").Value = "OK"

-Else

-Range("D553").Value = "NG"

-End If

-End Function

-

-Function test_xlScaleLinear(ByRef num)

-Range("A554").Clear

-Range("B554").Clear

-Range("C554").Clear

-Range("D554").Clear

-Range("A554").Value = "xlScaleLinear"

-Range("B554").Value = -4132

-Range("C554").Value = num

-B554 = Range("B554").Value

-C554 = Range("C554").Value

-If B554 = C554 Then

-Range("D554").Value = "OK"

-Else

-Range("D554").Value = "NG"

-End If

-End Function

-

-Function test_xlScaleLogarithmicr(ByRef num)

-Range("A555").Clear

-Range("B555").Clear

-Range("C555").Clear

-Range("D555").Clear

-Range("A555").Value = "xlScaleLogarithmicr"

-Range("B555").Value = -4133

-Range("C555").Value = num

-B555 = Range("B555").Value

-C555 = Range("C555").Value

-If B555 = C555 Then

-Range("D555").Value = "OK"

-Else

-Range("D555").Value = "NG"

-End If

-End Function

-

-Function test_xlNext(ByRef num)

-Range("A556").Clear

-Range("B556").Clear

-Range("C556").Clear

-Range("D556").Clear

-Range("A556").Value = "xlNext"

-Range("B556").Value = 1

-Range("C556").Value = num

-B556 = Range("B556").Value

-C556 = Range("C556").Value

-If B556 = C556 Then

-Range("D556").Value = "OK"

-Else

-Range("D556").Value = "NG"

-End If

-End Function

-

-Function test_xlPrevious(ByRef num)

-Range("A557").Clear

-Range("B557").Clear

-Range("C557").Clear

-Range("D557").Clear

-Range("A557").Value = "xlPrevious"

-Range("B557").Value = 2

-Range("C557").Value = num

-B557 = Range("B557").Value

-C557 = Range("C557").Value

-If B557 = C557 Then

-Range("D557").Value = "OK"

-Else

-Range("D557").Value = "NG"

-End If

-End Function

-

-Function test_xlByColumns(ByRef num)

-Range("A558").Clear

-Range("B558").Clear

-Range("C558").Clear

-Range("D558").Clear

-Range("A558").Value = "xlByColumns"

-Range("B558").Value = 2

-Range("C558").Value = num

-B558 = Range("B558").Value

-C558 = Range("C558").Value

-If B558 = C558 Then

-Range("D558").Value = "OK"

-Else

-Range("D558").Value = "NG"

-End If

-End Function

-

-Function test_xlByRows(ByRef num)

-Range("A559").Clear

-Range("B559").Clear

-Range("C559").Clear

-Range("D559").Clear

-Range("A559").Value = "xlByRows"

-Range("B559").Value = 1

-Range("C559").Value = num

-B559 = Range("B559").Value

-C559 = Range("C559").Value

-If B559 = C559 Then

-Range("D559").Value = "OK"

-Else

-Range("D559").Value = "NG"

-End If

-End Function

-

-Function test_xlWithinSheet(ByRef num)

-Range("A560").Clear

-Range("B560").Clear

-Range("C560").Clear

-Range("D560").Clear

-Range("A560").Value = "xlWithinSheet"

-Range("B560").Value = 1

-Range("C560").Value = num

-B560 = Range("B560").Value

-C560 = Range("C560").Value

-If B560 = C560 Then

-Range("D560").Value = "OK"

-Else

-Range("D560").Value = "NG"

-End If

-End Function

-

-Function test_xlWithinWorkbook(ByRef num)

-Range("A561").Clear

-Range("B561").Clear

-Range("C561").Clear

-Range("D561").Clear

-Range("A561").Value = "xlWithinWorkbook"

-Range("B561").Value = 2

-Range("C561").Value = num

-B561 = Range("B561").Value

-C561 = Range("C561").Value

-If B561 = C561 Then

-Range("D561").Value = "OK"

-Else

-Range("D561").Value = "NG"

-End If

-End Function

-

-Function test_xlChart(ByRef num)

-Range("A562").Clear

-Range("B562").Clear

-Range("C562").Clear

-Range("D562").Clear

-Range("A562").Value = "xlChart"

-Range("B562").Value = -4109

-Range("C562").Value = num

-B562 = Range("B562").Value

-C562 = Range("C562").Value

-If B562 = C562 Then

-Range("D562").Value = "OK"

-Else

-Range("D562").Value = "NG"

-End If

-End Function

-

-Function test_xlDialogSheet(ByRef num)

-Range("A563").Clear

-Range("B563").Clear

-Range("C563").Clear

-Range("D563").Clear

-Range("A563").Value = "xlDialogSheet"

-Range("B563").Value = -4116

-Range("C563").Value = num

-B563 = Range("B563").Value

-C563 = Range("C563").Value

-If B563 = C563 Then

-Range("D563").Value = "OK"

-Else

-Range("D563").Value = "NG"

-End If

-End Function

-

-Function test_xlExcel4IntMacroSheet(ByRef num)

-Range("A564").Clear

-Range("B564").Clear

-Range("C564").Clear

-Range("D564").Clear

-Range("A564").Value = "xlExcel4IntMacroSheet"

-Range("B564").Value = 4

-Range("C564").Value = num

-B564 = Range("B564").Value

-C564 = Range("C564").Value

-If B564 = C564 Then

-Range("D564").Value = "OK"

-Else

-Range("D564").Value = "NG"

-End If

-End Function

-

-Function test_xlExcel4MacroSheet(ByRef num)

-Range("A565").Clear

-Range("B565").Clear

-Range("C565").Clear

-Range("D565").Clear

-Range("A565").Value = "xlExcel4MacroSheet"

-Range("B565").Value = 3

-Range("C565").Value = num

-B565 = Range("B565").Value

-C565 = Range("C565").Value

-If B565 = C565 Then

-Range("D565").Value = "OK"

-Else

-Range("D565").Value = "NG"

-End If

-End Function

-

-Function test_xlWorkSheet(ByRef num)

-Range("A566").Clear

-Range("B566").Clear

-Range("C566").Clear

-Range("D566").Clear

-Range("A566").Value = "xlWorkSheet"

-Range("B566").Value = -4167

-Range("C566").Value = num

-B566 = Range("B566").Value

-C566 = Range("C566").Value

-If B566 = C566 Then

-Range("D566").Value = "OK"

-Else

-Range("D566").Value = "NG"

-End If

-End Function

-

-Function test_xlSheetHidden(ByRef num)

-Range("A567").Clear

-Range("B567").Clear

-Range("C567").Clear

-Range("D567").Clear

-Range("A567").Value = "xlSheetHidden"

-Range("B567").Value = 0

-Range("C567").Value = num

-B567 = Range("B567").Value

-C567 = Range("C567").Value

-If B567 = C567 Then

-Range("D567").Value = "OK"

-Else

-Range("D567").Value = "NG"

-End If

-End Function

-

-Function test_xlSheetVeryHidden(ByRef num)

-Range("A568").Clear

-Range("B568").Clear

-Range("C568").Clear

-Range("D568").Clear

-Range("A568").Value = "xlSheetVeryHidden"

-Range("B568").Value = 2

-Range("C568").Value = num

-B568 = Range("B568").Value

-C568 = Range("C568").Value

-If B568 = C568 Then

-Range("D568").Value = "OK"

-Else

-Range("D568").Value = "NG"

-End If

-End Function

-

-Function test_xlSheetVisible(ByRef num)

-Range("A569").Clear

-Range("B569").Clear

-Range("C569").Clear

-Range("D569").Clear

-Range("A569").Value = "xlSheetVisible"

-Range("B569").Value = -1

-Range("C569").Value = num

-B569 = Range("B569").Value

-C569 = Range("C569").Value

-If B569 = C569 Then

-Range("D569").Value = "OK"

-Else

-Range("D569").Value = "NG"

-End If

-End Function

-

-Function test_xlSizeIsArea(ByRef num)

-Range("A570").Clear

-Range("B570").Clear

-Range("C570").Clear

-Range("D570").Clear

-Range("A570").Value = "xlSizeIsArea"

-Range("B570").Value = 1

-Range("C570").Value = num

-B570 = Range("B570").Value

-C570 = Range("C570").Value

-If B570 = C570 Then

-Range("D570").Value = "OK"

-Else

-Range("D570").Value = "NG"

-End If

-End Function

-

-Function test_xlSizeIsWidth(ByRef num)

-Range("A571").Clear

-Range("B571").Clear

-Range("C571").Clear

-Range("D571").Clear

-Range("A571").Value = "xlSizeIsWidth"

-Range("B571").Value = 2

-Range("C571").Value = num

-B571 = Range("B571").Value

-C571 = Range("C571").Value

-If B571 = C571 Then

-Range("D571").Value = "OK"

-Else

-Range("D571").Value = "NG"

-End If

-End Function

-

-Function test_xlSmartTagControlActiveX(ByRef num)

-Range("A572").Clear

-Range("B572").Clear

-Range("C572").Clear

-Range("D572").Clear

-Range("A572").Value = "xlSmartTagControlActiveX"

-Range("B572").Value = 13

-Range("C572").Value = num

-B572 = Range("B572").Value

-C572 = Range("C572").Value

-If B572 = C572 Then

-Range("D572").Value = "OK"

-Else

-Range("D572").Value = "NG"

-End If

-End Function

-

-Function test_xlSmartTagControlButton(ByRef num)

-Range("A573").Clear

-Range("B573").Clear

-Range("C573").Clear

-Range("D573").Clear

-Range("A573").Value = "xlSmartTagControlButton"

-Range("B573").Value = 6

-Range("C573").Value = num

-B573 = Range("B573").Value

-C573 = Range("C573").Value

-If B573 = C573 Then

-Range("D573").Value = "OK"

-Else

-Range("D573").Value = "NG"

-End If

-End Function

-

-Function test_xlSmartTagControlCheckbox(ByRef num)

-Range("A574").Clear

-Range("B574").Clear

-Range("C574").Clear

-Range("D574").Clear

-Range("A574").Value = "xlSmartTagControlCheckbox"

-Range("B574").Value = 9

-Range("C574").Value = num

-B574 = Range("B574").Value

-C574 = Range("C574").Value

-If B574 = C574 Then

-Range("D574").Value = "OK"

-Else

-Range("D574").Value = "NG"

-End If

-End Function

-

-Function test_xlSmartTagControlCombo(ByRef num)

-Range("A575").Clear

-Range("B575").Clear

-Range("C575").Clear

-Range("D575").Clear

-Range("A575").Value = "xlSmartTagControlCombo"

-Range("B575").Value = 12

-Range("C575").Value = num

-B575 = Range("B575").Value

-C575 = Range("C575").Value

-If B575 = C575 Then

-Range("D575").Value = "OK"

-Else

-Range("D575").Value = "NG"

-End If

-End Function

-

-Function test_xlSmartTagControlHelp(ByRef num)

-Range("A576").Clear

-Range("B576").Clear

-Range("C576").Clear

-Range("D576").Clear

-Range("A576").Value = "xlSmartTagControlHelp"

-Range("B576").Value = 3

-Range("C576").Value = num

-B576 = Range("B576").Value

-C576 = Range("C576").Value

-If B576 = C576 Then

-Range("D576").Value = "OK"

-Else

-Range("D576").Value = "NG"

-End If

-End Function

-

-Function test_xlSmartTagControlHelpURL(ByRef num)

-Range("A577").Clear

-Range("B577").Clear

-Range("C577").Clear

-Range("D577").Clear

-Range("A577").Value = "xlSmartTagControlHelpURL"

-Range("B577").Value = 4

-Range("C577").Value = num

-B577 = Range("B577").Value

-C577 = Range("C577").Value

-If B577 = C577 Then

-Range("D577").Value = "OK"

-Else

-Range("D577").Value = "NG"

-End If

-End Function

-

-Function test_xlSmartTagControlImage(ByRef num)

-Range("A578").Clear

-Range("B578").Clear

-Range("C578").Clear

-Range("D578").Clear

-Range("A578").Value = "xlSmartTagControlImage"

-Range("B578").Value = 8

-Range("C578").Value = num

-B578 = Range("B578").Value

-C578 = Range("C578").Value

-If B578 = C578 Then

-Range("D578").Value = "OK"

-Else

-Range("D578").Value = "NG"

-End If

-End Function

-

-Function test_xlSmartTagControlLabel(ByRef num)

-Range("A579").Clear

-Range("B579").Clear

-Range("C579").Clear

-Range("D579").Clear

-Range("A579").Value = "xlSmartTagControlLabel"

-Range("B579").Value = 7

-Range("C579").Value = num

-B579 = Range("B579").Value

-C579 = Range("C579").Value

-If B579 = C579 Then

-Range("D579").Value = "OK"

-Else

-Range("D579").Value = "NG"

-End If

-End Function

-

-Function test_xlSmartTagControlLink(ByRef num)

-Range("A580").Clear

-Range("B580").Clear

-Range("C580").Clear

-Range("D580").Clear

-Range("A580").Value = "xlSmartTagControlLink"

-Range("B580").Value = 2

-Range("C580").Value = num

-B580 = Range("B580").Value

-C580 = Range("C580").Value

-If B580 = C580 Then

-Range("D580").Value = "OK"

-Else

-Range("D580").Value = "NG"

-End If

-End Function

-

-Function test_xlSmartTagControlListbox(ByRef num)

-Range("A581").Clear

-Range("B581").Clear

-Range("C581").Clear

-Range("D581").Clear

-Range("A581").Value = "xlSmartTagControlListbox"

-Range("B581").Value = 11

-Range("C581").Value = num

-B581 = Range("B581").Value

-C581 = Range("C581").Value

-If B581 = C581 Then

-Range("D581").Value = "OK"

-Else

-Range("D581").Value = "NG"

-End If

-End Function

-

-Function test_xlSmartTagControlRadioGroup(ByRef num)

-Range("A582").Clear

-Range("B582").Clear

-Range("C582").Clear

-Range("D582").Clear

-Range("A582").Value = "xlSmartTagControlRadioGroup"

-Range("B582").Value = 14

-Range("C582").Value = num

-B582 = Range("B582").Value

-C582 = Range("C582").Value

-If B582 = C582 Then

-Range("D582").Value = "OK"

-Else

-Range("D582").Value = "NG"

-End If

-End Function

-

-Function test_xlSmartTagControlSeparator(ByRef num)

-Range("A583").Clear

-Range("B583").Clear

-Range("C583").Clear

-Range("D583").Clear

-Range("A583").Value = "xlSmartTagControlSeparator"

-Range("B583").Value = 5

-Range("C583").Value = num

-B583 = Range("B583").Value

-C583 = Range("C583").Value

-If B583 = C583 Then

-Range("D583").Value = "OK"

-Else

-Range("D583").Value = "NG"

-End If

-End Function

-

-Function test_xlSmartTagControlSmartTag(ByRef num)

-Range("A584").Clear

-Range("B584").Clear

-Range("C584").Clear

-Range("D584").Clear

-Range("A584").Value = "xlSmartTagControlSmartTag"

-Range("B584").Value = 1

-Range("C584").Value = num

-B584 = Range("B584").Value

-C584 = Range("C584").Value

-If B584 = C584 Then

-Range("D584").Value = "OK"

-Else

-Range("D584").Value = "NG"

-End If

-End Function

-

-Function test_xlSmartTagControlTextbox(ByRef num)

-Range("A585").Clear

-Range("B585").Clear

-Range("C585").Clear

-Range("D585").Clear

-Range("A585").Value = "xlSmartTagControlTextbox"

-Range("B585").Value = 10

-Range("C585").Value = num

-B585 = Range("B585").Value

-C585 = Range("C585").Value

-If B585 = C585 Then

-Range("D585").Value = "OK"

-Else

-Range("D585").Value = "NG"

-End If

-End Function

-

-Function test_xlButtonOnly(ByRef num)

-Range("A586").Clear

-Range("B586").Clear

-Range("C586").Clear

-Range("D586").Clear

-Range("A586").Value = "xlButtonOnly"

-Range("B586").Value = 2

-Range("C586").Value = num

-B586 = Range("B586").Value

-C586 = Range("C586").Value

-If B586 = C586 Then

-Range("D586").Value = "OK"

-Else

-Range("D586").Value = "NG"

-End If

-End Function

-

-Function test_xlDisplayNone(ByRef num)

-Range("A587").Clear

-Range("B587").Clear

-Range("C587").Clear

-Range("D587").Clear

-Range("A587").Value = "xlDisplayNone"

-Range("B587").Value = 1

-Range("C587").Value = num

-B587 = Range("B587").Value

-C587 = Range("C587").Value

-If B587 = C587 Then

-Range("D587").Value = "OK"

-Else

-Range("D587").Value = "NG"

-End If

-End Function

-

-Function test_xlIndicatorAndButton(ByRef num)

-Range("A588").Clear

-Range("B588").Clear

-Range("C588").Clear

-Range("D588").Clear

-Range("A588").Value = "xlIndicatorAndButton"

-Range("B588").Value = 0

-Range("C588").Value = num

-B588 = Range("B588").Value

-C588 = Range("C588").Value

-If B588 = C588 Then

-Range("D588").Value = "OK"

-Else

-Range("D588").Value = "NG"

-End If

-End Function

-

-Function test_xlSortNormal(ByRef num)

-Range("A589").Clear

-Range("B589").Clear

-Range("C589").Clear

-Range("D589").Clear

-Range("A589").Value = "xlSortNormal"

-Range("B589").Value = 0

-Range("C589").Value = num

-B589 = Range("B589").Value

-C589 = Range("C589").Value

-If B589 = C589 Then

-Range("D589").Value = "OK"

-Else

-Range("D589").Value = "NG"

-End If

-End Function

-

-Function test_xlSortTextAsNumbers(ByRef num)

-Range("A590").Clear

-Range("B590").Clear

-Range("C590").Clear

-Range("D590").Clear

-Range("A590").Value = "xlSortTextAsNumbers"

-Range("B590").Value = 1

-Range("C590").Value = num

-B590 = Range("B590").Value

-C590 = Range("C590").Value

-If B590 = C590 Then

-Range("D590").Value = "OK"

-Else

-Range("D590").Value = "NG"

-End If

-End Function

-

-Function test_xlPinYin(ByRef num)

-Range("A591").Clear

-Range("B591").Clear

-Range("C591").Clear

-Range("D591").Clear

-Range("A591").Value = "xlPinYin"

-Range("B591").Value = 1

-Range("C591").Value = num

-B591 = Range("B591").Value

-C591 = Range("C591").Value

-If B591 = C591 Then

-Range("D591").Value = "OK"

-Else

-Range("D591").Value = "NG"

-End If

-End Function

-

-Function test_xlStroke(ByRef num)

-Range("A592").Clear

-Range("B592").Clear

-Range("C592").Clear

-Range("D592").Clear

-Range("A592").Value = "xlStroke"

-Range("B592").Value = 2

-Range("C592").Value = num

-B592 = Range("B592").Value

-C592 = Range("C592").Value

-If B592 = C592 Then

-Range("D592").Value = "OK"

-Else

-Range("D592").Value = "NG"

-End If

-End Function

-

-Function test_xlCodePage(ByRef num)

-Range("A593").Clear

-Range("B593").Clear

-Range("C593").Clear

-Range("D593").Clear

-Range("A593").Value = "xlCodePage"

-Range("B593").Value = 2

-Range("C593").Value = num

-B593 = Range("B593").Value

-C593 = Range("C593").Value

-If B593 = C593 Then

-Range("D593").Value = "OK"

-Else

-Range("D593").Value = "NG"

-End If

-End Function

-

-Function test_xlSyllabary(ByRef num)

-Range("A594").Clear

-Range("B594").Clear

-Range("C594").Clear

-Range("D594").Clear

-Range("A594").Value = "xlSyllabary"

-Range("B594").Value = 1

-Range("C594").Value = num

-B594 = Range("B594").Value

-C594 = Range("C594").Value

-If B594 = C594 Then

-Range("D594").Value = "OK"

-Else

-Range("D594").Value = "NG"

-End If

-End Function

-

-Function test_xlAscending(ByRef num)

-Range("A595").Clear

-Range("B595").Clear

-Range("C595").Clear

-Range("D595").Clear

-Range("A595").Value = "xlAscending"

-Range("B595").Value = 1

-Range("C595").Value = num

-B595 = Range("B595").Value

-C595 = Range("C595").Value

-If B595 = C595 Then

-Range("D595").Value = "OK"

-Else

-Range("D595").Value = "NG"

-End If

-End Function

-

-Function test_xlDescending(ByRef num)

-Range("A596").Clear

-Range("B596").Clear

-Range("C596").Clear

-Range("D596").Clear

-Range("A596").Value = "xlDescending"

-Range("B596").Value = 2

-Range("C596").Value = num

-B596 = Range("B596").Value

-C596 = Range("C596").Value

-If B596 = C596 Then

-Range("D596").Value = "OK"

-Else

-Range("D596").Value = "NG"

-End If

-End Function

-

-Function test_xlSortColumns(ByRef num)

-Range("A597").Clear

-Range("B597").Clear

-Range("C597").Clear

-Range("D597").Clear

-Range("A597").Value = "xlSortColumns"

-Range("B597").Value = 1

-Range("C597").Value = num

-B597 = Range("B597").Value

-C597 = Range("C597").Value

-If B597 = C597 Then

-Range("D597").Value = "OK"

-Else

-Range("D597").Value = "NG"

-End If

-End Function

-

-Function test_xlSortRows(ByRef num)

-Range("A598").Clear

-Range("B598").Clear

-Range("C598").Clear

-Range("D598").Clear

-Range("A598").Value = "xlSortRows"

-Range("B598").Value = 2

-Range("C598").Value = num

-B598 = Range("B598").Value

-C598 = Range("C598").Value

-If B598 = C598 Then

-Range("D598").Value = "OK"

-Else

-Range("D598").Value = "NG"

-End If

-End Function

-

-Function test_xlSortLabels(ByRef num)

-Range("A599").Clear

-Range("B599").Clear

-Range("C599").Clear

-Range("D599").Clear

-Range("A599").Value = "xlSortLabels"

-Range("B599").Value = 2

-Range("C599").Value = num

-B599 = Range("B599").Value

-C599 = Range("C599").Value

-If B599 = C599 Then

-Range("D599").Value = "OK"

-Else

-Range("D599").Value = "NG"

-End If

-End Function

-

-Function test_xlSortValues(ByRef num)

-Range("A600").Clear

-Range("B600").Clear

-Range("C600").Clear

-Range("D600").Clear

-Range("A600").Value = "xlSortValues"

-Range("B600").Value = 1

-Range("C600").Value = num

-B600 = Range("B600").Value

-C600 = Range("C600").Value

-If B600 = C600 Then

-Range("D600").Value = "OK"

-Else

-Range("D600").Value = "NG"

-End If

-End Function

-

-Function test_xlSourceAutoFilter(ByRef num)

-Range("A601").Clear

-Range("B601").Clear

-Range("C601").Clear

-Range("D601").Clear

-Range("A601").Value = "xlSourceAutoFilter"

-Range("B601").Value = 3

-Range("C601").Value = num

-B601 = Range("B601").Value

-C601 = Range("C601").Value

-If B601 = C601 Then

-Range("D601").Value = "OK"

-Else

-Range("D601").Value = "NG"

-End If

-End Function

-

-Function test_xlSourceChart(ByRef num)

-Range("A602").Clear

-Range("B602").Clear

-Range("C602").Clear

-Range("D602").Clear

-Range("A602").Value = "xlSourceChart"

-Range("B602").Value = 5

-Range("C602").Value = num

-B602 = Range("B602").Value

-C602 = Range("C602").Value

-If B602 = C602 Then

-Range("D602").Value = "OK"

-Else

-Range("D602").Value = "NG"

-End If

-End Function

-

-Function test_xlSourcePivotTable(ByRef num)

-Range("A603").Clear

-Range("B603").Clear

-Range("C603").Clear

-Range("D603").Clear

-Range("A603").Value = "xlSourcePivotTable"

-Range("B603").Value = 6

-Range("C603").Value = num

-B603 = Range("B603").Value

-C603 = Range("C603").Value

-If B603 = C603 Then

-Range("D603").Value = "OK"

-Else

-Range("D603").Value = "NG"

-End If

-End Function

-

-Function test_xlSourcePrintArea(ByRef num)

-Range("A604").Clear

-Range("B604").Clear

-Range("C604").Clear

-Range("D604").Clear

-Range("A604").Value = "xlSourcePrintArea"

-Range("B604").Value = 2

-Range("C604").Value = num

-B604 = Range("B604").Value

-C604 = Range("C604").Value

-If B604 = C604 Then

-Range("D604").Value = "OK"

-Else

-Range("D604").Value = "NG"

-End If

-End Function

-

-Function test_xlSourceQuery(ByRef num)

-Range("A605").Clear

-Range("B605").Clear

-Range("C605").Clear

-Range("D605").Clear

-Range("A605").Value = "xlSourceQuery"

-Range("B605").Value = 7

-Range("C605").Value = num

-B605 = Range("B605").Value

-C605 = Range("C605").Value

-If B605 = C605 Then

-Range("D605").Value = "OK"

-Else

-Range("D605").Value = "NG"

-End If

-End Function

-

-Function test_xlSourceRange(ByRef num)

-Range("A606").Clear

-Range("B606").Clear

-Range("C606").Clear

-Range("D606").Clear

-Range("A606").Value = "xlSourceRange"

-Range("B606").Value = 4

-Range("C606").Value = num

-B606 = Range("B606").Value

-C606 = Range("C606").Value

-If B606 = C606 Then

-Range("D606").Value = "OK"

-Else

-Range("D606").Value = "NG"

-End If

-End Function

-

-Function test_xlSourceSheet(ByRef num)

-Range("A607").Clear

-Range("B607").Clear

-Range("C607").Clear

-Range("D607").Clear

-Range("A607").Value = "xlSourceSheet"

-Range("B607").Value = 1

-Range("C607").Value = num

-B607 = Range("B607").Value

-C607 = Range("C607").Value

-If B607 = C607 Then

-Range("D607").Value = "OK"

-Else

-Range("D607").Value = "NG"

-End If

-End Function

-

-Function test_xlSourceWordbook(ByRef num)

-Range("A608").Clear

-Range("B608").Clear

-Range("C608").Clear

-Range("D608").Clear

-Range("A608").Value = "xlSourceWordbook"

-Range("B608").Value = 0

-Range("C608").Value = num

-B608 = Range("B608").Value

-C608 = Range("C608").Value

-If B608 = C608 Then

-Range("D608").Value = "OK"

-Else

-Range("D608").Value = "NG"

-End If

-End Function

-

-Function test_xlSpeakByColumns(ByRef num)

-Range("A609").Clear

-Range("B609").Clear

-Range("C609").Clear

-Range("D609").Clear

-Range("A609").Value = "xlSpeakByColumns"

-Range("B609").Value = 1

-Range("C609").Value = num

-B609 = Range("B609").Value

-C609 = Range("C609").Value

-If B609 = C609 Then

-Range("D609").Value = "OK"

-Else

-Range("D609").Value = "NG"

-End If

-End Function

-

-Function test_xlSpeakByRows(ByRef num)

-Range("A610").Clear

-Range("B610").Clear

-Range("C610").Clear

-Range("D610").Clear

-Range("A610").Value = "xlSpeakByRows"

-Range("B610").Value = 0

-Range("C610").Value = num

-B610 = Range("B610").Value

-C610 = Range("C610").Value

-If B610 = C610 Then

-Range("D610").Value = "OK"

-Else

-Range("D610").Value = "NG"

-End If

-End Function

-

-Function test_xlErrors(ByRef num)

-Range("A611").Clear

-Range("B611").Clear

-Range("C611").Clear

-Range("D611").Clear

-Range("A611").Value = "xlErrors"

-Range("B611").Value = 16

-Range("C611").Value = num

-B611 = Range("B611").Value

-C611 = Range("C611").Value

-If B611 = C611 Then

-Range("D611").Value = "OK"

-Else

-Range("D611").Value = "NG"

-End If

-End Function

-

-Function test_xlLogical(ByRef num)

-Range("A612").Clear

-Range("B612").Clear

-Range("C612").Clear

-Range("D612").Clear

-Range("A612").Value = "xlLogical"

-Range("B612").Value = 4

-Range("C612").Value = num

-B612 = Range("B612").Value

-C612 = Range("C612").Value

-If B612 = C612 Then

-Range("D612").Value = "OK"

-Else

-Range("D612").Value = "NG"

-End If

-End Function

-

-Function test_xlNumbers(ByRef num)

-Range("A613").Clear

-Range("B613").Clear

-Range("C613").Clear

-Range("D613").Clear

-Range("A613").Value = "xlNumbers"

-Range("B613").Value = 1

-Range("C613").Value = num

-B613 = Range("B613").Value

-C613 = Range("C613").Value

-If B613 = C613 Then

-Range("D613").Value = "OK"

-Else

-Range("D613").Value = "NG"

-End If

-End Function

-

-Function test_xlTextValues(ByRef num)

-Range("A614").Clear

-Range("B614").Clear

-Range("C614").Clear

-Range("D614").Clear

-Range("A614").Value = "xlTextValues"

-Range("B614").Value = 2

-Range("C614").Value = num

-B614 = Range("B614").Value

-C614 = Range("C614").Value

-If B614 = C614 Then

-Range("D614").Value = "OK"

-Else

-Range("D614").Value = "NG"

-End If

-End Function

-

-Function test_xlSubscribeToPicture(ByRef num)

-Range("A615").Clear

-Range("B615").Clear

-Range("C615").Clear

-Range("D615").Clear

-Range("A615").Value = "xlSubscribeToPicture"

-Range("B615").Value = -4147

-Range("C615").Value = num

-B615 = Range("B615").Value

-C615 = Range("C615").Value

-If B615 = C615 Then

-Range("D615").Value = "OK"

-Else

-Range("D615").Value = "NG"

-End If

-End Function

-

-Function test_xlSubscribeToText(ByRef num)

-Range("A616").Clear

-Range("B616").Clear

-Range("C616").Clear

-Range("D616").Clear

-Range("A616").Value = "xlSubscribeToText"

-Range("B616").Value = -4158

-Range("C616").Value = num

-B616 = Range("B616").Value

-C616 = Range("C616").Value

-If B616 = C616 Then

-Range("D616").Value = "OK"

-Else

-Range("D616").Value = "NG"

-End If

-End Function

-

-Function test_xlAtBottom(ByRef num)

-Range("A617").Clear

-Range("B617").Clear

-Range("C617").Clear

-Range("D617").Clear

-Range("A617").Value = "xlAtBottom"

-Range("B617").Value = 2

-Range("C617").Value = num

-B617 = Range("B617").Value

-C617 = Range("C617").Value

-If B617 = C617 Then

-Range("D617").Value = "OK"

-Else

-Range("D617").Value = "NG"

-End If

-End Function

-

-Function test_xlAtTop(ByRef num)

-Range("A618").Clear

-Range("B618").Clear

-Range("C618").Clear

-Range("D618").Clear

-Range("A618").Value = "xlAtTop"

-Range("B618").Value = 1

-Range("C618").Value = num

-B618 = Range("B618").Value

-C618 = Range("C618").Value

-If B618 = C618 Then

-Range("D618").Value = "OK"

-Else

-Range("D618").Value = "NG"

-End If

-End Function

-

-Function test_xlSummaryOnLeft(ByRef num)

-Range("A619").Clear

-Range("B619").Clear

-Range("C619").Clear

-Range("D619").Clear

-Range("A619").Value = "xlSummaryOnLeft"

-Range("B619").Value = -4131

-Range("C619").Value = num

-B619 = Range("B619").Value

-C619 = Range("C619").Value

-If B619 = C619 Then

-Range("D619").Value = "OK"

-Else

-Range("D619").Value = "NG"

-End If

-End Function

-

-Function test_xlSummaryOnRight(ByRef num)

-Range("A620").Clear

-Range("B620").Clear

-Range("C620").Clear

-Range("D620").Clear

-Range("A620").Value = "xlSummaryOnRight"

-Range("B620").Value = -4152

-Range("C620").Value = num

-B620 = Range("B620").Value

-C620 = Range("C620").Value

-If B620 = C620 Then

-Range("D620").Value = "OK"

-Else

-Range("D620").Value = "NG"

-End If

-End Function

-

-Function test_xlStandardSummary(ByRef num)

-Range("A621").Clear

-Range("B621").Clear

-Range("C621").Clear

-Range("D621").Clear

-Range("A621").Value = "xlStandardSummary"

-Range("B621").Value = 1

-Range("C621").Value = num

-B621 = Range("B621").Value

-C621 = Range("C621").Value

-If B621 = C621 Then

-Range("D621").Value = "OK"

-Else

-Range("D621").Value = "NG"

-End If

-End Function

-

-Function test_xlSummaryPivotTable(ByRef num)

-Range("A622").Clear

-Range("B622").Clear

-Range("C622").Clear

-Range("D622").Clear

-Range("A622").Value = "xlSummaryPivotTable"

-Range("B622").Value = -4148

-Range("C622").Value = num

-B622 = Range("B622").Value

-C622 = Range("C622").Value

-If B622 = C622 Then

-Range("D622").Value = "OK"

-Else

-Range("D622").Value = "NG"

-End If

-End Function

-

-Function test_xlSummaryAbove(ByRef num)

-Range("A623").Clear

-Range("B623").Clear

-Range("C623").Clear

-Range("D623").Clear

-Range("A623").Value = "xlSummaryAbove"

-Range("B623").Value = 0

-Range("C623").Value = num

-B623 = Range("B623").Value

-C623 = Range("C623").Value

-If B623 = C623 Then

-Range("D623").Value = "OK"

-Else

-Range("D623").Value = "NG"

-End If

-End Function

-

-Function test_xlSummaryBelow(ByRef num)

-Range("A624").Clear

-Range("B624").Clear

-Range("C624").Clear

-Range("D624").Clear

-Range("A624").Value = "xlSummaryBelow"

-Range("B624").Value = 1

-Range("C624").Value = num

-B624 = Range("B624").Value

-C624 = Range("C624").Value

-If B624 = C624 Then

-Range("D624").Value = "OK"

-Else

-Range("D624").Value = "NG"

-End If

-End Function

-

-Function test_xlTabPositionFirst(ByRef num)

-Range("A625").Clear

-Range("B625").Clear

-Range("C625").Clear

-Range("D625").Clear

-Range("A625").Value = "xlTabPositionFirst"

-Range("B625").Value = 0

-Range("C625").Value = num

-B625 = Range("B625").Value

-C625 = Range("C625").Value

-If B625 = C625 Then

-Range("D625").Value = "OK"

-Else

-Range("D625").Value = "NG"

-End If

-End Function

-

-Function test_xlTabPositionLast(ByRef num)

-Range("A626").Clear

-Range("B626").Clear

-Range("C626").Clear

-Range("D626").Clear

-Range("A626").Value = "xlTabPositionLast"

-Range("B626").Value = 1

-Range("C626").Value = num

-B626 = Range("B626").Value

-C626 = Range("C626").Value

-If B626 = C626 Then

-Range("D626").Value = "OK"

-Else

-Range("D626").Value = "NG"

-End If

-End Function

-

-Function test_xlDelimited(ByRef num)

-Range("A627").Clear

-Range("B627").Clear

-Range("C627").Clear

-Range("D627").Clear

-Range("A627").Value = "xlDelimited"

-Range("B627").Value = 1

-Range("C627").Value = num

-B627 = Range("B627").Value

-C627 = Range("C627").Value

-If B627 = C627 Then

-Range("D627").Value = "OK"

-Else

-Range("D627").Value = "NG"

-End If

-End Function

-

-Function test_xlFixedWidth(ByRef num)

-Range("A628").Clear

-Range("B628").Clear

-Range("C628").Clear

-Range("D628").Clear

-Range("A628").Value = "xlFixedWidth"

-Range("B628").Value = 2

-Range("C628").Value = num

-B628 = Range("B628").Value

-C628 = Range("C628").Value

-If B628 = C628 Then

-Range("D628").Value = "OK"

-Else

-Range("D628").Value = "NG"

-End If

-End Function

-

-Function test_xlTextQualifierDoubleQuote(ByRef num)

-Range("A629").Clear

-Range("B629").Clear

-Range("C629").Clear

-Range("D629").Clear

-Range("A629").Value = "xlTextQualifierDoubleQuote"

-Range("B629").Value = 1

-Range("C629").Value = num

-B629 = Range("B629").Value

-C629 = Range("C629").Value

-If B629 = C629 Then

-Range("D629").Value = "OK"

-Else

-Range("D629").Value = "NG"

-End If

-End Function

-

-Function test_xlTextQualifierNone(ByRef num)

-Range("A630").Clear

-Range("B630").Clear

-Range("C630").Clear

-Range("D630").Clear

-Range("A630").Value = "xlTextQualifierNone"

-Range("B630").Value = -4142

-Range("C630").Value = num

-B630 = Range("B630").Value

-C630 = Range("C630").Value

-If B630 = C630 Then

-Range("D630").Value = "OK"

-Else

-Range("D630").Value = "NG"

-End If

-End Function

-

-Function test_xlTextQualifierSingleQuote(ByRef num)

-Range("A631").Clear

-Range("B631").Clear

-Range("C631").Clear

-Range("D631").Clear

-Range("A631").Value = "xlTextQualifierSingleQuote"

-Range("B631").Value = 2

-Range("C631").Value = num

-B631 = Range("B631").Value

-C631 = Range("C631").Value

-If B631 = C631 Then

-Range("D631").Value = "OK"

-Else

-Range("D631").Value = "NG"

-End If

-End Function

-

-Function test_xlTextVisualLTR(ByRef num)

-Range("A632").Clear

-Range("B632").Clear

-Range("C632").Clear

-Range("D632").Clear

-Range("A632").Value = "xlTextVisualLTR"

-Range("B632").Value = 1

-Range("C632").Value = num

-B632 = Range("B632").Value

-C632 = Range("C632").Value

-If B632 = C632 Then

-Range("D632").Value = "OK"

-Else

-Range("D632").Value = "NG"

-End If

-End Function

-

-Function test_xlTextVisualRTL(ByRef num)

-Range("A633").Clear

-Range("B633").Clear

-Range("C633").Clear

-Range("D633").Clear

-Range("A633").Value = "xlTextVisualRTL"

-Range("B633").Value = 2

-Range("C633").Value = num

-B633 = Range("B633").Value

-C633 = Range("C633").Value

-If B633 = C633 Then

-Range("D633").Value = "OK"

-Else

-Range("D633").Value = "NG"

-End If

-End Function

-

-Function test_XlTickLabelOrientationAutomatic(ByRef num)

-Range("A634").Clear

-Range("B634").Clear

-Range("C634").Clear

-Range("D634").Clear

-Range("A634").Value = "XlTickLabelOrientationAutomatic"

-Range("B634").Value = -4105

-Range("C634").Value = num

-B634 = Range("B634").Value

-C634 = Range("C634").Value

-If B634 = C634 Then

-Range("D634").Value = "OK"

-Else

-Range("D634").Value = "NG"

-End If

-End Function

-

-Function test_XlTickLabelOrientationDownward(ByRef num)

-Range("A635").Clear

-Range("B635").Clear

-Range("C635").Clear

-Range("D635").Clear

-Range("A635").Value = "XlTickLabelOrientationDownward"

-Range("B635").Value = -4170

-Range("C635").Value = num

-B635 = Range("B635").Value

-C635 = Range("C635").Value

-If B635 = C635 Then

-Range("D635").Value = "OK"

-Else

-Range("D635").Value = "NG"

-End If

-End Function

-

-Function test_XlTickLabelOrientationHorizontal(ByRef num)

-Range("A636").Clear

-Range("B636").Clear

-Range("C636").Clear

-Range("D636").Clear

-Range("A636").Value = "XlTickLabelOrientationHorizontal"

-Range("B636").Value = -4128

-Range("C636").Value = num

-B636 = Range("B636").Value

-C636 = Range("C636").Value

-If B636 = C636 Then

-Range("D636").Value = "OK"

-Else

-Range("D636").Value = "NG"

-End If

-End Function

-

-Function test_XlTickLabelOrientationUpward(ByRef num)

-Range("A637").Clear

-Range("B637").Clear

-Range("C637").Clear

-Range("D637").Clear

-Range("A637").Value = "XlTickLabelOrientationUpward"

-Range("B637").Value = -4171

-Range("C637").Value = num

-B637 = Range("B637").Value

-C637 = Range("C637").Value

-If B637 = C637 Then

-Range("D637").Value = "OK"

-Else

-Range("D637").Value = "NG"

-End If

-End Function

-

-Function test_XlTickLabelOrientationVertical(ByRef num)

-Range("A638").Clear

-Range("B638").Clear

-Range("C638").Clear

-Range("D638").Clear

-Range("A638").Value = "XlTickLabelOrientationVertical"

-Range("B638").Value = -4166

-Range("C638").Value = num

-B638 = Range("B638").Value

-C638 = Range("C638").Value

-If B638 = C638 Then

-Range("D638").Value = "OK"

-Else

-Range("D638").Value = "NG"

-End If

-End Function

-

-Function test_xlTickLabelPositionHigh(ByRef num)

-Range("A639").Clear

-Range("B639").Clear

-Range("C639").Clear

-Range("D639").Clear

-Range("A639").Value = "xlTickLabelPositionHigh"

-Range("B639").Value = -4127

-Range("C639").Value = num

-B639 = Range("B639").Value

-C639 = Range("C639").Value

-If B639 = C639 Then

-Range("D639").Value = "OK"

-Else

-Range("D639").Value = "NG"

-End If

-End Function

-

-Function test_xlTickLabelPositionLow(ByRef num)

-Range("A640").Clear

-Range("B640").Clear

-Range("C640").Clear

-Range("D640").Clear

-Range("A640").Value = "xlTickLabelPositionLow"

-Range("B640").Value = -4134

-Range("C640").Value = num

-B640 = Range("B640").Value

-C640 = Range("C640").Value

-If B640 = C640 Then

-Range("D640").Value = "OK"

-Else

-Range("D640").Value = "NG"

-End If

-End Function

-

-Function test_xlTickLabelPositionNextToAxis(ByRef num)

-Range("A641").Clear

-Range("B641").Clear

-Range("C641").Clear

-Range("D641").Clear

-Range("A641").Value = "xlTickLabelPositionNextToAxis"

-Range("B641").Value = 4

-Range("C641").Value = num

-B641 = Range("B641").Value

-C641 = Range("C641").Value

-If B641 = C641 Then

-Range("D641").Value = "OK"

-Else

-Range("D641").Value = "NG"

-End If

-End Function

-

-Function test_xlTickLabelPositionNone(ByRef num)

-Range("A642").Clear

-Range("B642").Clear

-Range("C642").Clear

-Range("D642").Clear

-Range("A642").Value = "xlTickLabelPositionNone"

-Range("B642").Value = -4142

-Range("C642").Value = num

-B642 = Range("B642").Value

-C642 = Range("C642").Value

-If B642 = C642 Then

-Range("D642").Value = "OK"

-Else

-Range("D642").Value = "NG"

-End If

-End Function

-

-Function test_xlTickMarkCross(ByRef num)

-Range("A643").Clear

-Range("B643").Clear

-Range("C643").Clear

-Range("D643").Clear

-Range("A643").Value = "xlTickMarkCross"

-Range("B643").Value = 4

-Range("C643").Value = num

-B643 = Range("B643").Value

-C643 = Range("C643").Value

-If B643 = C643 Then

-Range("D643").Value = "OK"

-Else

-Range("D643").Value = "NG"

-End If

-End Function

-

-Function test_xlTickMarkInside(ByRef num)

-Range("A644").Clear

-Range("B644").Clear

-Range("C644").Clear

-Range("D644").Clear

-Range("A644").Value = "xlTickMarkInside"

-Range("B644").Value = 2

-Range("C644").Value = num

-B644 = Range("B644").Value

-C644 = Range("C644").Value

-If B644 = C644 Then

-Range("D644").Value = "OK"

-Else

-Range("D644").Value = "NG"

-End If

-End Function

-

-Function test_xlTickMarkNone(ByRef num)

-Range("A645").Clear

-Range("B645").Clear

-Range("C645").Clear

-Range("D645").Clear

-Range("A645").Value = "xlTickMarkNone"

-Range("B645").Value = -4142

-Range("C645").Value = num

-B645 = Range("B645").Value

-C645 = Range("C645").Value

-If B645 = C645 Then

-Range("D645").Value = "OK"

-Else

-Range("D645").Value = "NG"

-End If

-End Function

-

-Function test_xlTickMarkOutside(ByRef num)

-Range("A646").Clear

-Range("B646").Clear

-Range("C646").Clear

-Range("D646").Clear

-Range("A646").Value = "xlTickMarkOutside"

-Range("B646").Value = 3

-Range("C646").Value = num

-B646 = Range("B646").Value

-C646 = Range("C646").Value

-If B646 = C646 Then

-Range("D646").Value = "OK"

-Else

-Range("D646").Value = "NG"

-End If

-End Function

-

-Function test_xlDays(ByRef num)

-Range("A647").Clear

-Range("B647").Clear

-Range("C647").Clear

-Range("D647").Clear

-Range("A647").Value = "xlDays"

-Range("B647").Value = 0

-Range("C647").Value = num

-B647 = Range("B647").Value

-C647 = Range("C647").Value

-If B647 = C647 Then

-Range("D647").Value = "OK"

-Else

-Range("D647").Value = "NG"

-End If

-End Function

-

-Function test_xlMonths(ByRef num)

-Range("A648").Clear

-Range("B648").Clear

-Range("C648").Clear

-Range("D648").Clear

-Range("A648").Value = "xlMonths"

-Range("B648").Value = 1

-Range("C648").Value = num

-B648 = Range("B648").Value

-C648 = Range("C648").Value

-If B648 = C648 Then

-Range("D648").Value = "OK"

-Else

-Range("D648").Value = "NG"

-End If

-End Function

-

-Function test_xlYears(ByRef num)

-Range("A649").Clear

-Range("B649").Clear

-Range("C649").Clear

-Range("D649").Clear

-Range("A649").Value = "xlYears"

-Range("B649").Value = 2

-Range("C649").Value = num

-B649 = Range("B649").Value

-C649 = Range("C649").Value

-If B649 = C649 Then

-Range("D649").Value = "OK"

-Else

-Range("D649").Value = "NG"

-End If

-End Function

-

-Function test_xlNoButtonChanges(ByRef num)

-Range("A650").Clear

-Range("B650").Clear

-Range("C650").Clear

-Range("D650").Clear

-Range("A650").Value = "xlNoButtonChanges"

-Range("B650").Value = 1

-Range("C650").Value = num

-B650 = Range("B650").Value

-C650 = Range("C650").Value

-If B650 = C650 Then

-Range("D650").Value = "OK"

-Else

-Range("D650").Value = "NG"

-End If

-End Function

-

-Function test_xlNoChanges(ByRef num)

-Range("A651").Clear

-Range("B651").Clear

-Range("C651").Clear

-Range("D651").Clear

-Range("A651").Value = "xlNoChanges"

-Range("B651").Value = 4

-Range("C651").Value = num

-B651 = Range("B651").Value

-C651 = Range("C651").Value

-If B651 = C651 Then

-Range("D651").Value = "OK"

-Else

-Range("D651").Value = "NG"

-End If

-End Function

-

-Function test_xlNoDockingChanges(ByRef num)

-Range("A652").Clear

-Range("B652").Clear

-Range("C652").Clear

-Range("D652").Clear

-Range("A652").Value = "xlNoDockingChanges"

-Range("B652").Value = 3

-Range("C652").Value = num

-B652 = Range("B652").Value

-C652 = Range("C652").Value

-If B652 = C652 Then

-Range("D652").Value = "OK"

-Else

-Range("D652").Value = "NG"

-End If

-End Function

-

-Function test_xlNoShapeChanges(ByRef num)

-Range("A653").Clear

-Range("B653").Clear

-Range("C653").Clear

-Range("D653").Clear

-Range("A653").Value = "xlNoShapeChanges"

-Range("B653").Value = 2

-Range("C653").Value = num

-B653 = Range("B653").Value

-C653 = Range("C653").Value

-If B653 = C653 Then

-Range("D653").Value = "OK"

-Else

-Range("D653").Value = "NG"

-End If

-End Function

-

-Function test_xlToolbarProtectionNone(ByRef num)

-Range("A654").Clear

-Range("B654").Clear

-Range("C654").Clear

-Range("D654").Clear

-Range("A654").Value = "xlToolbarProtectionNone"

-Range("B654").Value = -4143

-Range("C654").Value = num

-B654 = Range("B654").Value

-C654 = Range("C654").Value

-If B654 = C654 Then

-Range("D654").Value = "OK"

-Else

-Range("D654").Value = "NG"

-End If

-End Function

-

-Function test_xlTotalsCalculationAverage(ByRef num)

-Range("A655").Clear

-Range("B655").Clear

-Range("C655").Clear

-Range("D655").Clear

-Range("A655").Value = "xlTotalsCalculationAverage"

-Range("B655").Value = 2

-Range("C655").Value = num

-B655 = Range("B655").Value

-C655 = Range("C655").Value

-If B655 = C655 Then

-Range("D655").Value = "OK"

-Else

-Range("D655").Value = "NG"

-End If

-End Function

-

-Function test_xlTotalsCalculationCount(ByRef num)

-Range("A656").Clear

-Range("B656").Clear

-Range("C656").Clear

-Range("D656").Clear

-Range("A656").Value = "xlTotalsCalculationCount"

-Range("B656").Value = 3

-Range("C656").Value = num

-B656 = Range("B656").Value

-C656 = Range("C656").Value

-If B656 = C656 Then

-Range("D656").Value = "OK"

-Else

-Range("D656").Value = "NG"

-End If

-End Function

-

-Function test_xlTotalsCalculationCountNums(ByRef num)

-Range("A657").Clear

-Range("B657").Clear

-Range("C657").Clear

-Range("D657").Clear

-Range("A657").Value = "xlTotalsCalculationCountNums"

-Range("B657").Value = 4

-Range("C657").Value = num

-B657 = Range("B657").Value

-C657 = Range("C657").Value

-If B657 = C657 Then

-Range("D657").Value = "OK"

-Else

-Range("D657").Value = "NG"

-End If

-End Function

-

-Function test_xlTotalsCalculationCountMax(ByRef num)

-Range("A658").Clear

-Range("B658").Clear

-Range("C658").Clear

-Range("D658").Clear

-Range("A658").Value = "xlTotalsCalculationCountMax"

-Range("B658").Value = 6

-Range("C658").Value = num

-B658 = Range("B658").Value

-C658 = Range("C658").Value

-If B658 = C658 Then

-Range("D658").Value = "OK"

-Else

-Range("D658").Value = "NG"

-End If

-End Function

-

-Function test_xlTotalsCalculationCountMin(ByRef num)

-Range("A659").Clear

-Range("B659").Clear

-Range("C659").Clear

-Range("D659").Clear

-Range("A659").Value = "xlTotalsCalculationCountMin"

-Range("B659").Value = 5

-Range("C659").Value = num

-B659 = Range("B659").Value

-C659 = Range("C659").Value

-If B659 = C659 Then

-Range("D659").Value = "OK"

-Else

-Range("D659").Value = "NG"

-End If

-End Function

-

-Function test_xlTotalsCalculationCountNone(ByRef num)

-Range("A660").Clear

-Range("B660").Clear

-Range("C660").Clear

-Range("D660").Clear

-Range("A660").Value = "xlTotalsCalculationCountNone"

-Range("B660").Value = 0

-Range("C660").Value = num

-B660 = Range("B660").Value

-C660 = Range("C660").Value

-If B660 = C660 Then

-Range("D660").Value = "OK"

-Else

-Range("D660").Value = "NG"

-End If

-End Function

-

-Function test_xlTotalsCalculationCountStdDev(ByRef num)

-Range("A661").Clear

-Range("B661").Clear

-Range("C661").Clear

-Range("D661").Clear

-Range("A661").Value = "xlTotalsCalculationCountStdDev"

-Range("B661").Value = 7

-Range("C661").Value = num

-B661 = Range("B661").Value

-C661 = Range("C661").Value

-If B661 = C661 Then

-Range("D661").Value = "OK"

-Else

-Range("D661").Value = "NG"

-End If

-End Function

-

-Function test_xlTotalsCalculationCountSum(ByRef num)

-Range("A662").Clear

-Range("B662").Clear

-Range("C662").Clear

-Range("D662").Clear

-Range("A662").Value = "xlTotalsCalculationCountSum"

-Range("B662").Value = 1

-Range("C662").Value = num

-B662 = Range("B662").Value

-C662 = Range("C662").Value

-If B662 = C662 Then

-Range("D662").Value = "OK"

-Else

-Range("D662").Value = "NG"

-End If

-End Function

-

-Function test_xlTotalsCalculationCountVar(ByRef num)

-Range("A663").Clear

-Range("B663").Clear

-Range("C663").Clear

-Range("D663").Clear

-Range("A663").Value = "xlTotalsCalculationCountVar"

-Range("B663").Value = 8

-Range("C663").Value = num

-B663 = Range("B663").Value

-C663 = Range("C663").Value

-If B663 = C663 Then

-Range("D663").Value = "OK"

-Else

-Range("D663").Value = "NG"

-End If

-End Function

-

-Function test_xlExponential(ByRef num)

-Range("A664").Clear

-Range("B664").Clear

-Range("C664").Clear

-Range("D664").Clear

-Range("A664").Value = "xlExponential"

-Range("B664").Value = 5

-Range("C664").Value = num

-B664 = Range("B664").Value

-C664 = Range("C664").Value

-If B664 = C664 Then

-Range("D664").Value = "OK"

-Else

-Range("D664").Value = "NG"

-End If

-End Function

-

-Function test_xlLinear(ByRef num)

-Range("A665").Clear

-Range("B665").Clear

-Range("C665").Clear

-Range("D665").Clear

-Range("A665").Value = "xlLinear"

-Range("B665").Value = -4132

-Range("C665").Value = num

-B665 = Range("B665").Value

-C665 = Range("C665").Value

-If B665 = C665 Then

-Range("D665").Value = "OK"

-Else

-Range("D665").Value = "NG"

-End If

-End Function

-

-Function test_xlLogarithmic(ByRef num)

-Range("A666").Clear

-Range("B666").Clear

-Range("C666").Clear

-Range("D666").Clear

-Range("A666").Value = "xlLogarithmic"

-Range("B666").Value = -4133

-Range("C666").Value = num

-B666 = Range("B666").Value

-C666 = Range("C666").Value

-If B666 = C666 Then

-Range("D666").Value = "OK"

-Else

-Range("D666").Value = "NG"

-End If

-End Function

-

-Function test_xlMovingAvg(ByRef num)

-Range("A667").Clear

-Range("B667").Clear

-Range("C667").Clear

-Range("D667").Clear

-Range("A667").Value = "xlMovingAvg"

-Range("B667").Value = 6

-Range("C667").Value = num

-B667 = Range("B667").Value

-C667 = Range("C667").Value

-If B667 = C667 Then

-Range("D667").Value = "OK"

-Else

-Range("D667").Value = "NG"

-End If

-End Function

-

-Function test_xlPolynomial(ByRef num)

-Range("A668").Clear

-Range("B668").Clear

-Range("C668").Clear

-Range("D668").Clear

-Range("A668").Value = "xlPolynomial"

-Range("B668").Value = 3

-Range("C668").Value = num

-B668 = Range("B668").Value

-C668 = Range("C668").Value

-If B668 = C668 Then

-Range("D668").Value = "OK"

-Else

-Range("D668").Value = "NG"

-End If

-End Function

-

-Function test_xlPower(ByRef num)

-Range("A669").Clear

-Range("B669").Clear

-Range("C669").Clear

-Range("D669").Clear

-Range("A669").Value = "xlPower"

-Range("B669").Value = 4

-Range("C669").Value = num

-B669 = Range("B669").Value

-C669 = Range("C669").Value

-If B669 = C669 Then

-Range("D669").Value = "OK"

-Else

-Range("D669").Value = "NG"

-End If

-End Function

-

-Function test_XlUnderlineStyleDouble(ByRef num)

-Range("A670").Clear

-Range("B670").Clear

-Range("C670").Clear

-Range("D670").Clear

-Range("A670").Value = "XlUnderlineStyleDouble"

-Range("B670").Value = -4119

-Range("C670").Value = num

-B670 = Range("B670").Value

-C670 = Range("C670").Value

-If B670 = C670 Then

-Range("D670").Value = "OK"

-Else

-Range("D670").Value = "NG"

-End If

-End Function

-

-Function test_XlUnderlineStyleDoubleAccounting(ByRef num)

-Range("A671").Clear

-Range("B671").Clear

-Range("C671").Clear

-Range("D671").Clear

-Range("A671").Value = "XlUnderlineStyleDoubleAccounting"

-Range("B671").Value = 5

-Range("C671").Value = num

-B671 = Range("B671").Value

-C671 = Range("C671").Value

-If B671 = C671 Then

-Range("D671").Value = "OK"

-Else

-Range("D671").Value = "NG"

-End If

-End Function

-

-Function test_XlUnderlineStyleNone(ByRef num)

-Range("A672").Clear

-Range("B672").Clear

-Range("C672").Clear

-Range("D672").Clear

-Range("A672").Value = "XlUnderlineStyleNone"

-Range("B672").Value = -4142

-Range("C672").Value = num

-B672 = Range("B672").Value

-C672 = Range("C672").Value

-If B672 = C672 Then

-Range("D672").Value = "OK"

-Else

-Range("D672").Value = "NG"

-End If

-End Function

-

-Function test_XlUnderlineStyleSingle(ByRef num)

-Range("A673").Clear

-Range("B673").Clear

-Range("C673").Clear

-Range("D673").Clear

-Range("A673").Value = "XlUnderlineStyleSingle"

-Range("B673").Value = 2

-Range("C673").Value = num

-B673 = Range("B673").Value

-C673 = Range("C673").Value

-If B673 = C673 Then

-Range("D673").Value = "OK"

-Else

-Range("D673").Value = "NG"

-End If

-End Function

-

-Function test_XlUnderlineStyleSingleAccounting(ByRef num)

-Range("A674").Clear

-Range("B674").Clear

-Range("C674").Clear

-Range("D674").Clear

-Range("A674").Value = "XlUnderlineStyleSingleAccounting"

-Range("B674").Value = 4

-Range("C674").Value = num

-B674 = Range("B674").Value

-C674 = Range("C674").Value

-If B674 = C674 Then

-Range("D674").Value = "OK"

-Else

-Range("D674").Value = "NG"

-End If

-End Function

-

-Function test_XlUpdateLinksAlways(ByRef num)

-Range("A675").Clear

-Range("B675").Clear

-Range("C675").Clear

-Range("D675").Clear

-Range("A675").Value = "XlUpdateLinksAlways"

-Range("B675").Value = 3

-Range("C675").Value = num

-B675 = Range("B675").Value

-C675 = Range("C675").Value

-If B675 = C675 Then

-Range("D675").Value = "OK"

-Else

-Range("D675").Value = "NG"

-End If

-End Function

-

-Function test_XlUpdateLinksNever(ByRef num)

-Range("A676").Clear

-Range("B676").Clear

-Range("C676").Clear

-Range("D676").Clear

-Range("A676").Value = "XlUpdateLinksNever"

-Range("B676").Value = 2

-Range("C676").Value = num

-B676 = Range("B676").Value

-C676 = Range("C676").Value

-If B676 = C676 Then

-Range("D676").Value = "OK"

-Else

-Range("D676").Value = "NG"

-End If

-End Function

-

-Function test_XlUpdateLinksUserSetting(ByRef num)

-Range("A677").Clear

-Range("B677").Clear

-Range("C677").Clear

-Range("D677").Clear

-Range("A677").Value = "XlUpdateLinksUserSetting"

-Range("B677").Value = 1

-Range("C677").Value = num

-B677 = Range("B677").Value

-C677 = Range("C677").Value

-If B677 = C677 Then

-Range("D677").Value = "OK"

-Else

-Range("D677").Value = "NG"

-End If

-End Function

-

-Function test_xlVAlignBottom(ByRef num)

-Range("A678").Clear

-Range("B678").Clear

-Range("C678").Clear

-Range("D678").Clear

-Range("A678").Value = "xlVAlignBottom"

-Range("B678").Value = -4107

-Range("C678").Value = num

-B678 = Range("B678").Value

-C678 = Range("C678").Value

-If B678 = C678 Then

-Range("D678").Value = "OK"

-Else

-Range("D678").Value = "NG"

-End If

-End Function

-

-Function test_xlVAlignCenter(ByRef num)

-Range("A679").Clear

-Range("B679").Clear

-Range("C679").Clear

-Range("D679").Clear

-Range("A679").Value = "xlVAlignCenter"

-Range("B679").Value = -4108

-Range("C679").Value = num

-B679 = Range("B679").Value

-C679 = Range("C679").Value

-If B679 = C679 Then

-Range("D679").Value = "OK"

-Else

-Range("D679").Value = "NG"

-End If

-End Function

-

-Function test_xlVAlignDistributed(ByRef num)

-Range("A680").Clear

-Range("B680").Clear

-Range("C680").Clear

-Range("D680").Clear

-Range("A680").Value = "xlVAlignDistributed"

-Range("B680").Value = -4117

-Range("C680").Value = num

-B680 = Range("B680").Value

-C680 = Range("C680").Value

-If B680 = C680 Then

-Range("D680").Value = "OK"

-Else

-Range("D680").Value = "NG"

-End If

-End Function

-

-Function test_xlVAlignJustify(ByRef num)

-Range("A681").Clear

-Range("B681").Clear

-Range("C681").Clear

-Range("D681").Clear

-Range("A681").Value = "xlVAlignJustify"

-Range("B681").Value = -4130

-Range("C681").Value = num

-B681 = Range("B681").Value

-C681 = Range("C681").Value

-If B681 = C681 Then

-Range("D681").Value = "OK"

-Else

-Range("D681").Value = "NG"

-End If

-End Function

-

-Function test_xlVAlignTop(ByRef num)

-Range("A682").Clear

-Range("B682").Clear

-Range("C682").Clear

-Range("D682").Clear

-Range("A682").Value = "xlVAlignTop"

-Range("B682").Value = -4160

-Range("C682").Value = num

-B682 = Range("B682").Value

-C682 = Range("C682").Value

-If B682 = C682 Then

-Range("D682").Value = "OK"

-Else

-Range("D682").Value = "NG"

-End If

-End Function

-

-Function test_XlWBATChart(ByRef num)

-Range("A683").Clear

-Range("B683").Clear

-Range("C683").Clear

-Range("D683").Clear

-Range("A683").Value = "XlWBATChart"

-Range("B683").Value = -4109

-Range("C683").Value = num

-B683 = Range("B683").Value

-C683 = Range("C683").Value

-If B683 = C683 Then

-Range("D683").Value = "OK"

-Else

-Range("D683").Value = "NG"

-End If

-End Function

-

-Function test_XlWBATExcel4IntlMacroSheet(ByRef num)

-Range("A684").Clear

-Range("B684").Clear

-Range("C684").Clear

-Range("D684").Clear

-Range("A684").Value = "XlWBATExcel4IntlMacroSheet"

-Range("B684").Value = 4

-Range("C684").Value = num

-B684 = Range("B684").Value

-C684 = Range("C684").Value

-If B684 = C684 Then

-Range("D684").Value = "OK"

-Else

-Range("D684").Value = "NG"

-End If

-End Function

-

-Function test_XlWBATExcel4MacroSheet(ByRef num)

-Range("A685").Clear

-Range("B685").Clear

-Range("C685").Clear

-Range("D685").Clear

-Range("A685").Value = "XlWBATExcel4MacroSheet"

-Range("B685").Value = 3

-Range("C685").Value = num

-B685 = Range("B685").Value

-C685 = Range("C685").Value

-If B685 = C685 Then

-Range("D685").Value = "OK"

-Else

-Range("D685").Value = "NG"

-End If

-End Function

-

-Function test_XlWBATWorksheet(ByRef num)

-Range("A686").Clear

-Range("B686").Clear

-Range("C686").Clear

-Range("D686").Clear

-Range("A686").Value = "XlWBATWorksheet"

-Range("B686").Value = -4167

-Range("C686").Value = num

-B686 = Range("B686").Value

-C686 = Range("C686").Value

-If B686 = C686 Then

-Range("D686").Value = "OK"

-Else

-Range("D686").Value = "NG"

-End If

-End Function

-

-Function test_xlWebFormattingAll(ByRef num)

-Range("A687").Clear

-Range("B687").Clear

-Range("C687").Clear

-Range("D687").Clear

-Range("A687").Value = "xlWebFormattingAll"

-Range("B687").Value = 1

-Range("C687").Value = num

-B687 = Range("B687").Value

-C687 = Range("C687").Value

-If B687 = C687 Then

-Range("D687").Value = "OK"

-Else

-Range("D687").Value = "NG"

-End If

-End Function

-

-Function test_xlWebFormattingNone(ByRef num)

-Range("A688").Clear

-Range("B688").Clear

-Range("C688").Clear

-Range("D688").Clear

-Range("A688").Value = "xlWebFormattingNone"

-Range("B688").Value = 3

-Range("C688").Value = num

-B688 = Range("B688").Value

-C688 = Range("C688").Value

-If B688 = C688 Then

-Range("D688").Value = "OK"

-Else

-Range("D688").Value = "NG"

-End If

-End Function

-

-Function test_xlWebFormattingRTF(ByRef num)

-Range("A689").Clear

-Range("B689").Clear

-Range("C689").Clear

-Range("D689").Clear

-Range("A689").Value = "xlWebFormattingRTF"

-Range("B689").Value = 2

-Range("C689").Value = num

-B689 = Range("B689").Value

-C689 = Range("C689").Value

-If B689 = C689 Then

-Range("D689").Value = "OK"

-Else

-Range("D689").Value = "NG"

-End If

-End Function

-

-Function test_xlAllTables(ByRef num)

-Range("A690").Clear

-Range("B690").Clear

-Range("C690").Clear

-Range("D690").Clear

-Range("A690").Value = "xlAllTables"

-Range("B690").Value = 2

-Range("C690").Value = num

-B690 = Range("B690").Value

-C690 = Range("C690").Value

-If B690 = C690 Then

-Range("D690").Value = "OK"

-Else

-Range("D690").Value = "NG"

-End If

-End Function

-

-Function test_xlEntirePage(ByRef num)

-Range("A691").Clear

-Range("B691").Clear

-Range("C691").Clear

-Range("D691").Clear

-Range("A691").Value = "xlEntirePage"

-Range("B691").Value = 1

-Range("C691").Value = num

-B691 = Range("B691").Value

-C691 = Range("C691").Value

-If B691 = C691 Then

-Range("D691").Value = "OK"

-Else

-Range("D691").Value = "NG"

-End If

-End Function

-

-Function test_xlSpecifiedTables(ByRef num)

-Range("A692").Clear

-Range("B692").Clear

-Range("C692").Clear

-Range("D692").Clear

-Range("A692").Value = "xlSpecifiedTables"

-Range("B692").Value = 3

-Range("C692").Value = num

-B692 = Range("B692").Value

-C692 = Range("C692").Value

-If B692 = C692 Then

-Range("D692").Value = "OK"

-Else

-Range("D692").Value = "NG"

-End If

-End Function

-

-Function test_xlMaximized(ByRef num)

-Range("A693").Clear

-Range("B693").Clear

-Range("C693").Clear

-Range("D693").Clear

-Range("A693").Value = "xlMaximized"

-Range("B693").Value = -4137

-Range("C693").Value = num

-B693 = Range("B693").Value

-C693 = Range("C693").Value

-If B693 = C693 Then

-Range("D693").Value = "OK"

-Else

-Range("D693").Value = "NG"

-End If

-End Function

-

-Function test_xlMinimized(ByRef num)

-Range("A694").Clear

-Range("B694").Clear

-Range("C694").Clear

-Range("D694").Clear

-Range("A694").Value = "xlMinimized"

-Range("B694").Value = -4140

-Range("C694").Value = num

-B694 = Range("B694").Value

-C694 = Range("C694").Value

-If B694 = C694 Then

-Range("D694").Value = "OK"

-Else

-Range("D694").Value = "NG"

-End If

-End Function

-

-Function test_xlNormal(ByRef num)

-Range("A695").Clear

-Range("B695").Clear

-Range("C695").Clear

-Range("D695").Clear

-Range("A695").Value = "xlNormal"

-Range("B695").Value = -4143

-Range("C695").Value = num

-B695 = Range("B695").Value

-C695 = Range("C695").Value

-If B695 = C695 Then

-Range("D695").Value = "OK"

-Else

-Range("D695").Value = "NG"

-End If

-End Function

-

-Function test_xlChartAsWindow(ByRef num)

-Range("A696").Clear

-Range("B696").Clear

-Range("C696").Clear

-Range("D696").Clear

-Range("A696").Value = "xlChartAsWindow"

-Range("B696").Value = 5

-Range("C696").Value = num

-B696 = Range("B696").Value

-C696 = Range("C696").Value

-If B696 = C696 Then

-Range("D696").Value = "OK"

-Else

-Range("D696").Value = "NG"

-End If

-End Function

-

-Function test_xlChartInPlace(ByRef num)

-Range("A697").Clear

-Range("B697").Clear

-Range("C697").Clear

-Range("D697").Clear

-Range("A697").Value = "xlChartInPlace"

-Range("B697").Value = 4

-Range("C697").Value = num

-B697 = Range("B697").Value

-C697 = Range("C697").Value

-If B697 = C697 Then

-Range("D697").Value = "OK"

-Else

-Range("D697").Value = "NG"

-End If

-End Function

-

-Function test_xlClipboard(ByRef num)

-Range("A698").Clear

-Range("B698").Clear

-Range("C698").Clear

-Range("D698").Clear

-Range("A698").Value = "xlClipboard"

-Range("B698").Value = 3

-Range("C698").Value = num

-B698 = Range("B698").Value

-C698 = Range("C698").Value

-If B698 = C698 Then

-Range("D698").Value = "OK"

-Else

-Range("D698").Value = "NG"

-End If

-End Function

-

-Function test_xlInfo(ByRef num)

-Range("A699").Clear

-Range("B699").Clear

-Range("C699").Clear

-Range("D699").Clear

-Range("A699").Value = "xlInfo"

-Range("B699").Value = -4129

-Range("C699").Value = num

-B699 = Range("B699").Value

-C699 = Range("C699").Value

-If B699 = C699 Then

-Range("D699").Value = "OK"

-Else

-Range("D699").Value = "NG"

-End If

-End Function

-

-Function test_xlWordbook(ByRef num)

-Range("A700").Clear

-Range("B700").Clear

-Range("C700").Clear

-Range("D700").Clear

-Range("A700").Value = "xlWordbook"

-Range("B700").Value = 1

-Range("C700").Value = num

-B700 = Range("B700").Value

-C700 = Range("C700").Value

-If B700 = C700 Then

-Range("D700").Value = "OK"

-Else

-Range("D700").Value = "NG"

-End If

-End Function

-

-Function test_xlNormalView(ByRef num)

-Range("A701").Clear

-Range("B701").Clear

-Range("C701").Clear

-Range("D701").Clear

-Range("A701").Value = "xlNormalView"

-Range("B701").Value = 1

-Range("C701").Value = num

-B701 = Range("B701").Value

-C701 = Range("C701").Value

-If B701 = C701 Then

-Range("D701").Value = "OK"

-Else

-Range("D701").Value = "NG"

-End If

-End Function

-

-Function test_xlPageBreakPreview(ByRef num)

-Range("A702").Clear

-Range("B702").Clear

-Range("C702").Clear

-Range("D702").Clear

-Range("A702").Value = "xlPageBreakPreview"

-Range("B702").Value = 2

-Range("C702").Value = num

-B702 = Range("B702").Value

-C702 = Range("C702").Value

-If B702 = C702 Then

-Range("D702").Value = "OK"

-Else

-Range("D702").Value = "NG"

-End If

-End Function

-

-Function test_xlCommand(ByRef num)

-Range("A703").Clear

-Range("B703").Clear

-Range("C703").Clear

-Range("D703").Clear

-Range("A703").Value = "xlCommand"

-Range("B703").Value = 2

-Range("C703").Value = num

-B703 = Range("B703").Value

-C703 = Range("C703").Value

-If B703 = C703 Then

-Range("D703").Value = "OK"

-Else

-Range("D703").Value = "NG"

-End If

-End Function

-

-Function test_xlFunction(ByRef num)

-Range("A704").Clear

-Range("B704").Clear

-Range("C704").Clear

-Range("D704").Clear

-Range("A704").Value = "xlFunction"

-Range("B704").Value = 1

-Range("C704").Value = num

-B704 = Range("B704").Value

-C704 = Range("C704").Value

-If B704 = C704 Then

-Range("D704").Value = "OK"

-Else

-Range("D704").Value = "NG"

-End If

-End Function

-

-Function test_xlnotXLM(ByRef num)

-Range("A705").Clear

-Range("B705").Clear

-Range("C705").Clear

-Range("D705").Clear

-Range("A705").Value = "xlnotXLM"

-Range("B705").Value = 3

-Range("C705").Value = num

-B705 = Range("B705").Value

-C705 = Range("C705").Value

-If B705 = C705 Then

-Range("D705").Value = "OK"

-Else

-Range("D705").Value = "NG"

-End If

-End Function

-

-Function test_xlXmlExportSuccess(ByRef num)

-Range("A706").Clear

-Range("B706").Clear

-Range("C706").Clear

-Range("D706").Clear

-Range("A706").Value = "xlXmlExportSuccess"

-Range("B706").Value = 0

-Range("C706").Value = num

-B706 = Range("B706").Value

-C706 = Range("C706").Value

-If B706 = C706 Then

-Range("D706").Value = "OK"

-Else

-Range("D706").Value = "NG"

-End If

-End Function

-

-Function test_xlXmlExportValidationFailed(ByRef num)

-Range("A707").Clear

-Range("B707").Clear

-Range("C707").Clear

-Range("D707").Clear

-Range("A707").Value = "xlXmlExportValidationFailed"

-Range("B707").Value = 1

-Range("C707").Value = num

-B707 = Range("B707").Value

-C707 = Range("C707").Value

-If B707 = C707 Then

-Range("D707").Value = "OK"

-Else

-Range("D707").Value = "NG"

-End If

-End Function

-

-Function test_xlXmlImportElementsTruncated(ByRef num)

-Range("A708").Clear

-Range("B708").Clear

-Range("C708").Clear

-Range("D708").Clear

-Range("A708").Value = "xlXmlImportElementsTruncated"

-Range("B708").Value = 1

-Range("C708").Value = num

-B708 = Range("B708").Value

-C708 = Range("C708").Value

-If B708 = C708 Then

-Range("D708").Value = "OK"

-Else

-Range("D708").Value = "NG"

-End If

-End Function

-

-Function test_xlXmlImportSuccess(ByRef num)

-Range("A709").Clear

-Range("B709").Clear

-Range("C709").Clear

-Range("D709").Clear

-Range("A709").Value = "xlXmlImportSuccess"

-Range("B709").Value = 0

-Range("C709").Value = num

-B709 = Range("B709").Value

-C709 = Range("C709").Value

-If B709 = C709 Then

-Range("D709").Value = "OK"

-Else

-Range("D709").Value = "NG"

-End If

-End Function

-

-Function test_xlXmlImportValidationFailed(ByRef num)

-Range("A710").Clear

-Range("B710").Clear

-Range("C710").Clear

-Range("D710").Clear

-Range("A710").Value = "xlXmlImportValidationFailed"

-Range("B710").Value = 2

-Range("C710").Value = num

-B710 = Range("B710").Value

-C710 = Range("C710").Value

-If B710 = C710 Then

-Range("D710").Value = "OK"

-Else

-Range("D710").Value = "NG"

-End If

-End Function

-

-Function test_xlXmlLoadImportToList(ByRef num)

-Range("A711").Clear

-Range("B711").Clear

-Range("C711").Clear

-Range("D711").Clear

-Range("A711").Value = "xlXmlLoadImportToList"

-Range("B711").Value = 2

-Range("C711").Value = num

-B711 = Range("B711").Value

-C711 = Range("C711").Value

-If B711 = C711 Then

-Range("D711").Value = "OK"

-Else

-Range("D711").Value = "NG"

-End If

-End Function

-

-Function test_xlXmlLoadMapXml(ByRef num)

-Range("A712").Clear

-Range("B712").Clear

-Range("C712").Clear

-Range("D712").Clear

-Range("A712").Value = "xlXmlLoadMapXml"

-Range("B712").Value = 3

-Range("C712").Value = num

-B712 = Range("B712").Value

-C712 = Range("C712").Value

-If B712 = C712 Then

-Range("D712").Value = "OK"

-Else

-Range("D712").Value = "NG"

-End If

-End Function

-

-Function test_xlXmlLoadOpenXml(ByRef num)

-Range("A713").Clear

-Range("B713").Clear

-Range("C713").Clear

-Range("D713").Clear

-Range("A713").Value = "xlXmlLoadOpenXml"

-Range("B713").Value = 1

-Range("C713").Value = num

-B713 = Range("B713").Value

-C713 = Range("C713").Value

-If B713 = C713 Then

-Range("D713").Value = "OK"

-Else

-Range("D713").Value = "NG"

-End If

-End Function

-

-Function test_xlXmlLoadPromptUser(ByRef num)

-Range("A714").Clear

-Range("B714").Clear

-Range("C714").Clear

-Range("D714").Clear

-Range("A714").Value = "xlXmlLoadPromptUser"

-Range("B714").Value = 0

-Range("C714").Value = num

-B714 = Range("B714").Value

-C714 = Range("C714").Value

-If B714 = C714 Then

-Range("D714").Value = "OK"

-Else

-Range("D714").Value = "NG"

-End If

-End Function

-

-Function test_xlGuess(ByRef num)

-Range("A715").Clear

-Range("B715").Clear

-Range("C715").Clear

-Range("D715").Clear

-Range("A715").Value = "xlGuess"

-Range("B715").Value = 0

-Range("C715").Value = num

-B715 = Range("B715").Value

-C715 = Range("C715").Value

-If B715 = C715 Then

-Range("D715").Value = "OK"

-Else

-Range("D715").Value = "NG"

-End If

-End Function

-

-Function test_xlNo(ByRef num)

-Range("A716").Clear

-Range("B716").Clear

-Range("C716").Clear

-Range("D716").Clear

-Range("A716").Value = "xlNo"

-Range("B716").Value = 2

-Range("C716").Value = num

-B716 = Range("B716").Value

-C716 = Range("C716").Value

-If B716 = C716 Then

-Range("D716").Value = "OK"

-Else

-Range("D716").Value = "NG"

-End If

-End Function

-

-Function test_xlYes(ByRef num)

-Range("A717").Clear

-Range("B717").Clear

-Range("C717").Clear

-Range("D717").Clear

-Range("A717").Value = "xlYes"

-Range("B717").Value = 1

-Range("C717").Value = num

-B717 = Range("B717").Value

-C717 = Range("C717").Value

-If B717 = C717 Then

-Range("D717").Value = "OK"

-Else

-Range("D717").Value = "NG"

-End If

-End Function

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'ProjectFoo'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Simple
->>>>>>
-Attribute VB_Name = "Simple"

-Function SGetThree()

-SGetThree = 3

-End Function

-

-Function SLoop()

-Dim i As Integer

-Dim j As Integer

-j = 0

-For i = 0 To 10

-    j = j + 1

-Next i

-SLoop = j

-End Function

-

-Function SNoRetVal()

-End Function

-<<<<<<
-======================
-MoreComplex
->>>>>>
-Attribute VB_Name = "MoreComplex"

-Function MGetThree()

-MGetThree = 3

-If MGetThree = 2 Then

- MsgBox ("Hello World")

-End If

-End Function

-

-Function MLoop()

-Dim i As Integer

-Dim j As Integer

-j = 0

-For i = 0 To 10

-    j = j + 1

-Next i

-If j = 17 Then

-    MLoop = Application.Sum(Range("A1:A10"))

-End If

-MLoop = j

-End Function

-

-Function MNoRetVal()

-Dim i As Integer

-End Function

-<<<<<<
-======================
-Real
->>>>>>
-Attribute VB_Name = "Real"

-Function CtoF(Centigrade)

-  CtoF = Centigrade * 9 / 5 + 32

-End Function

-

-Function WsF(Angle)

-  WsF = WorksheetFunction.Sinh(Angle)

-End Function

-<<<<<<
-======================
-FuncVal
->>>>>>
-Attribute VB_Name = "FuncVal"

-Function MyString()

-MyString = "teststring"

-End Function

-

-Function MyDouble()

-MyDouble = 1 / 8

-End Function

-

-Function MyBoolean()

-MyBoolean = False

-End Function

-

-Function MyInt()

-MyInt = 7

-End Function

-

-Function TakeOneArg(arg1)

-TakeOneArg = arg1

-End Function

-

-Function TakeTwoArgs(arg1, arg2)

-TakeTwoArgs = arg2

-End Function

-

-Function TakeThreeArgs(arg1, arg2, arg3)

-TakeThreeArgs = arg3

-End Function

-

-Function ContainsComment()

-Rem This is a comment

-ContainsComment = 3

-End Function

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    If Range("CloseFlag") <> "Y" Then

-        Worksheets("Workbook Examples").Activate

-        Range("CloseFlag").Activate

-        MsgBox "CloseFlag Cell must be 'Y' to close workbook"

-        Cancel = True

-    End If

-End Sub

-

-Private Sub Workbook_Open()

-    Worksheets("Change History").Activate

-    Range("VersionStart").Select

-    Selection.End(xlDown).Select

-    Selection.Copy (Worksheets("Overview").Range("VersionNumber"))

-    Worksheets("Workbook Examples").Activate

-    Range("CloseFlag") = "N"

-    Worksheets("Overview").Activate

-    Range("A1").Activate

-

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CommandButton1, 1, 0, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton2, 2, 1, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton3, 4, 2, MSForms, CommandButton"

-Private Sub CommandButton1_Click()

-    Call ListAllWorksheets

-End Sub

-

-Private Sub CommandButton2_Click()

-    Call ClearWorksheetNames

-End Sub

-

-Private Sub CommandButton3_Click()

-    Call AddNewWorksheet

-End Sub

-

-Private Sub Worksheet_Activate()

-    MsgBox "This pop-up message is displayed whenever this worksheet is activated."

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-

-End Sub

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CommandButton1, 1, 0, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton2, 2, 1, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton3, 3, 2, MSForms, CommandButton"

-Private Sub CommandButton1_Click()

-    Call SelectToFromCells

-End Sub

-

-Private Sub CommandButton2_Click()

-    Call RotateMatrix

-End Sub

-

-Private Sub CommandButton3_Click()

-    Call ElementOperations

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Not (Intersect(Target, Range("MyCell")) Is Nothing) Then

-        Select Case LCase(Target.Value)

-            Case "a", "e", "i", "o", "u"

-                Range("MsgCell").Value = "vowel"

-                

-            Case "b" To "d", "f" To "h", "j" To "n", "p" To "t", "v" To "z"

-                Range("MsgCell").Value = "consonant"

-            

-            Case 0 To 9

-                Range("MsgCell").Value = "number"

-                

-            Case Else

-                Range("MsgCell").Value = "unknown"

-        End Select

-    End If

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-

-End Sub

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-WorksheetsVBACode
->>>>>>
-Attribute VB_Name = "WorksheetsVBACode"

-Sub AddNewWorksheet()

-    Dim wksh As Worksheet

-    

-    Set wksh = Worksheets.Add

-    wksh.Name = "MyNewSheet"

-End Sub

-Sub ListAllWorksheets()

-    Dim wksh As Worksheet

-    Dim i As Integer

-    

-    With Range("WkShNames")

-        i = 1

-        For Each wksh In ActiveWorkbook.Worksheets

-            .Cells(i).Value = wksh.Name

-            i = i + 1

-        Next

-    End With

-

-End Sub

-

-Sub ClearWorksheetNames()

-    Dim YesNoResponse As Integer

-    

-    Range("WkShNameArea").Select

-    

-    YesNoResponse = MsgBox("Clear Worksheet Name Area?", vbYesNo)

-    

-    If YesNoResponse = vbYes Then

-        Range("WkShNameArea").ClearContents

-

-    End If

-    

-    Range("a1").Select

-End Sub

-<<<<<<
-======================
-CellVBACode
->>>>>>
-Attribute VB_Name = "CellVBACode"

-Sub SelectToFromCells()

-    Range("FromCell", "ToCell").Select

-End Sub

-

-Sub RotateMatrix()

-    Dim i As Integer, j As Integer

-    Dim Temp As Variant

-    

-    With Range("MyMatrix")

-        Temp = .Cells(2, 1)

-        .Cells(2, 1) = .Cells(2, 2)

-        .Cells(2, 2) = .Cells(1, 2)

-        .Cells(1, 2) = .Cells(1, 1)

-        .Cells(1, 1) = Temp

-    End With

-End Sub

-

-

-Sub ElementOperations()

-    Dim i As Integer

-    Dim NumberOfElements As Integer

-    Dim ElementProduct As Double

-    Dim ElementSum As Double

-    

-    With Range("MyVector")

-        NumberOfElements = .Rows.Count

-        ElementProduct = 1

-        ElementSum = 0

-        For i = 1 To NumberOfElements

-            ElementProduct = ElementProduct * .Cells(i)

-            ElementSum = ElementSum + .Cells(i)

-        Next i

-    End With

-

-    Range("ElementProduct").Value = ElementProduct

-    Range("ElementSum").Value = ElementSum

-End Sub

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CommandButton1, 1, 0, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton2, 2, 1, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton3, 3, 2, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton4, 5, 4, MSForms, CommandButton"

-Attribute VB_Control = "CommandButton5, 6, 5, MSForms, CommandButton"

-Private Sub CommandButton1_Click()

-    Call getApplProperties

-End Sub

-

-Private Sub CommandButton2_Click()

-    Call generateDataToSort

-End Sub

-

-Private Sub CommandButton3_Click()

-    Call SortWithScreenUpdating

-End Sub

-

-Private Sub CommandButton4_Click()

-    Call SortWithNoScreenUpdating

-End Sub

-

-Private Sub CommandButton5_Click()

-    Call generateDataToSort

-End Sub

-

-Private Sub Worksheet_Activate()

-    Range("ApplProperties").ClearContents

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-

-End Sub

-<<<<<<
-======================
-ApplicationCode
->>>>>>
-Attribute VB_Name = "ApplicationCode"

-'''

-''' Contains various VBA coding examples on accessing the Application Object

-'''

-Option Explicit

-

-

-Sub getApplProperties()

-    Range("ApplParent") = Application.Parent

-    Range("ApplPath") = Application.Path

-    Range("ApplActiveWorkbook") = Application.ActiveWorkbook.Name

-    Range("ApplActiveSheet") = Application.ActiveSheet.Name

-    Range("ApplActiveCell") = Application.ActiveCell.Address

-    

-End Sub

-

-

-Sub generateDataToSort()

-    Dim i As Integer

-    

-    With Range("SortArray")

-        For i = 1 To .Rows.Count

-            .Cells(i) = Int((100 * Rnd) + 1)    ' Generate random value between 1 and 100.

-        Next i

-    End With

-

-End Sub

-

-Sub SortWithScreenUpdating()

-    Application.ScreenUpdating = True

-    Call BubbleSort(Range("SortArray"))

-    Range("SortArray").Select

-    MsgBox "Sorting Completed"

-End Sub

-Sub SortWithNoScreenUpdating()

-    Application.ScreenUpdating = False

-    Call BubbleSort(Range("SortArray"))

-    Range("SortArray").Select

-    Application.ScreenUpdating = True

-    MsgBox "Sorting Completed"

-End Sub

-

-Sub BubbleSort(rngToSort As Range)

-    Dim i, j As Integer

-    Dim Temp As Variant

-

-    With rngToSort

-        For j = .Rows.Count To 1 Step -1

-            For i = 1 To j

-                .Cells(i).Interior.ColorIndex = 6

-                .Cells(j).Interior.ColorIndex = 8

-                Application.Wait (Now + TimeValue("0:00:01"))

-                If .Cells(i) > .Cells(j) Then

-                    Temp = .Cells(i)

-                    .Cells(i) = .Cells(j)

-                    .Cells(j) = Temp

-                End If

-                .Cells(i).Interior.ColorIndex = xlColorIndexNone

-                .Cells(j).Interior.ColorIndex = xlColorIndexNone

-            Next i

-        Next j

-    

-    End With

-

-End Sub

-

-

-

-

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Sub Macro1()

-Attribute Macro1.VB_Description = "Macro recorded 5/5/2004 by Jim Thompson"

-Attribute Macro1.VB_ProcData.VB_Invoke_Func = " \n14"

-'

-' Macro1 Macro

-' Macro recorded 5/5/2004 by Jim Thompson

-'

-

-'

-    Selection.End(xlDown).Select

-End Sub

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'Controls'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Attribute VB_Control = "CommandButton1, 1, 0, MSForms, CommandButton"

-

-Private Sub CommandButton1_Click()

-ActiveSheet.Next.Select

-Rem Range("A1").Select - broken for some stupid reason

-Rem Selection.Copy

-Rem If Selection.EntireRow.Hidden = False Then

-Rem     MsgBox ("Selection Error")

-Rem End If

-ActiveSheet.Previous.Select

-End Sub

-<<<<<<
-======================
-Invocations
->>>>>>
-Attribute VB_Name = "Invocations"

-Rem       No defined return value

-

-Function INoReturnNoRet()

-End Function

-Function IGetThreeNoRet()

-IGetThreeNoRet = 3

-End Function

-Function IGetFooNoRet()

-IGetFooNoRet = "foo"

-End Function

-Function IGetPINoRet()

-IGetPINoRet = 3.1415926535898

-End Function

-

-Rem       Various return types

-

-Function IGetInteger() As Integer

-IGetInteger = 42

-End Function

-Function IGetString() As String

-IGetString = "baa"

-End Function

-Function IGetDouble() As Double

-IGetDouble = 3.1415926535898

-End Function

-Function IGetSingle() As Single

-IGetSingle = 23

-End Function

-Function IGetBoolean() As Boolean

-IGetBoolean = True

-End Function

-

-Rem       Misc parameter types

-

-Function TakesNothing()

-TakesNothing = 1

-End Function

-Function TakesInteger(arg As Integer) As Integer

-TakesInteger = 21

-End Function

-Function TakesString(arg As String) As Integer

-TakesString = 17

-End Function

-Function TakesDouble(arg As Double) As Integer

-TakesDouble = 38

-End Function

-Function TakesDate(arg As Date) As Integer

-TakesDate = 23

-End Function

-Function TakesRange(arg As Range) As Integer

-TakesRange = 11

-End Function

-

-

-Rem Optional arguments

-Function OptionalArgument(Length As Integer, Optional Width As Variant) As Integer

-If IsMissing(Width) Then

-    OptionalArgument = Length * Length

-Else

-    OptionalArgument = Length * Width

-End If

-End Function

-

-Function OptionalNonVariant(Optional IsZero As Integer) As Integer

-If IsMissing(IsZero) Then

-Rem This never occurs

-    OptionalNonVariant = 23

-Else

-    OptionalNonVariant = 17

-End If

-End Function

-

-<<<<<<
-======================
-ObjectModel
->>>>>>
-Attribute VB_Name = "ObjectModel"

-Function ObjectWorksheetFn() As Double

-ObjectWorksheetFn = WorksheetFunction.Sinh(2.3)

-End Function

-Function ObjectIsVolatile() As Double

-Application.Volatile

-ObjectIsVolatile = 3

-End Function

-Function ObjectRange(a As Range) As Integer

-ObjectRange = a.Column + a.Row + a.Height + a.Width

-End Function

-<<<<<<
-======================
-Syntax
->>>>>>
-Attribute VB_Name = "Syntax"

-Rem       Basic Statements

-Function StmtFor() As Integer

-Dim i As Integer

-Dim j As Integer

-For i = 0 To 10

-    j = j + i

-Next i

-StmtFor = j

-End Function

-Function StmtWhile() As Integer

-Dim i As Integer

-While i < 11

-    i = i + 1

-Wend

-StmtWhile = i

-End Function

-Function StmtWith() As Integer

-With Selection

-    .Orientation = 0

-End With

-StmtWith = 15

-End Function

-

-Rem       Unary Operators

-Function UnaryNot() As Boolean

-UnaryNot = Not False

-End Function

-

-Rem       Comparison Operators

-Function BinaryIsGreater() As Boolean

-BinaryIsGreater = 3 > 2

-End Function

-Function BinaryIsGreaterEqual() As Boolean

-BinaryIsGreaterEqual = 2 >= 2

-End Function

-Function BinaryIsLess() As Boolean

-BinaryIsLess = 2 < 2

-End Function

-Function BinaryIsLessEqual() As Boolean

-BinaryIsLessEqual = 4 <= 4

-End Function

-Function BinaryIsEqual() As Boolean

-BinaryIsEqual = 4 = 4

-End Function

-

-Rem       Arithmetic Operators

-Function BinaryAdd() As Integer

-BinaryAdd = 2 + 3

-End Function

-Function BinarySub() As Integer

-BinarySub = 5 - 7

-End Function

-Function BinaryMult() As Integer

-BinaryMult = 2 * 7

-End Function

-Function BinaryDivide() As Integer

-BinaryDivide = 17 / 6

-End Function

-<<<<<<
-======================
-RecordedMacros
->>>>>>
-Attribute VB_Name = "RecordedMacros"

-Sub Boldify()

-Attribute Boldify.VB_Description = "Macro recorded 20/04/2004 by Michael"

-Attribute Boldify.VB_ProcData.VB_Invoke_Func = "t\n14"

-'

-' Boldify Macro

-' Macro recorded 20/04/2004 by Michael

-'

-' Keyboard Shortcut: Ctrl+t

-'

-    Selection.Font.Bold = True

-End Sub

-Sub Italicize()

-Attribute Italicize.VB_Description = "Second Macro description"

-Attribute Italicize.VB_ProcData.VB_Invoke_Func = "J\n14"

-'

-' Italicize Macro

-' Second Macro description

-'

-' Keyboard Shortcut: Ctrl+Shift+J

-'

-    Selection.Font.Italic = True

-End Sub

-Sub Complex()

-Attribute Complex.VB_Description = "Daft thing ..."

-Attribute Complex.VB_ProcData.VB_Invoke_Func = "C\n14"

-'

-' Complex Macro

-' Daft thing ...

-'

-' Keyboard Shortcut: Ctrl+Shift+C

-'

-    ActiveCell.FormulaR1C1 = "2"

-    Range("F8").Select

-    ActiveCell.FormulaR1C1 = "3"

-    Range("F9").Select

-    Selection.Font.Bold = True

-    ActiveCell.FormulaR1C1 = "5"

-    Range("F10").Select

-    ActiveCell.FormulaR1C1 = "=R[-3]C+R[-1]C"

-    Range("F11").Select

-    With Selection.Font

-        .Name = "Arial Black"

-        .Size = 10

-        .Strikethrough = False

-        .Superscript = False

-        .Subscript = False

-        .OutlineFont = False

-        .Shadow = False

-        .Underline = xlUnderlineStyleNone

-        .ColorIndex = xlAutomatic

-    End With

-    ActiveCell.FormulaR1C1 = "Arial Black"

-    Range("F12").Select

-    ActiveCell.FormulaR1C1 = "Centered"

-    Range("F13").Select

-    ActiveCell.FormulaR1C1 = "Left"

-    Range("F14").Select

-    ActiveCell.FormulaR1C1 = "Right"

-    Range("F12").Select

-    With Selection

-        .HorizontalAlignment = xlCenter

-        .VerticalAlignment = xlBottom

-        .WrapText = False

-        .Orientation = 0

-        .AddIndent = False

-        .IndentLevel = 0

-        .ShrinkToFit = False

-        .ReadingOrder = xlContext

-        .MergeCells = False

-    End With

-    Range("F13").Select

-    With Selection

-        .HorizontalAlignment = xlLeft

-        .VerticalAlignment = xlBottom

-        .WrapText = False

-        .Orientation = 0

-        .AddIndent = False

-        .IndentLevel = 0

-        .ShrinkToFit = False

-        .ReadingOrder = xlContext

-        .MergeCells = False

-    End With

-    Range("F14").Select

-    With Selection

-        .HorizontalAlignment = xlRight

-        .VerticalAlignment = xlBottom

-        .WrapText = False

-        .Orientation = 0

-        .AddIndent = False

-        .IndentLevel = 0

-        .ShrinkToFit = False

-        .ReadingOrder = xlContext

-        .MergeCells = False

-    End With

-    Range("F15:G15").Select

-    ActiveCell.FormulaR1C1 = "Joiined"

-    Range("F15:G15").Select

-    Range("G15").Activate

-    With Selection

-        .HorizontalAlignment = xlCenter

-        .VerticalAlignment = xlBottom

-        .WrapText = False

-        .Orientation = 0

-        .AddIndent = False

-        .IndentLevel = 0

-        .ShrinkToFit = False

-        .ReadingOrder = xlContext

-        .MergeCells = False

-    End With

-    Selection.Merge

-End Sub

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Private Sub Workbook_Open()

-    Dim xlWkBook As Workbook

-    If (FileSystem.Dir(Application.StartupPath & "\" & TEMPLATE_NAME & ".lnk") = (TEMPLATE_NAME & ".lnk")) Then

-        Kill (Application.StartupPath & "\" & TEMPLATE_NAME & ".lnk")

-    End If

-    Call AddOleInsertVisioDrawingButton

-    ThisWorkbook.Saved = True

-    If Windows.Count = 0 Then

-    If Workbooks(1).IsInplace Then

-            Workbooks.Add

-        End If

-    End If

-

-    

- End Sub

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-<<<<<<
-======================
-InsertButtonMacros
->>>>>>
-Attribute VB_Name = "InsertButtonMacros"

-Const BUTTON_BEFORE$ = "&Drawing" 'Button before the insertion point, check localized versions of Excel

-Const STD_TOOLBAR$ = "Standard" 'Excel standard toobar name, check localized versions of Excel

-Const BUTTON_CAPTION$ = "Insert Visio Drawing"    'The caption to use for the button

-'Do not localize below this point

-Const MACRO_NAME$ = "InsertVisioDrawing"    'The name of the function in the VisioMacros module

-Const MODULE_NAME$ = "VisioMacros"    'The name of the module containing the insert drawing macro

-Global Const TEMPLATE_NAME$ = "VisBut97.XLS" '(Do not localise) the name of this template

-Global Const OLD_TEMPLATE_NAME$ = "Insert Visio Button.XLS" 'the name of the Visio 5.0 Excel Macro

-Sub AddOleInsertVisioDrawingButton()

-Dim nButtonPos

-Dim nButtons

-Dim i

-Dim lpszButtonName$

-Dim strCantAdd_

-Dim strError_

-Dim msoButton As CommandBarButton

-Dim msoVisButton As CommandBarButton

-Dim bPresent As Boolean

-

-

-    On Error GoTo -1: On Error GoTo errAddButton

-    

-

-    If Not CommandBars(STD_TOOLBAR).Visible Then

-        CommandBars(STD_TOOLBAR).Visible = True

-    End If

-

-    nButtonPos = 0

-    nButtons = Application.CommandBars(STD_TOOLBAR).Controls.Count - 1

-

-    If nButtons >= 0 Then

-        ' First we look to see if a Visio button already exists.

-

-        For i = 1 To nButtons

-            lpszButtonName$ = Application.CommandBars(STD_TOOLBAR).Controls(i).Caption

-            If lpszButtonName$ = BUTTON_CAPTION Then

-                bPresent = False

-                For x = 1 To (Len(Application.CommandBars(STD_TOOLBAR).Controls(i).OnAction) - Len(OLD_TEMPLATE_NAME))

-                If Mid(Application.CommandBars(STD_TOOLBAR).Controls(i).OnAction, x, Len(OLD_TEMPLATE_NAME)) = OLD_TEMPLATE_NAME Then

-                    bPresent = True

-                    Application.CommandBars(STD_TOOLBAR).Controls(i).Delete

-

-                End If

-                Next x

-                If Not bPresent Then GoTo Done

-            End If

-        Next i

-

-        If ((FileSystem.Dir(Application.Path & "\XLStart\" & OLD_TEMPLATE_NAME & ".LNK") = (OLD_TEMPLATE_NAME & ".LNK")) Or (FileSystem.Dir(Application.Path & "\XLStart\" & OLD_TEMPLATE_NAME & ".LNK") = (OLD_TEMPLATE_NAME & ".lnk"))) Then

-            Kill (Application.Path & "\XLStart\" & OLD_TEMPLATE_NAME & ".LNK")

-        End If

-        'if we didn't find a Visio button, find a location to put one

-        For i = 1 To nButtons

-            lpszButtonName$ = Application.CommandBars(STD_TOOLBAR).Controls(i).Caption

-    

-            If lpszButtonName$ = BUTTON_BEFORE Then

-                nButtonPos = i

-                Exit For

-            End If

-        Next i

-

-    End If

-    'If the Drawing toolbar button does not exist, tack the Visio button onto the end

-    If nButtonPos = 0 Then nButtonPos = nButtons + 1

-    

-    If nButtonPos > 0 Then

-        If 0 = fExists Then

-            Set msoButton = Application.CommandBars(STD_TOOLBAR).Controls.Add(msoControlButton, 1, 0, nButtonPos)

-            msoButton.OnAction = ThisWorkbook.Path & "\" & TEMPLATE_NAME & "!" & MACRO_NAME

-            msoButton.Caption = BUTTON_CAPTION

-            msoButton.TooltipText = BUTTON_CAPTION

-            'Get the stuff we need out of the Visio template

-            ThisWorkbook.Sheets(1).Shapes(1).CopyPicture

-            Rem ---- Make sure the STD_TOOLBAR Toolbar is showing, if it isn't

-            Rem ---- then show it.

-            msoButton.PasteFace

-        End If

-

-    Else

-        MsgBox strCantAdd_, strError_, 48

-    End If

-   

-Done:

-  

-Exit Sub

-errAddButton:

- 

-End Sub

-<<<<<<
-======================
-VisioMacros
->>>>>>
-Attribute VB_Name = "VisioMacros"

-Public Sub InsertVisioDrawing()

-    

-    Dim xlActiveSheet As Object

-    

-    'ThisWorkbook.Windows(1).Visible = False

-    

-    Set xlActiveSheet = Application.ActiveSheet

-    

-    Application.ScreenUpdating = False

-    If Windows.Count = 0 Or xlActiveSheet Is Nothing Then

-        Workbooks.Add

-        Set xlActiveSheet = Application.ActiveSheet

-    End If

-       

-    xlActiveSheet.Shapes.AddOLEObject ("Visio.Drawing")

-    xlActiveSheet.OLEObjects(ActiveSheet.OLEObjects.Count).Activate

-    

-    Application.ScreenUpdating = True

-

-    If Workbooks.Count = 1 Then

-        Application.Tasks(Application.Name).Close

-    End If

-    

-End Sub

-<<<<<<
-Project Name : 'Sample Flowchart Data.XLS'
-Quirk - duff tag length======================
-General
->>>>>>
-Attribute VB_Name = "General"

-

-

-

-

-

-Const strToolbar = "Standard"

-Const szDataShtName = "Flowchart Wizard Data"

-Const szXLCommandLine = "/excel"

-Const szFromExcel = "fromexcel"

-Const szFromExcelOnClose = "excelonclose"

-Const szRunWizrdErr = "Unable to locate Flowchart Wizard."

-Const strButtonName = "Visio Import Flowchart Data Wizard"    ' The button name is also used as the ToolTip.

-Const szSaveNow = "You must save your Excel Workbook before running the Visio Import Flowchart Data Wizard.  Would you like to save it now?"

-Const szNotSaved = "Please save your Excel Workbook before running the Visio Import Flowchart Data Wizard."

-Const szExitWithoutRun = "Would you like to export your Excel workbook to Visio now?"

-Const iButtonID = 231                       ' ID of blank button

-

-Dim bRunWizardOnClose As Integer    ' True if run on close, False otherwise

-Dim lRetVal As Long

-Dim iSaveNow As Integer

-Dim iRunWizardNow As Integer

-Dim iHasWizardStarted As Integer

-Dim szFName As String

-Dim objFltToolbar As Toolbar

-

-Sub Auto_Open()

-Attribute Auto_Open.VB_ProcData.VB_Invoke_Func = " \n14"

-

-    'Add Export Wizard Button

-    AddExportWizardButton

-    

-    Worksheets("Shapes Worksheet").Activate

-    

-    ' AddFloatToolbar

-    

-    ' Set the wizard tracker to 0

-    iHasWizardStarted = 0

-    

-    ' initialize to False

-    bRunWizardOnClose = False

-    

-    

-End Sub

-

-Sub Auto_Close()

-Attribute Auto_Close.VB_ProcData.VB_Invoke_Func = " \n14"

-    

-    'Remove Export Wizard Button

-    RemoveExportWizardButton

-        

-    ' If the wizard hasn't yet been started, ask the user if wizard should be started.

-    If iHasWizardStarted = 0 Then

-        If MsgBox(szExitWithoutRun, vbYesNo + vbQuestion, "Visio Import Flowchart Data Wizard") = 6 Then

-            If Not (Application.ThisWorkbook.Saved) Then

-                If MsgBox(szSaveNow, vbYesNo + vbQuestion, "Visio Import Flowchart Data Wizard") = 6 Then

-                    ThisWorkbook.Save

-                    Call RunExportChartWizard

-                    bRunWizardOnClose = True

-                End If

-            Else

-                Call RunExportChartWizard

-                bRunWizardOnClose = True

-            End If

-        End If

-    End If

-        

-Exit Sub

-

-    

-

-End Sub

-

-

-Private Sub AddExportWizardButton()

-' Add the "InsertVisioDrawing" button to Excel's standard toolbar

-' if the button does not already exist.

-

-    Set btns = Toolbars(strToolbar).ToolbarButtons

-    Set btn = ButtonsIndex(btns, strButtonName)

-    

-    ' Check if toolbar button already exists

-    If Not (btn Is Nothing) Then

-        btn.Delete

-    End If

-    

-    ' Add a blank button to the Standard toolbar,

-    ' after the "Drawing" toolbar button.

-    iLoc = ButtonsLoc(btns, "Drawing")

-    If iLoc = 0 Then

-        Set btn = btns.Add(iButtonID)

-    Else

-        Set btn = btns.Add(iButtonID, iLoc + 1)

-    End If

-    btn.Name = strButtonName

-    

-    ' Copy the button bitmap to the clipboard.

-    ' Paste it onto the button.

-    Set objWorkbook = Application.ThisWorkbook

-    objWorkbook.Sheets(szDataShtName).DrawingObjects(1).CopyPicture

-    btn.PasteFace

-                

-    ' Set the macro the toolbar button will run.

-    btn.OnAction = "RunExportChartWizard"

-End Sub

-

-Private Sub RemoveExportWizardButton()

-

-    Set btns = Toolbars(strToolbar).ToolbarButtons

-    Set btn = ButtonsIndex(btns, strButtonName)

-    

-    If Not (btn Is Nothing) Then

-        btn.Delete

-    End If

-        

-End Sub

-

-

-Sub RunExportChartWizard()

-Attribute RunExportChartWizard.VB_ProcData.VB_Invoke_Func = " \n14"

-    

-    Dim szExportWizExe As String

-    Dim szTempName As String

-    Dim szFileName As String

-    Dim szCommandLine As String

-    

-    On Error GoTo ErrRunWizard

-    

-    ' Keep track of the fact that the wizard started

-    iHasWizardStarted = 1

-    

-    If Not (Application.ThisWorkbook.Saved) Then

-        ' Alert user to save work before continuing

-        MsgBox szNotSaved, 48

-        ' Bring up the SaveAs Dialog Box to do the saving

-        Do

-           szName = Application.GetSaveAsFilename

-        Loop Until szName <> False

-        ThisWorkbook.SaveAs Filename:=szName

-    End If

-            

-

-    szOrgWizExe = Application.ThisWorkbook.Worksheets(szDataShtName).Cells(1).Formula

-    

-    szFileName = Application.ThisWorkbook.FullName

-    If bRunWizardOnClose = True Then

-        szCommandLine = szXLCommandLine & "=" & Chr$(34) & szFromExcelOnClose & szFileName & Chr$(34)

-    Else

-        szCommandLine = szXLCommandLine & "=" & Chr$(34) & szFromExcel & szFileName & Chr$(34)

-    End If

-    

-    lRetVal = Shell(szOrgWizExe & " " & szCommandLine, 5)

-        

-Exit Sub

-        

-ErrRunWizard:

-    MsgBox szRunWizrdErr, 48

-End Sub

-

-

-Private Function ButtonsIndex(ByVal Buttons As Object, ByVal bname As String) As Object

-' Index any collection by name.

-' Returns the object with a given name.

-' Returns Nothing if not found.

-

-    For Each btn In Buttons

-        If btn.Name = bname Then

-            Set ButtonsIndex = btn

-            Exit For

-        End If

-    Next

-    

-End Function

-

-

-Private Function ButtonsLoc(ByVal Buttons As Object, ByVal bname As String) As Integer

-' Returns the location of a button with a given name

-' or zero if not found.

-

-    n = Buttons.Count

-    For i = 1 To n

-        If Buttons(i).Name = bname Then

-            ButtonsLoc = i

-            Exit For

-        End If

-    Next

-End Function

-

-

-Private Function AddFloatToolbar()

-' Creates a floating toolbar for the add shapes and

-' add connectors buttons

-

-    Dim cToolbars As Integer, cBuiltin As Integer

-    Dim bToolbarOpen As Boolean

-    

-    Dim iLocShpBtn As Integer, iLocConBtn As Integer, iLocExpBtn As Integer

-    Dim iLocHlpBtn As Integer, iLocVisBtn As Integer

-    

-    cToolbars = Toolbars.Count

-    cBuiltin = 0

-    

-    ' Set a flag if the toolbar is already open.

-    For i = 1 To cToolbars

-        If Toolbars.Item(i).Name = strButtonName Then

-            Toolbars.Item(i).Left = 200

-            Toolbars.Item(i).Top = 100

-            Toolbars.Item(i).Visible = True

-            bToolbarOpen = True

-        End If

-    Next i

-    

-

-

-End Function

-

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag lengthProject Name : 'VBAProject'
-Quirk - duff tag length======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    

-    Application.EnableEvents = True

-    Set MyAppEvents.app = Application

-    

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    

-    set_work_mode

-    

-    MyAppEvents.CheckWorkBooksArround ThisWorkbook

-    

-    CheckUser

-    

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-    Application.ScreenUpdating = True

-

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-    ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-    Application.Calculate

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    

-    Application.Caption = Empty

-    Application.CommandBars("Worksheet Menu Bar").Reset

-    

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-    

-    With ThisWorkbook

-        xlRestoreView

-        .Application.DisplayAlerts = False

-        .Save

-    End With

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-    Dim MaxX, MaxY As Integer

-    With ThisWorkbook.Worksheets(RM_QTR_SHEET)

-        .Select

-        MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-        MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-    End With

-

-    With ThisWorkbook.Application

-        .ScreenUpdating = False

-        .WindowState = xlNormal

-        .Height = MaxY

-        .Width = MaxX

-    End With

-End Sub

-

-

-

-

-

-<<<<<<
-======================
-REP_QTR
->>>>>>
-Attribute VB_Name = "REP_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CQTR_QT As Integer = 0

-Const CQTR_ID As Integer = 1

-Const CQTR_PLN As Integer = 2

-Const CQTR_FCT As Integer = 3

-Const CQTR_BDG As Integer = 4

-Const CQTR_CNT As Integer = 5

-Const CQTR_BEDS As Integer = 6

-Const CQTR_HIR As Integer = 7

-Const CQTR_TER As Integer = 8

-Const CQTR_CRD As Integer = 9

-Const CQTR_CLXN_BDG As Integer = 10

-Const CQTR_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub update_history()

-    Dim objQTR() As tQTR

-    Dim i As Long

-    Dim r As Range

-    Dim cRep As tREPID

-

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    Range("D4") = cRep.LastName

-    Range("D5") = cRep.FirstName

-

-    Range("H4") = GetRegionName(cRep.Region)

-    Range("H5") = GetCityName(cRep.Region, cRep.City)

-

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetAll_QTR_Records_by_REP(objQTR, "%", cRep.rep_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CQTR_QT) = objQTR(i).entry_date

-        Next i

-    End If

-    Dim qcd() As tQTR_COMMON

-    i = Get_QTR_CommonList_by_REP(qcd, "%", cRep.rep_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(qcd)

-            r.Offset(i - 1, CQTR_QT) = qcd(i).qtr.entry_date

-            r.Offset(i - 1, CQTR_ID) = qcd(i).qtr.id

-            r.Offset(i - 1, CQTR_PLN) = qcd(i).qtr.sale_PLAN

-            r.Offset(i - 1, CQTR_FCT) = qcd(i).c_sale_ALL

-            r.Offset(i - 1, CQTR_BDG) = qcd(i).c_bdgt_LPU

-            r.Offset(i - 1, CQTR_CNT) = qcd(i).i_lcd

-            r.Offset(i - 1, CQTR_BEDS) = qcd(i).c_beds

-            r.Offset(i - 1, CQTR_HIR) = qcd(i).c_pat_HIR

-            r.Offset(i - 1, CQTR_TER) = qcd(i).c_pat_TER

-            r.Offset(i - 1, CQTR_CRD) = qcd(i).c_pat_CRD

-            If qcd(i).c_bdgt_LPU <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_BDG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_LPU

-            End If

-            If qcd(i).c_bdgt_NMG <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_NMG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CQTR_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRepQtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CQTR_ID + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    i = currRange.Column - Range(CINP_AREA).Column

-

-    QTR_ID = r

-

-    If QTR_ID = 0 Then

-        Worksheets(VAR_SHEET).Range("USER_ACTION") = 1

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        If i > CQTR_FCT Then

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-            Range("LAST_FOCUS") = currRange.address

-        Else

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 3

-            Range("LAST_FOCUS") = currRange.address

-        End If

-    End If

-    Cancel = True

-    btHomeDo_IT

-End Sub

-

-<<<<<<
-======================
-mRep_QTR
->>>>>>
-Attribute VB_Name = "mRep_QTR"

-Option Explicit

-

-Sub NoFunc()

-    MsgBox "Функция не доступна", vbOKOnly, PROGRAM_NAME

-End Sub

-

-Sub DO_Price_qtr(ent_date As String)

-    Dim qtr As tQTR

-    Dim res As Integer

-    Dim cRep As tREPID

-

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    qtr = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-

-    If qtr.id = 0 Then

-        qtr.entry_date = ent_date

-

-        With Worksheets(VAR_SHEET)

-            qtr.ClxnH20mg = .Range("ClxnH20mg")

-            qtr.ClxnH40mg = .Range("ClxnH40mg")

-            qtr.ClxnT40mg = .Range("ClxnT40mg")

-            qtr.ClxnC_ACS = .Range("ClxnC_ACS")

-            qtr.ClxnC_IM = .Range("ClxnC_IM")

-        End With

-    End If

-

-    Dim dlg_nq As dlg_nextQTR

-    Set dlg_nq = New dlg_nextQTR

-

-    With dlg_nq

-        .tb_qtr_name = qtr.entry_date

-        .tb_bdgt_avts = qtr.sale_PLAN

-        .tb_qtr_name = qtr.entry_date

-        .tb_ClxnH20mg = qtr.ClxnH20mg

-        .tb_ClxnH40mg = qtr.ClxnH40mg

-        .tb_ClxnT40mg = qtr.ClxnT40mg

-        .tb_ClxnC_ACS = qtr.ClxnC_ACS

-        .tb_ClxnC_IM = qtr.ClxnC_IM

-    End With

-

-    dlg_nq.Show

-End Sub

-

-Sub DO_Edit_qtr(ent_date As String)

-    If ent_date = "" Then

-        NoFunc

-    Else

-        Dim rep_id As Long

-        rep_id = Worksheets(REP_QTR_SHEET).Range("REP_ID")

-        With ThisWorkbook.Worksheets("LPU_LIST")

-            .Range("VIEW_ONLY") = True

-            .Range("ent_date") = ent_date

-            .Range("REP_ID") = rep_id

-            .Select

-        End With

-    End If

-End Sub

-

-Sub DO_Delete_qtr(ent_date As String)

-    If ent_date <> "" Then

-        MsgBox "Удалить данные за период [" & ent_date & "] нельзя ", vbOKOnly, PROGRAM_NAME

-    End If

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-

-Sub btHomeDo_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    idx = Worksheets(VAR_SHEET).Range("USER_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            NoFunc

-            ' Обновляем экран

-        Case 2

-            DO_Edit_qtr ent_date

-        Case 3

-            DO_Price_qtr ent_date

-        Case 4

-            NoFunc

-    End Select

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-Sub Delete_qtr()

-'    Dim ent_date As String

-'    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-'    DO_Delete_qtr ent_date

-End Sub

-

-Sub btREP_QTR_RET_IT()

-    Dim s As String

-    With Worksheets("REP_QTR")

-        .Range("LAST_FOCUS") = ""

-        s = .Range("ret_addr")

-        .Range("ret_addr") = ""

-    End With

-    If s <> "" Then

-        ThisWorkbook.Worksheets(s).Select

-    Else

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane[RM]"

-Public Const PROGRAM_VERSION As String = "Clexane[FM] ver 1.0"

-Public Const PROGRAM_FILENAME As String = "clexane-fm"

-Public Const PROGRAM_EXPORTNAME As String = "fm-export-"

-Public Const PROGRAM_IMPORTNAME As String = "rm-export-*"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20030329

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "P40"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-Public Const RM_QTR_SHEET As String = "RM_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-

-End Sub

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetWBName(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBName = Right(FullName, s_len - pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.name = VAR_SHEET Or sh.name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-<<<<<<
-======================
-Var
->>>>>>
-Attribute VB_Name = "Var"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-title
->>>>>>
-Attribute VB_Name = "title"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LPU_LIST
->>>>>>
-Attribute VB_Name = "LPU_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentLPU_ID() As Long

-    Dim r As Range

-

-    With Worksheets("LPU_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CLPU_ID)

-    End With

-

-    getCurrentLPU_ID = r

-End Function

-

-Public Sub LPU_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectLPU_NAME(lpu_id As Long, ent_date As String)

-    If Range("VIEW_ONLY") = True Then

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    Dim cLPU As tLPU

-    If lpu_id = 0 Then

-        cLPU.id = 0

-        cLPU.rep_id = 0

-        cLPU.address = ""

-        cLPU.name = ""

-    Else

-        cLPU = Get_LPU_Record(lpu_id)

-    End If

-    EditLPU cLPU, getEnt_date

-    Worksheet_Activate

-End Sub

-

-Sub SelectLPU_BDGT(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    vo = Range("VIEW_ONLY")

-    If lpu_id = 0 Then

-        SelectLPU_NAME lpu_id, ent_date

-    Else

-        With ThisWorkbook.Worksheets("LPU_BDGT")

-            .Range("VIEW_ONLY") = vo

-            .Range("ret_addr") = "LPU_LIST"

-            .Range("REP_ID") = r_id

-            .Range("ent_date") = ent_date

-            .Range("lpu_id") = lpu_id

-        End With

-    End If

-End Sub

-

-Sub SelectLPU_HIR(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_HIR")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Sub SelectLPU_TER(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_TER")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Sub SelectLPU_C_ACS(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_C_ACS")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateLPUList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-'    Dim r_sel As Range

-'    If Not chk_input_range(Target) Then

-'        Set r_sel = Range(CINP_AREA)

-'    Else

-'        Set r_sel = Target

-'    End If

-'

-'    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-'        Set r_sel = r_sel.Cells(1, 1)

-'    End If

-'

-'    If r_sel.count = 1 Then

-'        Range("LAST_FOCUS") = r_sel.address

-'        InpRowSelect r_sel

-'    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim lpu_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CINP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CINP_AREA).row, CLPU_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    lpu_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CINP_AREA).Column

-

-    If lpu_id = 0 Then

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    End If

-

-    If lpu_id = 0 Then

-        i = CLPU_NAME

-        Range("JUMP") = ""

-    End If

-    Select Case i

-        Case CLPU_NAME, CLPU_NAME1, CLPU_NAME2, CLPU_BEDS

-            SelectLPU_NAME lpu_id, ent_date

-            Range("JUMP") = ""

-

-        Case CLPU_NMG, CLPU_NFG, CLPU_PLAN, CLPU_FACT

-            SelectLPU_BDGT lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-

-        Case CLPU_HIR

-            SelectLPU_HIR lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_HIR"

-

-        Case CLPU_TER

-            SelectLPU_TER lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_TER"

-

-        Case CLPU_CAR

-            SelectLPU_C_ACS lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        Case Else

-            Range("JUMP") = ""

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateLPUList()

-    Dim lcd() As tLPU_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-    Dim objQTR As tQTR

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    ent_date = getEnt_date

-

-'     ent_date = "%" ' % - all records

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-    i = Get_LPU_CommonQTR(lcd, objQTR)

-

-'     стираем ФИО

-    Range("C3:C4").ClearContents

-

-    Range("C3") = cRep.LastName

-    Range("C4") = cRep.FirstName

-    Range("G3") = GetRegionName(cRep.Region)

-    Range("G4") = GetCityName(cRep.Region, cRep.City)

-    Range("G5") = objQTR.sale_PLAN

-

-

-

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(lcd)

-            r.Offset(i - 1, CLPU_NAME) = lcd(i).lpu.name

-            r.Offset(i - 1, CLPU_ID) = lcd(i).lpu.id

-            r.Offset(i - 1, CLPU_BEDS) = lcd(i).lpu.beds

-

-

-            r.Offset(i - 1, CLPU_NFG) = lcd(i).bdgt.bdgt_NFG

-            r.Offset(i - 1, CLPU_NMG) = lcd(i).bdgt.bdgt_NMG

-            r.Offset(i - 1, CLPU_PLAN) = lcd(i).bdgt.sale_PLAN

-

-            r.Offset(i - 1, CLPU_HIR) = lcd(i).pat_HIR

-            r.Offset(i - 1, CLPU_TER) = lcd(i).pat_TER

-            r.Offset(i - 1, CLPU_CAR) = lcd(i).pat_CRD

-            r.Offset(i - 1, CLPU_FACT) = lcd(i).sale_ALL

-            r.Offset(i - 1, CLPU_PAT_LPU) = lcd(i).pat_LPU

-            r.Offset(i - 1, CLPU_BDGT) = lcd(i).bdgt_LPU

-            If lcd(i).bdgt_LPU > 0 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = lcd(i).sale_ALL / lcd(i).bdgt_LPU

-            End If

-            If r.Offset(i - 1, CLPU_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{45F91340-020C-4762-8C2B-14E6F5375F21}{C544EEE0-1237-49FD-B4F4-45C95DDB8922}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-dbACS
->>>>>>
-Attribute VB_Name = "dbACS"

-Option Explicit

-

-Public Type tACS

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    patients_with_geparins As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objACS.ID <> 0 then updatre else insert

-Sub Insert_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objACS.id <> 0 Then

-        dbUpdate_ACS_Record dbConnection, objACS

-    Else

-        dbInsert_ACS_Record dbConnection, objACS

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_ACS_RecordsByLPU_ID(ByRef all_ACS_() As tACS, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_ACS_RecordsByLPU_ID = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, all_ACS_, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_ACS_Record dbConnection, objACS

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub dbInsert_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_acs", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objACS

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("patients_with_geparins") = .patients_with_geparins

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objACS.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim Update_SQL As String

-    

-    With objACS

-        Update_SQL = "UPDATE lpu_acs SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "patients_with_geparins=" & .patients_with_geparins & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_ACS_RecordsbyLPU_ID(dbConnection As Object, all_ACS() As tACS, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_ACS_SQL As String

-    Dim getAll_ACS_SQL As String

-    Dim ACS_Count As Long

-    ACS_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_ACS_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        ACS_Count = dbRecordset("ACS_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_ACS_RecordsbyLPU_ID = ACS_Count

-    

-    If ACS_Count > 0 Then

-        'we have records

-        ReDim all_ACS(1 To ACS_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_ACS_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_ACS As tACS

-                 With tmp_ACS

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .patients_with_geparins = dbRecordset("patients_with_geparins")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 all_ACS(index) = tmp_ACS

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE ID=" & objACS.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_ACS_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_HIR
->>>>>>
-Attribute VB_Name = "LPU_CLSN_HIR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-

-        Dim objHir As tHIRURGIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objHir

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .operations_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L9")

-                .patients_ambulator_clexan_20mg = Range("L10")

-                .patients_ambulator_clexan_40mg = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L19")

-                .patients_stationar_clexan_20mg = Range("L20")

-                .patients_stationar_clexan_40mg = Range("L21")

-            End With

-            Insert_Hir_Record objHir

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objHir.id = Range("rec_id")

-                    If objHir.id <> 0 Then

-                        Delete_Hir_Record objHir

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objHir As tHIRURGIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    With objHir

-        Range("rec_id") = .id

-        Range("F6") = .operations_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L9") = .patients_ambulator_clexan

-        Range("L10") = .patients_ambulator_clexan_20mg

-        Range("I21") = .patients_stationar_nmg

-        Range("L19") = .patients_stationar_clexan

-        Range("L20") = .patients_stationar_clexan_20mg

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id)

-

-        formula = "=" & qtr.ClxnH20mg & "*($L$10+$L$20)+" & qtr.ClxnH40mg & "*($L$11+$L$21)"

-        Range("F11").formula = formula

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objHir() As tHIRURGIA

-        Dim i As Integer

-        i = GetAll_Hir_RecordsByLPU_ID(objHir, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.3

-        Else

-            SetupData objHir(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-mSapes
->>>>>>
-Attribute VB_Name = "mSapes"

-Option Explicit

-

-Const SHAPE_COLOR As Integer = 1

-Const SHAPE_NAME As Integer = 2

-

-

-Sub ShapeView(r_sh_finite_state As Range)

-    Dim chk As Range

-    Dim s As String

-    Dim c, idx As Integer

-    For Each chk In r_sh_finite_state

-        idx = 0

-        If chk = "+" Then

-            c = chk.Offset(0, idx + SHAPE_COLOR)

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While c <> 0

-                ShapeFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s)), c

-                idx = idx + 2

-                c = chk.Offset(0, idx + SHAPE_COLOR)

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        Else

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While s <> ""

-                ShapeUnFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s))

-                idx = idx + 2

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        End If

-    Next chk

-End Sub

-

-Sub ShapeFill(sh As ShapeRange, ByVal color As Integer)

-    sh.Fill.Visible = msoTrue

-    sh.Fill.Solid

-    sh.Fill.ForeColor.SchemeColor = color

-    sh.Fill.Transparency = 0#

-End Sub

-

-Sub ShapeUnFill(sh As ShapeRange)

-    sh.Fill.Visible = msoFalse

-    sh.Fill.Transparency = 0#

-End Sub

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Public Const INPUT_NO = 0

-Public Const INPUT_NUMBER = 1

-Public Const INPUT_PERCENT = 2

-Public Const INPUT_STRING = 3

-Public Const INPUT_CHECK = 4

-

-Public Const INP_IDX_TYPE = 1

-Public Const INP_IDX_NEXT = 2

-Public Const INP_IDX_MIN = 3

-Public Const INP_IDX_MAX = 4

-Public Const INP_IDX_DEP = 5

-Public Const INP_IDX_ALT = 7

-

-

-Public Type tInputSet

-    vType As Integer

-    vMin As Long

-    vMax As Long

-    rChk As String

-End Type

-

-Function is_input_cell(ByVal Target As Range, inputs As Range) As tInputSet

-    Dim t As Range

-    Dim iset As tInputSet

-    Dim test As Range

-    iset.vType = INPUT_NO

-    iset.vMin = 0

-    iset.vMax = 0

-    iset.rChk = ""

-    is_input_cell = iset

-

-' Закоментировать следующую сточку для работы

-'  Exit Function

-

-    Set test = Target.Cells(1, 1)

-    For Each t In inputs

-        If Range(t).Column = test.Column And Range(t).row = test.row Then

-            iset.vType = t.Offset(0, INP_IDX_TYPE).Value

-            Select Case iset.vType

-                Case INPUT_CHECK

-                    iset.rChk = t.Offset(0, INP_IDX_ALT)

-                Case INPUT_NUMBER, INPUT_PERCENT

-                    iset.vMin = t.Offset(0, INP_IDX_MIN).Value

-                    iset.vMax = t.Offset(0, INP_IDX_MAX).Value

-            End Select

-            is_input_cell = iset

-            Exit Function

-        End If

-    Next t

-End Function

-

-Function GetFocusAddress(ByVal r As Range, f_next As Range) As String

-    Dim chk, t As Range

-    

-    For Each chk In f_next

-        For Each t In r

-            If t.address = chk Then

-                GetFocusAddress = chk

-                Exit Function

-            End If

-            If Range(chk).Column = t.Column - 1 And Range(chk).row = t.row _

-            Or Range(chk).Column = t.Column And Range(chk).row = t.row - 1 _

-            Then

-                If Range(chk) <> "" Then

-                    If Range(chk) = 0 Then

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_ALT)).address

-                    Else

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_NEXT)).address

-                    End If

-                Else

-                    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-                End If

-                Exit Function

-            End If

-        Next t

-    Next chk

-    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-End Function

-

-Sub SetDependet(r As Range, inputs As Range)

-    Dim chk As Range

-    Dim s, serr As String

-    Dim idx As Integer

-    Dim iset As tInputSet

-    Dim err_found As Boolean

-    

-    If r.count > 1 Then

-        Exit Sub

-    End If

-    

-    err_found = False

-    For Each chk In inputs

-        idx = INP_IDX_DEP

-        

-        

-        iset.vType = chk.Offset(0, INP_IDX_TYPE).Value

-        Select Case iset.vType

-            Case INPUT_NUMBER, INPUT_PERCENT

-                iset.vMin = chk.Offset(0, INP_IDX_MIN).Value

-                iset.vMax = chk.Offset(0, INP_IDX_MAX).Value

-                

-                If Range(chk) > iset.vMax Then

-                    err_found = True

-                    Range(chk) = iset.vMax

-                    serr = "Выход за дозволенный диапазон [" & iset.vMin & ".." & iset.vMax & "]! Данные скорректированы."

-                End If

-                

-                If Range(chk) = "" Then

-                    s = chk.Offset(0, idx)

-                    Do While s <> ""

-                        Range(s) = ""

-                        idx = idx + 1

-                        s = chk.Offset(0, idx)

-                    Loop

-                End If

-        End Select

-    Next chk

-    If err_found Then

-        MsgBox serr, vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Function CheckInputData(inputs As Range) As Boolean

-    Dim r As Range

-    

-    CheckInputData = True

-    For Each r In inputs

-        If Range(r) = "" Then

-            CheckInputData = False

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100.", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Sub Check_Int_Number(Target As Range, Def_Val As Long)

-    Dim err As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    err = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                err = True

-            End If

-        End If

-    Next r

-    If err Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_TER
->>>>>>
-Attribute VB_Name = "LPU_CLSN_TER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim objTer As tTERAPIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objTer

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .patients_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L20")

-            End With

-            Insert_Ter_Record objTer

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objTer.id = Range("rec_id")

-                    If objTer.id <> 0 Then

-                        Delete_Ter_Record objTer

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objTer As tTERAPIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    With objTer

-        Range("rec_id") = .id

-        Range("F6") = .patients_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L11") = .patients_ambulator_clexan

-        Range("I21") = .patients_stationar_nmg

-        Range("L20") = .patients_stationar_clexan

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id)

-        formula = "=" & qtr.ClxnT40mg & "*($L$12+$L$20)"

-        Range("F11").formula = formula

-

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objTer() As tTERAPIA

-        Dim i As Integer

-        i = GetAll_Ter_RecordsByLPU_ID(objTer, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.25

-        Else

-            SetupData objTer(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{DF5C686A-EAE3-49BA-8115-FE816E2D39EC}{48D2D902-BB57-4E5D-8E3E-DE019AAA3DCB}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-LPU_BDGT
->>>>>>
-Attribute VB_Name = "LPU_BDGT"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub SetDefFocus()

-    Range(Range("DEF_FOCUS")).Select

-End Sub

-

-Public Sub ClearData()

-    ClearSheetData

-End Sub

-

-Sub ClearSheetData()

-    If Range("F10") = 0 And Range("F13") = 0 Then

-        Range("F11:F18") = ""

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("F11:F13") = ""

-    End If

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim bdgt As tBUDGET

-        Dim test As Long

-        With bdgt

-            .lpu_id = Range("lpu_id")

-            .id = Range("rec_id")

-            .entry_date = Range("ent_date")

-            .bdgt_NMG = Round(Range("F11").Value, 0)

-            .bdgt_NFG = Round(Range("F12").Value, 0)

-            .sale_PLAN = Round(Range("F13").Value, 0)

-

-            test = .bdgt_NFG + .bdgt_NMG - .sale_PLAN

-        End With

-        If test <> 0 Then

-            If test < 0 Then

-                If vbYes = MsgBox("Ваш план превышает выделенный на гепарины бюджет. Сохранить данные?", _

-                        vbYesNo, PROGRAM_NAME) Then

-                    test = 1

-                End If

-            End If

-            If test > 0 Then

-                Insert_BDGT_Record bdgt

-            End If

-        Else

-            If bdgt.id <> 0 Then

-                If vbYes = MsgBox("Удалить данные из базы!", vbYesNo, PROGRAM_NAME) Then

-                    Delete_BDGT_Record bdgt

-                End If

-                ret_back Range("DEF_FOCUS").Worksheet

-                Exit Sub

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-    End If

-

-   ClearData

-   ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(cLPU As tLPU_COMMON)

-    Dim t_sum As Long

-    t_sum = 0

-' Setup budget data

-    Range("F11") = cLPU.bdgt.bdgt_NMG

-    Range("F12") = cLPU.bdgt.bdgt_NFG

-    Range("F13") = cLPU.bdgt.sale_PLAN

-

-    With cLPU

-        Range("F14") = .pat_ALL

-        Range("F15") = .pat_HIR

-        Range("F16") = .pat_TER

-        Range("F17") = .pat_CRD

-        Range("F18") = .sale_ALL

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    ws_activate

-End Sub

-

-

-Sub ws_activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Dim cLPU As tLPU_COMMON

-    Dim objQTR As tQTR

-    Dim objLPU As tLPU

-    Dim ent_date As String

-    Dim id As Long

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    id = Range("lpu_id").Value

-    ent_date = Range("ent_date")

-    

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-

-    objLPU = Get_LPU_Record(id)

-    Get_LPU_Common cLPU, objLPU, objQTR

-

-    If cLPU.lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = cLPU.lpu.beds

-        Range("lpu_name") = cLPU.lpu.name

-        Range("lpu_addr") = cLPU.lpu.address

-        Range("rec_id") = cLPU.bdgt.id

-

-        SetupData cLPU

-

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-'    MsgBox Target.address

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case INPUT_CHECK

-

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{F17F06E4-A8A6-41A3-9FED-D0AC38822956}{458758E5-729D-4F56-9D38-AB3E5822B018}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mSheets
->>>>>>
-Attribute VB_Name = "mSheets"

-Option Explicit

-

-Function am_load_now() As Boolean

-    am_load_now = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE")

-End Function

-

-Sub Wks_select(RetSheet As String)

-    Dim sheet As Worksheet

-    For Each sheet In ThisWorkbook.Worksheets

-        If sheet.name = RetSheet Then

-            ThisWorkbook.Worksheets(RetSheet).Select

-            Exit Sub

-        End If

-    Next sheet

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub ret_back(sh As Worksheet)

-    Dim RetSheet As String

-    RetSheet = sh.Range("ret_addr")

-    sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    sh.Range("ret_addr") = ""

-    sh.Range("rec_id") = ""

-    sh.Range("lpu_id") = ""

-    sh.Range("ent_date") = ""

-    sh.Range("lpu_name") = ""

-    sh.Range("lpu_addr") = ""

-    sh.Range("lpu_beds") = ""

-    Wks_select RetSheet

-End Sub

-

-Sub ClearSheetData(r_start As Range)

-    If r_start <> "" Then

-        r_start.Worksheet.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        r_start = ""

-    Else

-        ret_back r_start.Worksheet

-    End If

-End Sub

-

-Sub wks_sel_chng(iset As tInputSet, ByVal Target As Range, sh As Worksheet)

-    Dim DebugMode As Boolean

-    Dim in_range As Range

-    

-    DebugMode = Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-

-    If DebugMode Then

-        sh.Unprotect

-    Else

-        sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    End If

-

-    If iset.vType = INPUT_CHECK Then

-        Set in_range = Target.Worksheet.Range(iset.rChk)

-    Else

-        Set in_range = Target

-    End If

-    

-    Dim str As String

-    str = GetFocusAddress(in_range, sh.Range("h_inputs"))

-

-'    MsgBox Target.Address & "; " & str

-    If str <> Target.address Then

-        sh.Range(str).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-Dlg_lpu_card
->>>>>>
-Attribute VB_Name = "Dlg_lpu_card"

-Attribute VB_Base = "0{A9872FBD-E473-4AE0-9292-983BA36D1587}{906EBD8D-FA59-4DD0-BBC0-F7370FBEEB1B}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbLPU_List_Change()

-    Dim src As Range

-    Dim idx_src As Integer

-    

-    Set src = Worksheets(VAR_SHEET).Range(Me.cbLPU_List.RowSource)

-    idx_src = Me.cbLPU_List.ListIndex + 1

-    Me.tb_lpu_name.Text = src.Cells(idx_src, 1)

-    Me.tb_lpu_address.Text = src.Cells(idx_src, 2)

-    Me.tbBedsCount.Text = src.Cells(idx_src, 3)

-End Sub

-

-

-Private Sub cbxLPU_List_Enable_Click()

-    

-    If Me.cbxLPU_List_Enable Then

-        

-        Me.tb_lpu_name.Text = ""

-        Me.tb_lpu_name.Enabled = False

-        

-        Me.tb_lpu_address.Text = ""

-        Me.tb_lpu_address.Enabled = False

-        

-        Me.tbBedsCount.Text = ""

-        Me.tbBedsCount.Enabled = False

-        

-        Me.cbLPU_List.Enabled = True

-        cbLPU_List_Change

-    Else

-        Me.tb_lpu_name.Enabled = True

-        Me.tb_lpu_name.Text = ""

-        

-        Me.tb_lpu_address.Enabled = True

-        Me.tb_lpu_address.Text = ""

-        

-        Me.tbBedsCount.Enabled = True

-        Me.tbBedsCount.Text = ""

-        

-        Me.cbLPU_List.Enabled = False

-    End If

-End Sub

-

-<<<<<<
-======================
-UserInfo
->>>>>>
-Attribute VB_Name = "UserInfo"

-Attribute VB_Base = "0{EEA1A7D4-FC90-41EB-B07A-2394D6ADAC87}{F006F648-CB60-4054-8125-4E6FAF38821B}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Tag = vbOK

-End Sub

-

-Private Sub cbCity_Change()

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_CITY") = Me.cbCity.ListIndex

-        .Calculate

-    End With

-End Sub

-

-Private Sub cbRegion_Change()

-    Dim LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        NewRangeOffsetCol = cbRegion.Value * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).address

-        NewSumRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).address

-        .Calculate

-        .Range("IDX_CITY") = 0

-        cbCity.RowSource = NewCbxRange

-

-    End With

-    cbCity.ListIndex = 0

-End Sub

-

-<<<<<<
-======================
-mREGMAN
->>>>>>
-Attribute VB_Name = "mREGMAN"

-Option Explicit

-

-Sub hwnew()

-    Dim rs As Range

-    Dim re As Object

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    HWReset

-    With Application

-        .DisplayAlerts = False

-        .Quit

-    End With

-End Sub

-

-Sub CheckUser()

-    If Range("HW_Number") = "" Then

-        StoreHWInfo

-    End If

-    If CheckHWInfo <> True Then

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    Else

-        SetupUser

-    End If

-End Sub

-

-

-Sub SetupUser()

-    Dim cREGMAN As tREGMAN

-    Dim idx As Integer

-    Dim dlg_ui As UserInfo

-    

-    Set dlg_ui = New UserInfo

-    

-    cREGMAN = Get_REGMAN_Record()

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_REGION") = cREGMAN.Region

-        .Range("IDX_CITY") = cREGMAN.City

-    End With

-        

-    With dlg_ui

-        .cbRegion = cREGMAN.Region

-        .cbCity = cREGMAN.City

-        .tbFName = cREGMAN.FirstName

-        .tbLName = cREGMAN.LastName

-    End With

-    

-    dlg_ui.Show

-    Worksheets(REGS_SHEET).Calculate

-    

-    If dlg_ui.Tag = vbOK Then

-        With cREGMAN

-            .Region = dlg_ui.cbRegion.Value

-            .City = dlg_ui.cbCity.Value

-            .FirstName = dlg_ui.tbFName.Value

-            .LastName = dlg_ui.tbLName.Value

-        End With

-        Set_REGMAN_Record cREGMAN

-    Else

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-Sub StoreHWInfo()

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim objHW() As Long

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    Set r = Range("HW_Number")

-    i = 1

-    For Each d In dc

-        If d.drivetype = 2 Then

-            r = d.SerialNumber

-            Set r = r.Offset(1, 0)

-            ReDim Preserve objHW(i)

-            objHW(i) = d.SerialNumber

-            i = i + 1

-        End If

-    Next

-    

-    UpdateHWRecords objHW

-End Sub

-

-Function CheckHWInfo()

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim objHW() As Long

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    

-    CheckHWInfo = False

-    

-    i = GetHWRecords(objHW)

-    If i = 0 And Range("HW_Number") <> 0 Then

-        Exit Function

-    End If

-    For Each d In dc

-        If d.drivetype = 2 Then

-            Set r = Range("HW_Number")

-            Do While r <> ""

-                If r = d.SerialNumber Then

-                    For i = 1 To UBound(objHW)

-                        If d.SerialNumber = objHW(i) Then

-                            CheckHWInfo = True

-                            Exit Function

-                        End If

-                    Next i

-                End If

-                Set r = r.Offset(1, 0)

-            Loop

-        End If

-    Next

-End Function

-<<<<<<
-======================
-dbBudget
->>>>>>
-Attribute VB_Name = "dbBudget"

-Option Explicit

-

-Public Type tBUDGET

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    bdgt_NMG As Long

-    bdgt_NFG As Long

-    sale_PLAN As Long

-End Type

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function GetAll_BDGT_RecordsByLPU_ID(ByRef allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_BDGT_RecordsByLPU_ID = dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection, allBDGT, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function Get_BDGT_Record(ByVal lpu_id As Long, ByVal ent_date As String) As tBUDGET

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    Get_BDGT_Record = dbGet_BDGT_Record(dbConnection, lpu_id, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objBDGT.ID <> 0 then updatre else insert

-Public Sub Insert_BDGT_Record(objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    If objBDGT.id <> 0 Then

-        dbUpdate_BDGT_Record dbConnection, objBDGT

-    Else

-        dbInsert_BDGT_Record dbConnection, objBDGT

-    End If

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Public Sub Delete_BDGT_Record(ByRef objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    dbDelete_BDGT_Record dbConnection, objBDGT

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_BDGT_Record(dbConnection As Object, ByVal lpu_id As Long, ent_date As String) As tBUDGET

-    

-    Dim sql As String

-    Dim objBDGT As tBUDGET

-    

-    With objBDGT

-        .id = 0

-        .lpu_id = lpu_id

-        .entry_date = ent_date

-        .bdgt_NMG = 0

-        .bdgt_NFG = 0

-        .sale_PLAN = 0

-    End With

-        

-    

-    sql = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        With objBDGT

-            .entry_date = dbRecordset("entry_date")

-            .id = dbRecordset("id")

-            .lpu_id = dbRecordset("lpu_id")

-            .bdgt_NFG = dbRecordset("bdgt_NFG")

-            .bdgt_NMG = dbRecordset("bdgt_NMG")

-            .sale_PLAN = dbRecordset("sale_PLAN")

-        End With

-    End If

-    

-    dbGet_BDGT_Record = objBDGT

-End Function

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection As Object, allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_BDGT_SQL As String

-    Dim getAll_BDGT_SQL As String

-    Dim BDGT_Count As Long

-    BDGT_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_BDGT_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        BDGT_Count = dbRecordset("BDGT_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_BDGT_RecordsbyLPU_ID = BDGT_Count

-    

-    If BDGT_Count > 0 Then

-        'we have records

-        ReDim allBDGT(1 To BDGT_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_BDGT_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpBDGT As tBUDGET

-                 With tmpBDGT

-                    .entry_date = dbRecordset("entry_date")

-                    .id = dbRecordset("id")

-                    .lpu_id = dbRecordset("lpu_id")

-                    .bdgt_NFG = dbRecordset("bdgt_NFG")

-                    .bdgt_NMG = dbRecordset("bdgt_NMG")

-                    .sale_PLAN = dbRecordset("sale_PLAN")

-                 End With

-                 

-                 allBDGT(index) = tmpBDGT

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbInsert_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "lpu_budget", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    dbRecordset("entry_date") = objBDGT.entry_date

-    dbRecordset("lpu_id") = objBDGT.lpu_id

-    dbRecordset("bdgt_NMG") = objBDGT.bdgt_NMG

-    dbRecordset("bdgt_NFG") = objBDGT.bdgt_NFG

-    dbRecordset("sale_PLAN") = objBDGT.sale_PLAN

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objBDGT.id = dbRecordset("id")

-  

-End Sub

-

-Public Sub dbUpdate_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu_budget SET " & _

-    "entry_date='" & objBDGT.entry_date & "'," & _

-    "lpu_id=" & objBDGT.lpu_id & "," & _

-    "bdgt_NMG=" & objBDGT.bdgt_NMG & "," & _

-    "bdgt_NFG=" & objBDGT.bdgt_NFG & "," & _

-    "sale_PLAN=" & objBDGT.sale_PLAN & _

-    " WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-Public Sub dbDelete_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_BDGT_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbDatabase
->>>>>>
-Attribute VB_Name = "dbDatabase"

-Option Explicit

-

-

-Sub dbOpenConnection(dbConnection As Object)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-<<<<<<
-======================
-dbLPU
->>>>>>
-Attribute VB_Name = "dbLPU"

-Option Explicit

-

-Public Type tLPU

-    id As Long

-    rep_id As Long

-    name As String

-    address As String

-    beds As Integer

-End Type

-

-Function Get_LPU_Record(ByVal lpu_id As Long) As tLPU

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_LPU_Record = dbGet_LPU_Record(dbConnection, lpu_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_LPU_byQTR(allLPU() As tLPU, ent_date As String, rep_id As Long) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_LPU_byQTR = dbGetAll_LPU_byQTR(dbConnection, allLPU, ent_date, rep_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_Record(dbConnection As Object, ByVal lpu_id As Long) As tLPU

-    

-    Dim sql As String

-    Dim objLPU As tLPU

-    

-    objLPU.id = lpu_id

-    objLPU.name = ""

-    objLPU.address = ""

-    

-    sql = "SELECT * FROM lpu WHERE id=" & lpu_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objLPU.name = dbRecordset("name")

-        objLPU.address = dbRecordset("address")

-        objLPU.rep_id = dbRecordset("rep_id")

-        objLPU.beds = dbRecordset("beds")

-    End If

-    

-    dbGet_LPU_Record = objLPU

-

-End Function

-

-Function dbGetAll_LPU_byQTR(dbConnection As Object, allLPU() As tLPU, ent_date As String, rep_id As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    Dim Where As String

-    Where = "WHERE lpu_budget.entry_date like '" & ent_date & "'" & " AND lpu.id=lpu_budget.lpu_id AND lpu.rep_id=" & rep_id

-

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu_budget, lpu " & Where

-    

-    getAll_LPU_SQL = "SELECT lpu.id as id, lpu.rep_id as rep_id, lpu.name as name, lpu.address as address, lpu.beds AS beds " & _

-    "FROM lpu, lpu_budget " & Where

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_LPU_byQTR = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-dbREP
->>>>>>
-Attribute VB_Name = "dbREP"

-'Option Explicit

-'

-'Public Type tREP

-'    FirstName As String

-'    LastName As String

-'    Region As Integer

-'    City As Integer

-'End Type

-'

-'Function GetREPRecord() As tREP

-'    Dim dbConnection As Object

-'

-'    dbOpenConnection dbConnection

-'    GetREPRecord = dbGetREPRecord(dbConnection)

-'    dbCloseConnection dbConnection

-'End Function

-'

-'Sub SetREPRecord(cUser As tREP)

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbSetREPRecord dbConnection, cUser

-'    dbCloseConnection dbConnection

-'End Sub

-'

-'Public Function dbGetREPRecord(dbConnection As Object) As tREP

-'

-'    Dim SQL As String

-'    Dim objREP As tREP

-'

-'    objREP.FirstName = ""

-'    objREP.LastName = ""

-'    objREP.Region = 0

-'    objREP.City = 0

-'    SQL = "SELECT firstname, lastname, region, city FROM " & _

-'          "rep"

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open SQL, dbConnection

-'    ', 3, 3

-'    If Not dbRecordset.BOF Then

-'

-'        objREP.FirstName = dbRecordset("firstname")

-'        objREP.LastName = dbRecordset("lastname")

-'        objREP.Region = dbRecordset("region")

-'        objREP.City = dbRecordset("city")

-'

-'    End If

-'

-'    dbGetREPRecord = objREP

-'

-'End Function

-'

-'Public Sub dbSetREPRecord(dbConnection As Object, ByRef objREP As tREP)

-'

-'    Dim DeleteSQL As String

-'    Dim InsertSQL As String

-'

-'    DeleteSQL = "DELETE FROM rep"

-'    InsertSQL = "INSERT INTO rep (firstname, lastname, region, city) VALUES (" & _

-'    "'" & objREP.FirstName & "', " & _

-'    "'" & objREP.LastName & "', " & _

-'    objREP.Region & ", " & _

-'    objREP.City & ")"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-'

-'End Sub

-'

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    CheckWorkBooksArround Wb

-End Sub

-

-

-Sub CheckWorkBooksArround(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If app.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKOnly, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-        Exit Sub

-    End If

-

-End Sub

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub GetState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-        ActiveWorkbook.DisplayDrawingObjects = xlDisplayShapes

-        

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars("Worksheet Menu Bar").Visible = False

-End Sub

-

-

-Public Sub RestoreState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars("Worksheet Menu Bar").Visible = True

-End Sub

-

-

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Export"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 620

-                        .OnAction = "cmExport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(flag As Boolean)

-    If flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars("Worksheet Menu Bar")

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmExport()

-    dbExport

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    Dim dlg As dlgAbout

-    Set dlg = New dlgAbout

-    

-    dlg.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlg.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlg.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlg.Show

-End Sub

-

-Sub cmMail2Support()

-    Dim err_description As String

-    Dim dlg_msg As dlg_Mail

-    Set dlg_msg = New dlg_Mail

-    With dlg_msg

-        .Show

-        If .Tag = vbOK Then

-            ThisWorkbook.Worksheets(VAR_SHEET).Range("ERR_MESSAGE") _

-                = .tbMessage.Text

-            ThisWorkbook.Save

-            ThisWorkbook.SendMail Recipients:="infra@i-rs.ru", Subject:=PROGRAM_NAME & " ver.:" & PROGRAM_VERSION

-            MsgBox "Сообщение об ошибке отправлено. Перезагрузите программу.", vbOKOnly, PROGRAM_NAME

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-    End With

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-'        helppath = "hh.exe " & .Path & "\Telfast.chm"

-'        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub set_work_mode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-End Sub

-

-Sub cmSetStandaloneMode()

-    set_work_mode

-    ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    Dim dlg As dlgGetPwd

-    rp = common_pwd

-    

-    Set dlg = New dlgGetPwd

-    dlg.edPwd = ""

-    dlg.Show

-    

-    If dlg.edPwd = rp Then

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-        xlRestoreView

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    Dim dlg_prn As dlgPrint

-    

-    Set dlg_prn = New dlgPrint

-    

-    With dlg_prn

-        .cbMainReport = True

-        .cbMainBudget = False

-        .cbSrcData = False

-        .cbAllSheets = False

-    

-        .Show

-    

-        If .Tag = vbCancel Then

-            Exit Sub

-        End If

-    End With

-    

-    Dim PrnIdx As Integer

-    

-    With dlg_prn

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("REP_QTR", "budget", "Final")

-    Case 1111

-        plist = Array("REP_QTR", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("REP_QTR")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Clexane bar"

-Public Const common_pwd As String = "password"

-

-

-Sub SetEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    With Application

-        .Caption = PROGRAM_NAME

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .GetState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = False

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    If cWindow.Type = xlWorkbook Then

-                        cWindow.DisplayHeadings = True

-                    End If

-                Next

-            End If

-        Next

-        .Worksheets(REP_QTR_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu (True)

-        End If

-        With mobjAppState

-            .RestoreState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Option Explicit

-

-Sub UpdateHWRecords(objHW() As Long)

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    dbUpdateHWRecords dbConnection, objHW

-    dbCloseConnection dbConnection

-End Sub

-

-Function GetHWRecords(objHW() As Long) As Integer

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    GetHWRecords = dbGetHWRecords(dbConnection, objHW)

-    dbCloseConnection dbConnection

-End Function

-

-Sub HWReset()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbInsertHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    

-    Dim dbRecordset As Object

-    Dim i As Long

-    

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "hw", dbConnection, 2, 2

-    

-    For i = 1 To UBound(objHW)

-        dbRecordset.addnew

-        dbRecordset("num") = objHW(i)

-        dbRecordset.Update

-    Next i

-    

-End Sub

-

-Sub dbUpdateHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    dbDeleteHWRecord dbConnection

-    dbInsertHWRecords dbConnection, objHW

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-dbHir
->>>>>>
-Attribute VB_Name = "dbHir"

-Option Explicit

-

-Public Type tHIRURGIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    operations_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_ambulator_clexan_40mg As Integer

-    patients_ambulator_clexan_20mg As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-    patients_stationar_clexan_40mg As Integer

-    patients_stationar_clexan_20mg As Integer

-End Type

-

-' if objHir.ID <> 0 then updatre else insert

-Sub Insert_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objHir.id <> 0 Then

-        dbUpdate_Hir_Record dbConnection, objHir

-    Else

-        dbInsert_Hir_Record dbConnection, objHir

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Hir_RecordsByLPU_ID(ByRef allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Hir_RecordsByLPU_ID = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, allHir, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Hir_Record dbConnection, objHir

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objHir.ID <> 0 then updatre else insert

-

-Sub dbInsert_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_hir", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objHir

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("operations_per_quarter") = .operations_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_ambulator_clexan_20mg") = .patients_ambulator_clexan_20mg

-        dbRecordset("patients_ambulator_clexan_40mg") = .patients_ambulator_clexan_40mg

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-        dbRecordset("patients_stationar_clexan_20mg") = .patients_stationar_clexan_20mg

-        dbRecordset("patients_stationar_clexan_40mg") = .patients_stationar_clexan_40mg

-        

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objHir.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim UpdateSQL As String

-    

-    With objHir

-        UpdateSQL = "UPDATE lpu_hir SET " & _

-            "entry_date='" & objHir.entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "operations_per_quarter=" & .operations_per_quarter & "," & _

-            "risk_percent=" & .risk_percent & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_ambulator_clexan_20mg=" & .patients_ambulator_clexan_20mg & "," & _

-            "patients_ambulator_clexan_40mg=" & .patients_ambulator_clexan_40mg & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & "," & _

-            "patients_stationar_clexan_20mg=" & .patients_stationar_clexan_20mg & "," & _

-            "patients_stationar_clexan_40mg=" & .patients_stationar_clexan_40mg & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_Hir_RecordsbyLPU_ID(dbConnection As Object, allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Hir_SQL As String

-    Dim getAll_Hir_SQL As String

-    Dim Hir_Count As Long

-    Hir_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Hir_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Hir_Count = dbRecordset("HIR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Hir_RecordsbyLPU_ID = Hir_Count

-    

-    If Hir_Count > 0 Then

-        'we have records

-        ReDim allHir(1 To Hir_Count)

-        Dim index As Integer

-        index = 1

-        dbRecordset.Open getAll_Hir_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpHir As tHIRURGIA

-                 With tmpHir

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .operations_per_quarter = dbRecordset("operations_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_ambulator_clexan_20mg = dbRecordset("patients_ambulator_clexan_20mg")

-                    .patients_ambulator_clexan_40mg = dbRecordset("patients_ambulator_clexan_40mg")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                    .patients_stationar_clexan_20mg = dbRecordset("patients_stationar_clexan_20mg")

-                    .patients_stationar_clexan_40mg = dbRecordset("patients_stationar_clexan_40mg")

-                 End With

-                 

-                 allHir(index) = tmpHir

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE ID=" & objHir.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Hir_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbTer
->>>>>>
-Attribute VB_Name = "dbTer"

-Option Explicit

-

-Public Type tTERAPIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objTer.ID <> 0 then updatre else insert

-Sub Insert_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objTer.id <> 0 Then

-        dbUpdate_Ter_Record dbConnection, objTer

-    Else

-        dbInsert_Ter_Record dbConnection, objTer

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Ter_RecordsByLPU_ID(ByRef allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Ter_RecordsByLPU_ID = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, allTer, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Ter_Record dbConnection, objTer

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objTer.ID <> 0 then updatre else insert

-

-Sub dbInsert_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_ter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objTer

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objTer.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim Update_SQL As String

-    

-    With objTer

-        Update_SQL = "UPDATE lpu_ter SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "risk_percent=" & .risk_percent & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_Ter_RecordsbyLPU_ID(dbConnection As Object, allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Ter_SQL As String

-    Dim getAll_Ter_SQL As String

-    Dim Ter_Count As Long

-    Ter_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Ter_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Ter_Count = dbRecordset("TER_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Ter_RecordsbyLPU_ID = Ter_Count

-    

-    If Ter_Count > 0 Then

-        'we have records

-        ReDim allTer(1 To Ter_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_Ter_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpTer As tTERAPIA

-                 With tmpTer

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 allTer(index) = tmpTer

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE ID=" & objTer.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Ter_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-mLPU_LIST
->>>>>>
-Attribute VB_Name = "mLPU_LIST"

-Option Explicit

-

-Public Const CINP_AREA As String = "B12"

-Public Const CLPU_NAME As Integer = 0

-Public Const CLPU_NAME1 As Integer = 1

-Public Const CLPU_NAME2 As Integer = 2

-Public Const CLPU_ID As Integer = 3

-Public Const CLPU_BEDS As Integer = 4

-Public Const CLPU_NFG As Integer = 5

-Public Const CLPU_NMG As Integer = 6

-Public Const CLPU_HIR As Integer = 7

-Public Const CLPU_TER As Integer = 8

-Public Const CLPU_CAR As Integer = 9

-Public Const CLPU_FACT As Integer = 10

-Public Const CLPU_PLAN As Integer = 11

-Public Const CLPU_PAT_LPU As Integer = 16

-Public Const CLPU_BDGT As Integer = 17

-Public Const CLPU_PAT_ALL As Integer = 16

-

-

-

-Sub EditLPU(cLPU As tLPU, ent_date As String)

-    NoFunc

-End Sub

-

-Sub Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-        End If

-    Next i

-

-End Sub

-

-Sub Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btLPU_DEL_IT()

-    Dim cLPU As tLPU

-    Dim ent_date As String

-    Dim delete_all As Integer

-    Dim dlg_del As dlg_LPU_delete

-

-    With Worksheets("LPU_LIST")

-        ent_date = .Range("ent_date")

-        cLPU.id = .getCurrentLPU_ID()

-    End With

-

-    If cLPU.id = 0 Then

-        MsgBox "Укажите удаляемый объект", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    cLPU = Get_LPU_Record(cLPU.id)

-

-    Set dlg_del = New dlg_LPU_delete

-    With dlg_del

-        .chbDeleteQTR.Value = True

-        .chbDeleteAll.Value = False

-        .lComment = ent_date & ": Удаление ЛПУ '" _

-        & cLPU.name & "', расположенного по адресу:" _

-        & cLPU.address & " не разрешено."

-        .Show

-    End With

-End Sub

-

-Sub btLPU_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        

-        Wks_select .Range("ret_addr")

-    End With

-

-End Sub

-

-

-Sub btLPU_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim lpu_id As Long

-

-    i = Worksheets(VAR_SHEET).Range("QTR_ACTION").Value

-    With Worksheets("LPU_LIST")

-        ent_date = .getEnt_date()

-

-

-        lpu_id = .getCurrentLPU_ID

-        If lpu_id = 0 And i <> 6 Then

-            i = 1

-        End If

-        Select Case i

-            Case 1

-                .SelectLPU_NAME lpu_id, ent_date

-                .Range("JUMP") = ""

-            Case 2

-                .SelectLPU_BDGT lpu_id, ent_date

-                .Range("JUMP") = "LPU_BDGT"

-            Case 3

-                .SelectLPU_HIR lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_HIR"

-

-            Case 4

-                .SelectLPU_TER lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_TER"

-

-            Case 5

-                .SelectLPU_C_ACS lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        End Select

-    End With

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-dbQTR
->>>>>>
-Attribute VB_Name = "dbQTR"

-Option Explicit

-

-Public Type tQTR

-    id As Long

-    entry_date As String

-    rep_id As Long

-    sale_PLAN As Long

-    ClxnH20mg As Long

-    ClxnH40mg As Long

-    ClxnT40mg As Long

-    ClxnC_IM As Long

-    ClxnC_ACS As Long

-End Type

-

-Function Get_QTR_Record(ByVal QTR_ID As Long) As tQTR

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_QTR_Record = dbGet_QTR_Record(dbConnection, QTR_ID)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_Record(dbConnection As Object, ByVal QTR_ID As Long) As tQTR

-    

-    Dim sql As String

-    Dim objQTR As tQTR

-    

-    With objQTR

-        .ClxnC_ACS = 0

-        .ClxnC_IM = 0

-        .ClxnH20mg = 0

-        .ClxnH40mg = 0

-        .ClxnT40mg = 0

-        .entry_date = ""

-        .id = QTR_ID

-    End With

-    

-    sql = "SELECT * FROM quarter WHERE id=" & QTR_ID

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objQTR.entry_date = dbRecordset("entry_date")

-        objQTR.rep_id = dbRecordset("rep_id")

-        objQTR.sale_PLAN = dbRecordset("sale_plan")

-        objQTR.ClxnH20mg = dbRecordset("ClxnH20mg")

-        objQTR.ClxnH40mg = dbRecordset("ClxnH40mg")

-        objQTR.ClxnT40mg = dbRecordset("ClxnT40mg")

-        objQTR.ClxnC_IM = dbRecordset("ClxnC_IM")

-        objQTR.ClxnC_ACS = dbRecordset("ClxnC_ACS")

-        objQTR.id = dbRecordset("id")

-    End If

-    

-    dbGet_QTR_Record = objQTR

-

-End Function

-

-

-Function Get_QTR_Record_by_REP(ent_date As String, rep_id As Long) As tQTR

-    Dim dbConnection As Object

-    Dim allQTR() As tQTR

-    Dim i As Long

-

-    dbOpenConnection dbConnection

-

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id)

-    If i <> 0 Then

-        Get_QTR_Record_by_REP = allQTR(1)

-    End If

-

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTR_Records_by_REP(ByRef all_QTR() As tQTR, ent_date As String, rep_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-

-    GetAll_QTR_Records_by_REP = dbGetAll_QTR_Records_By_REP(dbConnection, all_QTR, ent_date, rep_id)

-

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGetAll_QTR_Records_By_REP(dbConnection As Object, all_QTR() As tQTR, ent_date As String, rep_id As Long) As Integer

-

-    Dim getCount_QTR_SQL As String

-    Dim getAll_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter " & _

-    "WHERE entry_date like '" & ent_date & "' AND rep_id=" & rep_id

-    getAll_QTR_SQL = "SELECT * FROM quarter " & _

-    "WHERE entry_date like '" & ent_date & "' AND rep_id=" & rep_id & " ORDER BY entry_date"

-

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-

-    dbRecordset.Close

-

-    dbGetAll_QTR_Records_By_REP = QTR_Count

-

-    If QTR_Count > 0 Then

-        'we have records

-        ReDim all_QTR(1 To QTR_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTR_SQL, dbConnection

-

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTR As tQTR

-                 With tmp_QTR

-                    .entry_date = dbRecordset("entry_date")

-                    .rep_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .ClxnH20mg = dbRecordset("ClxnH20mg")

-                    .ClxnH40mg = dbRecordset("ClxnH40mg")

-                    .ClxnT40mg = dbRecordset("ClxnT40mg")

-                    .ClxnC_IM = dbRecordset("ClxnC_IM")

-                    .ClxnC_ACS = dbRecordset("ClxnC_ACS")

-                    .id = dbRecordset("id")

-                 End With

-

-                 all_QTR(index) = tmp_QTR

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-cdbQTR
->>>>>>
-Attribute VB_Name = "cdbQTR"

-Option Explicit

-

-Public Type tQTR_COMMON

-    qtr As tQTR

-    i_lcd As Long           ' число ЛПУ в СПИСКЕ

-    lcd() As tLPU_COMMON    ' список ЛПУ

-    c_beds As Long          ' сумма коек

-    c_bdgt_NFG As Long      ' общий бюджет на НФГ

-    c_bdgt_NMG As Long      ' общий бюджет на НМГ

-    c_bdgt_LPU As Long      ' общий бюджет на гепарины

-    c_sale_PLAN As Long     ' план продаж репа

-    c_sale_ALL As Long      ' продажи

-    c_sale_HIR As Long      ' в хирургии

-    c_sale_TER  As Long     ' в терапии

-    c_sale_CRD  As Long     ' в кардиологии

-    c_pat_HIR   As Long     ' пациенты

-    c_pat_TER   As Long     '

-    c_pat_CRD   As Long     '

-    c_pat_ALL   As Long     '

-    c_pat_LPU   As Long     ' Всего операций

-End Type

-

-Function Get_QTR_CommonList_by_REP(ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_QTR_CommonList_by_REP = dbGet_QTR_CommonList_by_REP(dbConnection, qcd, ent_date, rep_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_CommonList_by_REP(dbConnection As Object, ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim allQTR() As tQTR

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id)

-    dbGet_QTR_CommonList_by_REP = i

-    If i > 0 Then

-        ReDim qcd(i)

-        For i = 1 To UBound(allQTR)

-            With qcd(i)

-                .qtr = allQTR(i)

-                .c_beds = 0

-                .c_bdgt_NFG = 0

-                .c_bdgt_NMG = 0

-                .c_bdgt_LPU = 0

-                .c_sale_PLAN = 0

-                .c_pat_HIR = 0

-                .c_pat_TER = 0

-                .c_pat_CRD = 0

-                .c_pat_ALL = 0

-                .c_sale_HIR = 0

-                .c_sale_TER = 0

-                .c_sale_CRD = 0

-                .c_sale_ALL = 0

-                .c_pat_LPU = 0

-                

-                j = dbGet_LPU_CommonQTR(dbConnection, .lcd, .qtr)

-                .i_lcd = j

-                If j > 0 Then

-                    For j = 1 To UBound(.lcd)

-                        .c_beds = .c_beds + .lcd(j).lpu.beds

-                        .c_bdgt_NFG = .c_bdgt_NFG + .lcd(j).bdgt.bdgt_NFG

-                        .c_bdgt_NMG = .c_bdgt_NMG + .lcd(j).bdgt.bdgt_NMG

-                        .c_bdgt_LPU = .c_bdgt_LPU + .lcd(j).bdgt_LPU

-                        .c_sale_PLAN = .c_sale_PLAN + .lcd(j).bdgt.sale_PLAN

-                        .c_pat_HIR = .c_pat_HIR + .lcd(j).pat_HIR

-                        .c_pat_TER = .c_pat_TER + .lcd(j).pat_TER

-                        .c_pat_CRD = .c_pat_CRD + .lcd(j).pat_CRD

-                        .c_pat_ALL = .c_pat_ALL + .lcd(j).pat_ALL

-                        .c_sale_HIR = .c_sale_HIR + .lcd(j).sale_HIR

-                        .c_sale_TER = .c_sale_TER + .lcd(j).sale_TER

-                        .c_sale_CRD = .c_sale_CRD + .lcd(j).sale_CRD

-                        .c_sale_ALL = .c_sale_ALL + .lcd(j).sale_ALL

-                        .c_pat_LPU = .c_pat_LPU + .lcd(j).pat_LPU

-                    Next j

-                    

-                End If

-            End With

-        Next i

-    End If

-End Function

-

-Function GetLastQtr() As String

-    Dim s As String

-    Dim r As Range

-    Set r = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Do While r.Cells(1, 1) <> ""

-        s = r.Cells(1, 1)

-        Set r = r.Cells.Offset(1, 0)

-    Loop

-    GetLastQtr = s

-End Function

-

-Function GetNextQTR(ent_date As String) As String

-    Dim rd As Range

-    Dim idx As Integer

-    Dim b As Variant

-    Dim dlg As dlg_newQTR

-    Set dlg = New dlg_newQTR

-    

-    If ent_date = "" Then

-        Dim ir As Variant

-        idx = 0

-        dlg.Show

-        b = dlg.Tag

-            

-        If IsNumeric(b) Then

-            GetNextQTR = dlg.cbQTR

-        Else

-            GetNextQTR = ""

-        End If

-    Else

-        Set rd = Worksheets(VAR_SHEET).Range("Date_Lst")

-        idx = WorksheetFunction.Match(ent_date, rd, 0)

-        GetNextQTR = WorksheetFunction.index(rd, idx + 1, 1)

-    End If

-End Function

-<<<<<<
-======================
-mRestView
->>>>>>
-Attribute VB_Name = "mRestView"

-Option Explicit

-

-Sub xlRestoreView()

-Attribute xlRestoreView.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute xlRestoreView.VB_ProcData.VB_Invoke_Func = " \n14"

-    With Application

-        .CommandBars("Standard").Visible = True

-        .CommandBars("Formatting").Visible = True

-        .DisplayFormulaBar = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .DisplayStatusBar = True

-    End With

-End Sub

-<<<<<<
-======================
-dlg_newQTR
->>>>>>
-Attribute VB_Name = "dlg_newQTR"

-Attribute VB_Base = "0{340DD43E-515B-4263-825A-A255A94425B7}{CEE59553-DC72-40C2-99DE-3AB9AE67989B}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mDec2TS
->>>>>>
-Attribute VB_Name = "mDec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-CHRT_LPU_BBL
->>>>>>
-Attribute VB_Name = "CHRT_LPU_BBL"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PAT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PAT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-<<<<<<
-======================
-CHRT_PAT_LPU
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_nextQTR
->>>>>>
-Attribute VB_Name = "dlg_nextQTR"

-Attribute VB_Base = "0{A2D9F2DF-DECC-4DE7-9E52-73E543C4AD9F}{7D8D098F-D14A-4204-9B3D-65C54EB47462}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-cdbLPU
->>>>>>
-Attribute VB_Name = "cdbLPU"

-Option Explicit

-

-Public Type tLPU_COMMON

-    lpu As tLPU

-    bdgt As tBUDGET

-    i_hir As Long

-    hir() As tHIRURGIA

-    i_ter As Long

-    ter() As tTERAPIA

-    i_ACS As Long

-    ACS() As tACS

-    bdgt_LPU As Long

-    sale_HIR As Long

-    sale_TER As Long

-    sale_CRD As Long

-    sale_ALL As Long

-    pat_HIR As Long

-    pat_TER As Long

-    pat_CRD As Long

-    pat_ALL As Long     ' Сумма всех пациентов на клексане

-    pat_LPU As Long     ' Число потенциальных пациентов для продаж клексана

-End Type

-

-Function Get_LPU_CommonQTR(ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    Get_LPU_CommonQTR = dbGet_LPU_CommonQTR(dbConnection, lcd, objQTR)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_CommonQTR(dbConnection As Object, ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    i = dbGetAll_LPU_byQTR(dbConnection, allLPU, objQTR.entry_date, objQTR.rep_id)

-    dbGet_LPU_CommonQTR = i

-    If i > 0 Then

-        ReDim lcd(i)

-        For i = 1 To UBound(allLPU)

-            dbGet_LPU_Common dbConnection, lcd(i), allLPU(i), objQTR

-        Next i

-    End If

-End Function

-

-Sub Get_LPU_Common(ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    dbGet_LPU_Common dbConnection, lcd, cLPU, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbGet_LPU_Common(dbConnection As Object, ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-

-    lcd.lpu = cLPU

-    lcd.bdgt = dbGet_BDGT_Record(dbConnection, cLPU.id, objQTR.entry_date)

-    lcd.i_hir = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, lcd.hir, cLPU.id, objQTR.entry_date)

-    lcd.i_ter = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, lcd.ter, cLPU.id, objQTR.entry_date)

-    lcd.i_ACS = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, lcd.ACS, cLPU.id, objQTR.entry_date)

-    With lcd

-        .bdgt_LPU = .bdgt.bdgt_NFG + .bdgt.bdgt_NMG

-        .pat_LPU = 0

-        If .i_hir > 0 Then

-            .pat_HIR = .hir(1).patients_ambulator_clexan + .hir(1).patients_stationar_clexan

-            .sale_HIR = objQTR.ClxnH20mg * (.hir(1).patients_ambulator_clexan_20mg + .hir(1).patients_stationar_clexan_20mg)

-            .sale_HIR = .sale_HIR + objQTR.ClxnH40mg * (.hir(1).patients_ambulator_clexan_40mg + .hir(1).patients_stationar_clexan_40mg)

-            .pat_LPU = .pat_LPU + .hir(1).operations_per_quarter

-        End If

-        If .i_ter > 0 Then

-            .pat_TER = .ter(1).patients_ambulator_clexan + .ter(1).patients_stationar_clexan

-            .sale_TER = .pat_TER * objQTR.ClxnT40mg

-            .pat_LPU = .pat_LPU + .ter(1).patients_per_quarter

-        End If

-        If .i_ACS > 0 Then

-            .pat_CRD = .ACS(1).patients_stationar_clexan

-            .sale_CRD = .pat_CRD * objQTR.ClxnC_ACS

-            .pat_LPU = .pat_LPU + .ACS(1).patients_per_quarter

-        End If

-        .pat_ALL = .pat_HIR + .pat_TER + .pat_CRD

-        .sale_ALL = .sale_HIR + .sale_TER + .sale_CRD

-    End With

-End Sub

-

-<<<<<<
-======================
-CHRT_PIE
->>>>>>
-Attribute VB_Name = "CHRT_PIE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PLN_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PLN_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_BDGT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_BDGT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_LPU_delete
->>>>>>
-Attribute VB_Name = "dlg_LPU_delete"

-Attribute VB_Base = "0{8C52BEE1-3ADE-4F5C-AACA-0C97B456CBD2}{E38DF44D-9857-40F3-8374-8CFE5C56BFDB}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlg_Mail
->>>>>>
-Attribute VB_Name = "dlg_Mail"

-Attribute VB_Base = "0{604DF175-692F-4321-9AAA-1442FA3AD341}{F0BCE93C-6F12-4F69-BC41-B2299FAA7ADE}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dbREP_id
->>>>>>
-Attribute VB_Name = "dbREP_id"

-Public Type tREPID

-    rep_id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function GetAll_REPID_Records_by_QTR(ByRef all_REPID() As tREPID, ent_date As String) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_REPID_Records_by_QTR = dbGetAll_REPID_Records_by_QTR(dbConnection, all_REPID, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-Function Get_REPID_Record(id As Long) As tREPID

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REPID_Record = dbGet_REPID_Record(dbConnection, id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_REPID_Records(ByRef all_REPID() As tREPID) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_REPID_Records = dbGetAll_REPID_Records(dbConnection, all_REPID)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function dbGet_REPID_Record(dbConnection As Object, id As Long) As tREPID

-    

-    Dim sql As String

-    Dim objREPID As tREPID

-    

-    objREPID.FirstName = ""

-    objREPID.LastName = ""

-    objREPID.Region = 0

-    objREPID.City = 0

-    sql = "SELECT rep_id, firstname, lastname, region, city FROM " & _

-          "rep WHERE rep_id=" & id

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREPID.rep_id = dbRecordset("rep_id")

-        objREPID.FirstName = dbRecordset("firstname")

-        objREPID.LastName = dbRecordset("lastname")

-        objREPID.Region = dbRecordset("region")

-        objREPID.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REPID_Record = objREPID

-        

-End Function

-

-Function dbGetAll_REPID_Records_by_QTR(dbConnection As Object, ByRef all_REPID() As tREPID, ent_date As String) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    Dim Where As String

-    

-    REPID_Count = 0

-    Where = " WHERE lpu_budget.entry_date like '" & ent_date & "' " & _

-        "AND rep.rep_id=lpu.rep_id AND lpu.id=lpu_budget.lpu_id"

-    

-    

-    getAll_REPID_SQL = "SELECT distinct rep.* FROM rep, lpu, lpu_budget" & Where

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM (" & getAll_REPID_SQL & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records_by_QTR = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Function dbGetAll_REPID_Records(dbConnection As Object, ByRef all_REPID() As tREPID) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    REPID_Count = 0

-    

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM rep"

-    getAll_REPID_SQL = "SELECT * FROM rep"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-cdbExport
->>>>>>
-Attribute VB_Name = "cdbExport"

-Option Explicit

-

-Function GetDBSN() As String

-    Dim n As Long

-    Randomize Timer

-    n = Int((100000000 - 1000000 + 1) * Rnd + 1000000)

-    GetDBSN = Dec2ThirtySix(n)

-End Function

-

-Sub dbExport()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim old_file As String

-    

-    On Error GoTo ErrHandler

-    

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    old_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & "*.*"

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & GetDBSN() & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.DeleteFile old_file, True

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Данные экспортированы в файл:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для передачи", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-Exit Sub

-

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-<<<<<<
-======================
-mRegs
->>>>>>
-Attribute VB_Name = "mRegs"

-Option Explicit

-

-Function GetRegionName(idx As Integer) As String

-    GetRegionName = Worksheets(REGS_SHEET).Range("LST_REGIONS").Cells(idx + 1, 1).Text

-End Function

-

-Function GetCityName(idx_reg As Integer, idx_city As Integer) As String

-    GetCityName = Worksheets(REGS_SHEET).Range("CITY_TABLES").Offset(idx_city + 1, idx_reg * 2).Text

-End Function

-

-Sub testReg()

-    Dim r As Integer

-    Dim c As Integer

-    Dim s As String

-    

-    r = 3

-    c = 3

-    s = GetRegionName(r)

-    s = s & ", " & GetCityName(r, c)

-    MsgBox s

-End Sub

-

-<<<<<<
-======================
-RM_QTR
->>>>>>
-Attribute VB_Name = "RM_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CRGN_QT As Integer = 0

-Const CRGN_PLN As Integer = 2

-Const CRGN_FCT As Integer = 3

-Const CRGN_BDG As Integer = 4

-Const CRGN_LPU As Integer = 5

-Const CRGN_REP As Integer = 6

-Const CRGN_HIR As Integer = 7

-Const CRGN_TER As Integer = 8

-Const CRGN_CRD As Integer = 9

-Const CRGN_CLXN_BDG As Integer = 10

-Const CRGN_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub update_history()

-    Dim objRGN() As tREGION

-    Dim i As Long

-    Dim r As Range

-    Dim cRMan As tREGMAN

-

-    cRMan = Get_REGMAN_Record

-    

-    Range("D4") = cRMan.LastName

-    Range("D5") = cRMan.FirstName

-

-    Range("H4") = GetRegionName(cRMan.Region)

-    

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetRGN_COMM_DATA(objRGN)

-    

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objRGN)

-            r.Offset(i - 1, CRGN_QT) = objRGN(i).ent_date

-            r.Offset(i - 1, CRGN_FCT) = objRGN(i).total_SALE

-            r.Offset(i - 1, CRGN_PLN) = objRGN(i).sale_PLAN

-            r.Offset(i - 1, CRGN_BDG) = objRGN(i).total_BDGT

-            r.Offset(i - 1, CRGN_LPU) = objRGN(i).total_LPU

-            r.Offset(i - 1, CRGN_REP) = objRGN(i).total_REP

-            r.Offset(i - 1, CRGN_HIR) = objRGN(i).total_HIR

-            r.Offset(i - 1, CRGN_TER) = objRGN(i).total_TER

-            r.Offset(i - 1, CRGN_CRD) = objRGN(i).total_ACS

-            If objRGN(i).total_BDGT <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_BDG) = objRGN(i).total_SALE / objRGN(i).total_BDGT

-            End If

-            If objRGN(i).total_BDGT_NMG <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_NMG) = objRGN(i).total_SALE / objRGN(i).total_BDGT_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRGN_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRM_QtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR_RM

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR_RM

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR_RM

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = RM_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CRGN_QT + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    If r = "" Then

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = currRange.address

-        With Worksheets("REP_LIST")

-            .Range("ret_addr") = "RM_QTR"

-            .Range("ent_date") = r

-            .Range("VIEW_ONLY") = True

-        End With

-    End If

-    Cancel = True

-    btRM_QTR_Do_IT

-End Sub

-

-

-<<<<<<
-======================
-dbREG_MAN
->>>>>>
-Attribute VB_Name = "dbREG_MAN"

-Option Explicit

-

-Public Type tREGMAN

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function Get_REGMAN_Record() As tREGMAN

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REGMAN_Record = dbGet_REGMAN_Record(dbConnection)

-    dbCloseConnection dbConnection

-End Function

-

-Sub Set_REGMAN_Record(cREGMAN As tREGMAN)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbSet_REGMAN_Record dbConnection, cREGMAN

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_REGMAN_Record(dbConnection As Object) As tREGMAN

-    

-    Dim sql As String

-    Dim objREGMAN As tREGMAN

-    

-    objREGMAN.FirstName = ""

-    objREGMAN.LastName = ""

-    objREGMAN.Region = 0

-    objREGMAN.City = 0

-    sql = "SELECT firstname, lastname, region, city FROM " & _

-          "reg_man"

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREGMAN.FirstName = dbRecordset("firstname")

-        objREGMAN.LastName = dbRecordset("lastname")

-        objREGMAN.Region = dbRecordset("region")

-        objREGMAN.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REGMAN_Record = objREGMAN

-        

-End Function

-

-Public Sub dbSet_REGMAN_Record(dbConnection As Object, ByRef objREGMAN As tREGMAN)

-  

-    Dim DeleteSQL As String

-    Dim InsertSQL As String

-    

-    DeleteSQL = "DELETE FROM reg_man"

-    InsertSQL = "INSERT INTO reg_man (firstname, lastname, region, city) VALUES (" & _

-    "'" & objREGMAN.FirstName & "', " & _

-    "'" & objREGMAN.LastName & "', " & _

-    objREGMAN.Region & ", " & _

-    objREGMAN.City & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    dbRecordset.Open InsertSQL, dbConnection

-       

-End Sub

-

-

-

-<<<<<<
-======================
-dbDatabaseMerge
->>>>>>
-Attribute VB_Name = "dbDatabaseMerge"

-Option Explicit

-

-Public Type tDBFIELD

-    name As String

-End Type

-

-Public Type tDBTABLE

-    name As String

-    field() As tDBFIELD

-End Type

-

-

-Function dbGetConnection(dbAccessFileFullPath As String) As Object

-    Dim dbConnection As Object

-    Dim dbAccessFilePasswd As String

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFileFullPath & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    Set dbGetConnection = dbConnection

-End Function

-

-Sub dbCloseOpenedConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteOpenedSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-Function dbMergeRM(from_dbConnection As Object, to_dbConnection As Object) As Long

-

-    Dim getRecordset As Object

-    Dim getREPData_SQL As String

-    Dim REP_fn As String

-    Dim REP_ln As String

-    Dim REP_region As String

-    Dim REP_city As String

-

-

-    getREPData_SQL = "SELECT * FROM reg_man"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getREPData_SQL, from_dbConnection

-        

-        If Not getRecordset.BOF Then

-            REP_fn = getRecordset("firstname")

-            REP_ln = getRecordset("lastname")

-            REP_city = getRecordset("city")

-            REP_region = getRecordset("region")

-        Else

-            MsgBox "There is no information about rep! This database cannot be merged!!!"

-            dbMergeRM = -1

-            Exit Function

-        End If

-    

-    Dim insertRecordset As Object

-    Set insertRecordset = CreateObject("ADODB.Recordset")

-        

-    insertRecordset.Open "reg_man", to_dbConnection, 2, 2

-    insertRecordset.addnew

-        

-    insertRecordset("firstname") = REP_fn

-    insertRecordset("lastname") = REP_ln

-    insertRecordset("region") = REP_region

-    insertRecordset("city") = REP_city

-    insertRecordset.Update

-    insertRecordset.MoveLast

-    'new ID

-    

-    dbMergeRM = insertRecordset("mgr_id")

-    

-End Function

-

-Sub dbMergeLPU(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getLPU_SQL As String

-    Dim getRecordset As Object

-    Dim idx As Long

-    idx = 1

-    

-    getLPU_SQL = "SELECT * FROM lpu"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getLPU_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            ReDim Preserve objLPU(1 To idx)

-            objLPU(idx).old_lpu_id = getRecordset("id")

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "lpu", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("name") = getRecordset("name")

-            insRS("address") = getRecordset("address")

-            insRS("beds") = getRecordset("beds")

-            insRS.Update

-            insRS.MoveLast

-            'new ID

-            

-            objLPU(idx).new_lpu_id = insRS("id")

-                        

-            idx = idx + 1

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about LPU! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-

-Sub dbMergeLPURelated(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object)

-

-    ' 6 tables to change

-    Dim tables(1 To 5) As tDBTABLE

-    

-    'lpu budget

-    tables(1).name = "lpu_budget"

-    ReDim tables(1).field(1 To 4)

-    

-    tables(1).field(1).name = "entry_date"

-    tables(1).field(2).name = "bdgt_NMG"

-    tables(1).field(3).name = "bdgt_NFG"

-    tables(1).field(4).name = "sale_PLAN"

-    

-    'lpu hir

-    tables(2).name = "lpu_hir"

-    ReDim tables(2).field(1 To 13)

-    

-    tables(2).field(1).name = "entry_date"

-    tables(2).field(2).name = "operations_per_quarter"

-    tables(2).field(3).name = "risk_percent"

-    tables(2).field(4).name = "patients_with_risk_ON"

-    tables(2).field(5).name = "patients_ambulator"

-    tables(2).field(6).name = "patients_ambulator_nmg"

-    tables(2).field(7).name = "patients_ambulator_clexan"

-    tables(2).field(8).name = "patients_ambulator_clexan_40mg"

-    tables(2).field(9).name = "patients_ambulator_clexan_20mg"

-    tables(2).field(10).name = "patients_stationar_nmg"

-    tables(2).field(11).name = "patients_stationar_clexan"

-    tables(2).field(12).name = "patients_stationar_clexan_40mg"

-    tables(2).field(13).name = "patients_stationar_clexan_20mg"

-    

-    

-    'lpu acs

-    tables(3).name = "lpu_acs"

-    ReDim tables(3).field(1 To 5)

-    

-    tables(3).field(1).name = "entry_date"

-    tables(3).field(2).name = "patients_with_geparins"

-    tables(3).field(3).name = "patients_per_quarter"

-    tables(3).field(4).name = "patients_stationar_nmg"

-    tables(3).field(5).name = "patients_stationar_clexan"

-    

-    'lpu acs

-    tables(4).name = "lpu_im"

-    ReDim tables(4).field(1 To 5)

-    

-    tables(4).field(1).name = "entry_date"

-    tables(4).field(2).name = "patients_with_geparins"

-    tables(4).field(3).name = "patients_per_quarter"

-    tables(4).field(4).name = "patients_stationar_nmg"

-    tables(4).field(5).name = "patients_stationar_clexan"

-    

-    

-    'lpu acs

-    tables(5).name = "lpu_ter"

-    ReDim tables(5).field(1 To 9)

-    

-    tables(5).field(1).name = "entry_date"

-    tables(5).field(2).name = "patients_per_quarter"

-    tables(5).field(3).name = "risk_percent"

-    tables(5).field(4).name = "patients_with_risk_ON"

-    tables(5).field(5).name = "patients_ambulator"

-    tables(5).field(6).name = "patients_ambulator_nmg"

-    tables(5).field(7).name = "patients_ambulator_clexan"

-    tables(5).field(8).name = "patients_stationar_nmg"

-    tables(5).field(9).name = "patients_stationar_clexan"

-    

-    

-    

-    Dim tbl_idx As Integer

-    

-    For tbl_idx = 1 To UBound(tables)

-        

-        Dim getSQL As String

-        Dim getRS As Object

-        

-        

-        

-        Set getRS = CreateObject("ADODB.Recordset")

-        

-        getSQL = "SELECT * FROM " & tables(tbl_idx).name

-        getRS.Open getSQL, from_db

-        

-        If Not getRS.BOF Then

-            Do While Not getRS.EOF

-                Dim insRS As Object

-                Set insRS = CreateObject("ADODB.Recordset")

-                

-                insRS.Open tables(tbl_idx).name, to_db, 2, 2

-                insRS.addnew

-                Dim fld_idx As Integer

-    

-                    For fld_idx = 1 To UBound(tables(tbl_idx).field)

-                        insRS(tables(tbl_idx).field(fld_idx).name) = getRS(tables(tbl_idx).field(fld_idx).name)

-                        insRS("lpu_id") = findNewLPU_IDByOld(objLPU, getRS("lpu_id"))

-                    Next fld_idx

-                    

-                insRS.Update

-                insRS.MoveLast

-                getRS.MoveNext

-            Loop

-        End If

-        

-        

-    Next tbl_idx

-

-End Sub

-

-Function findNewLPU_IDByOld(objLPU() As tLPUCONVERTION, old_id As Long)

-

-Dim i As Integer

-For i = 1 To UBound(objLPU)

-    If objLPU(i).old_lpu_id = old_id Then

-        findNewLPU_IDByOld = objLPU(i).new_lpu_id

-        Exit Function

-    End If

-Next i

-

-findNewLPU_IDByOld = -1

-End Function

-

-

-

-

-

-Sub dbMergeQTR(from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getQTR_SQL As String

-    Dim getRecordset As Object

-    

-    getQTR_SQL = "SELECT * FROM quarter"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getQTR_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "quarter", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("entry_date") = getRecordset("entry_date")

-            insRS("sale_plan") = getRecordset("sale_plan")

-            insRS("ClxnH20mg") = getRecordset("ClxnH20mg")

-            insRS("ClxnH40mg") = getRecordset("ClxnH40mg")

-            insRS("ClxnT40mg") = getRecordset("ClxnT40mg")

-            insRS("ClxnC_IM") = getRecordset("ClxnC_IM")

-            insRS("ClxnC_ACS") = getRecordset("ClxnC_ACS")

-            

-            

-            insRS.Update

-            

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about quarter budget! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-dbMerge
->>>>>>
-Attribute VB_Name = "dbMerge"

-Option Explicit

-

-Public Type tLPUCONVERTION

-    old_lpu_id As Long

-    new_lpu_id As Long

-End Type

-

-Public Type tREPCONVERTION

-    old_rep_id As Long

-    new_lp_id As Long

-End Type

-

-

-

-Sub Merge_Clear_All_Data(access_file_full_path As String)

-    

-    Dim db As Object

-    Dim tables_to_clear() As String

-    On Error GoTo ErrHandler

-    

-    ReDim tables_to_clear(1 To 8)

-    tables_to_clear(1) = "rep"

-    tables_to_clear(2) = "lpu"

-    tables_to_clear(3) = "lpu_budget"

-    tables_to_clear(4) = "lpu_hir"

-    tables_to_clear(5) = "lpu_ter"

-    tables_to_clear(6) = "lpu_acs"

-    tables_to_clear(7) = "lpu_im"

-    tables_to_clear(8) = "quarter"

-    

-    Set db = dbGetConnection(access_file_full_path)

-

-    Dim i As Integer

-    

-    For i = 1 To UBound(tables_to_clear)

-        

-        If tables_to_clear(i) <> "" Then

-            Dim Clear_SQL As String

-            Clear_SQL = "DELETE FROM " & tables_to_clear(i)

-            dbExecuteOpenedSQL db, Clear_SQL

-        Else

-            'do nothing or show message

-        End If

-    Next i

-    

-    dbCloseOpenedConnection db

-    Set db = Nothing

-    

-'    Dim Engine As Object

-'    Set Engine = CreateObject("JRO.JetEngine")

-'    Engine.CompactDatabase "Password=password;Data Source=" & access_file_full_path, _

-'    "Password=password;Data Source=c:\tmp\1.mdb"

-    

-Exit Sub

-

-ErrHandler:

-    MsgBox "something wrong: " & err.Description

-    Resume Next

-    

-End Sub

-

-Function MergeRM(from_file As String, to_file As String) As Long

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    MergeRM = dbMergeRM(db1, db2)

-    'MsgBox "new rep ID is " & new_rep_id

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Function

-

-Sub MergeQTR(from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeQTR db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-Sub MergeREP(objREP() As tLPUCONVERTION, from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeLPU objREP, db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-Sub MergeLPU(objLPU() As tLPUCONVERTION, from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeLPU objLPU, db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-Sub MergeLPURelated(objLPU() As tLPUCONVERTION, from_file As String, to_file As String)

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    dbMergeLPURelated objLPU, db1, db2

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-

-End Sub

-

-Sub MergeGlobal(rm_files() As String, fm_file As String)

-

-    Dim i As Integer

-    'clear output file content

-    Merge_Clear_All_Data fm_file

-    

-    For i = 1 To UBound(rm_files)

-        

-        Dim rm_file As String

-        'setup input and output files

-        rm_file = rm_files(i)

-        

-        Dim new_rm_id As Long

-        ' insert REP data and get new rep_id

-        new_rm_id = MergeRM(rm_file, fm_file)

-        

-        'insert all REP for new generateg rm_id

-        

-        Dim objLPU() As tLPUCONVERTION

-        'insert all LPU using new generated rep_id

-        'and populate objLPU old->new relation object

-        

-        MergeLPU objLPU, rm_file, fm_file, new_rm_id

-        

-        'insert quarter data using new rep_id

-        MergeQTR rm_file, fm_file, new_rm_id

-        

-        

-        ' and.... insert all another data (5 tables excl version and hw)

-        'using objLPU old->new relation object

-        MergeLPURelated objLPU, rm_file, fm_file

-    

-    

-    Next i

-    

-End Sub

-

-Function GetDBList(MyPath As String, ByRef dblist() As String) As Integer

-    Dim i As Integer

-    Dim MyName, MyMask

-    MyMask = MyPath & PROGRAM_IMPORTNAME & PROGRAM_DATAEXT

-    i = 0

-    MyName = Dir(MyMask)      ' Retrieve the first entry.

-    Do While MyName <> ""    ' Start the loop.

-        ' Ignore the current directory and the encompassing directory.

-        If MyName <> "." And MyName <> ".." Then

-            ' Use bitwise comparison to make sure MyName is a directory.

-            i = i + 1

-            ReDim Preserve dblist(i)

-            dblist(i) = MyPath & MyName

-        End If

-        MyName = Dir    ' Get next entry.

-    Loop

-    GetDBList = i

-End Function

-

-Sub test_import()

-    Dim MyPath As String

-    Dim flist() As String

-    Dim i As Integer

-    MyPath = "g:\"

-    i = GetDBList(MyPath, flist)

-    If i > 0 Then

-        MergeGlobal flist, GetWBPath(ThisWorkbook.FullName) & "clexane-rm.mdb"

-    End If

-End Sub

-<<<<<<
-======================
-dbxyz_test
->>>>>>
-Attribute VB_Name = "dbxyz_test"

-Option Explicit

-

-Sub mrg_main()

-    Dim rep_files(1 To 2) As String

-    Dim rm_file As String

-    

-    'setup input and output files

-    rep_files(1) = "e:\work\aventis\clexane-mr1.mdb"

-    rep_files(2) = "e:\work\aventis\clexane-mr2.mdb"

-    

-    'setup output file

-    rm_file = "e:\work\aventis\clexane-rm.mdb"

-    

-    MergeGlobal rep_files, rm_file

-End Sub

-

-Sub ttt()

-    Dim rcd() As tREPID_COMMON

-    Dim i As Long

-    i = Get_REP_CommonList_by_QTR(rcd, "2003-III")

-End Sub

-

-Sub getallreps()

-    Dim i As Integer

-    Dim j As Integer

-    Dim k As Integer

-    Dim s As String

-    

-    Dim allREPID() As tREPID

-    Dim allQTRREP() As tQTR

-    Dim allLPU() As tLPU

-    

-    i = GetAll_REPID_Records(allREPID)

-    

-    If i > 0 Then

-        For i = 1 To UBound(allREPID)

-            j = GetAll_QTR_Records_by_REP(allQTRREP, "%", allREPID(i).rep_id)

-            If j > 0 Then

-                For j = 1 To UBound(allREPID)

-                    k = GetAll_LPU_byQTR(allLPU, allQTRREP(j).entry_date, allREPID(i).rep_id)

-                    If k > 0 Then

-                        For k = 1 To UBound(allLPU)

-                            MsgBox allLPU(k).name

-                        Next k

-                    End If

-                Next j

-            End If

-        Next i

-    End If

-End Sub

-

-<<<<<<
-======================
-dbQTR_RM
->>>>>>
-Attribute VB_Name = "dbQTR_RM"

-Option Explicit

-

-Public Type tQTRRM

-    id As Long

-    entry_date As String

-    rm_id As Long

-    sale_PLAN As Long

-End Type

-

-

-Sub Insert_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objQTRRM.id <> 0 Then

-        dbUpdate_QTRRM_Record dbConnection, objQTRRM

-    Else

-        dbInsert_QTRRM_Record dbConnection, objQTRRM

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-Function Get_QTRRM_Record(ent_date As String) As tQTRRM

-    Dim dbConnection As Object

-    Dim allQTRRM() As tQTRRM

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    i = dbGetAll_QTRRM_Records(dbConnection, allQTRRM, ent_date)

-    If i <> 0 Then

-        Get_QTRRM_Record = allQTRRM(1)

-    End If

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTRRM_Records(ByRef all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_QTRRM_Records = dbGetAll_QTRRM_Records(dbConnection, all_QTRRM, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_QTRRM_Record dbConnection, objQTRRM

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objQTRRM.ID <> 0 then updatre else insert

-Sub dbInsert_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "quarter_rm", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objQTRRM

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("sale_plan") = .sale_PLAN

-        dbRecordset("rm_id") = .rm_id

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objQTRRM.id = dbRecordset("id")

-

-End Sub

-

-Sub dbUpdate_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim Update_SQL As String

-    

-    With objQTRRM

-        Update_SQL = "UPDATE quarter_rm SET " & _

-            "entry_date='" & .entry_date & "'" & "," & _

-            "rm_id=" & .rm_id & "," & _

-            "sale_plan=" & .sale_PLAN & "," & _

-            " WHERE id=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if ent_date = % then all_records

-Function dbGetAll_QTRRM_Records(dbConnection As Object, all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    

-    Dim getCount_QTRRM_SQL As String

-    Dim getAll_QTRRM_SQL As String

-    Dim QTRRM_Count As Long

-    QTRRM_Count = 0

-    

-    getCount_QTRRM_SQL = "SELECT COUNT(*) AS QTRRM_TOTAL FROM quarter_rm WHERE entry_date like '" & ent_date & "'"

-    getAll_QTRRM_SQL = "SELECT * FROM quarter_rm WHERE entry_date like '" & ent_date & "' ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTRRM_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTRRM_Count = dbRecordset("QTRRM_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_QTRRM_Records = QTRRM_Count

-    

-    If QTRRM_Count > 0 Then

-        'we have records

-        ReDim all_QTRRM(1 To QTRRM_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTRRM_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTRRM As tQTRRM

-                 With tmp_QTRRM

-                    .entry_date = dbRecordset("entry_date")

-                    .rm_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .id = dbRecordset("id")

-                 End With

-                 

-                 all_QTRRM(index) = tmp_QTRRM

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM quarter_rm " & _

-    "WHERE id=" & objQTRRM.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-    

-    'delete related budget entries

-    MsgBox "remember delete related"

-'    dbDelete_BDGT_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Hir_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Ter_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_ACS_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-       

-End Sub

-

-

-<<<<<<
-======================
-REP_LIST
->>>>>>
-Attribute VB_Name = "REP_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentREP_ID() As Long

-    Dim r As Range

-

-    With Worksheets("REP_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CREP_ID)

-    End With

-

-    getCurrentREP_ID = r

-End Function

-

-Public Sub REP_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Rep_Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Rep_Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Rep_Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Rep_Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectREP_LPU(rep_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim r_id As Long

-    

-    Range("JUMP") = "LPU_LIST"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-        .Range("ent_date") = ent_date

-    End With

-End Sub

-

-Public Sub SelectREP_QTR(rep_id As Long)

-    Dim vo As Boolean

-    Dim r_id As Long

-    

-    Range("JUMP") = "REP_QTR"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("REP_QTR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateREPList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim rep_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CREP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CREP_AREA).row, CREP_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    rep_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CREP_AREA).Column

-    

-    If i < 4 Then

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 1

-    Else

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 2

-    End If

-    

-    If rep_id = 0 Then

-        Range("LAST_FOCUS") = Range(CREP_AREA).address

-    End If

-

-    If rep_id = 0 Then

-        i = CREP_NAME

-        Range("JUMP") = ""

-    Else

-        btREP_LIST_DO_IT

-    End If

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateREPList()

-    Dim rcd() As tREPID_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-

-    ent_date = getEnt_date

-

-    i = Get_REP_CommonList_by_QTR(rcd, ent_date)

-

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(rcd)

-            r.Offset(i - 1, CREP_NAME) = rcd(i).rep.FirstName & " " & rcd(i).rep.LastName

-            r.Offset(i - 1, CREP_ID) = rcd(i).rep.rep_id

-            r.Offset(i - 1, CREP_BEDS) = rcd(i).qtrs(1).c_beds

-

-            r.Offset(i - 1, CREP_NFG) = rcd(i).qtrs(1).c_bdgt_NFG

-            r.Offset(i - 1, CREP_NMG) = rcd(i).qtrs(1).c_bdgt_NMG

-

-            r.Offset(i - 1, CREP_PLAN) = rcd(i).qtrs(1).qtr.sale_PLAN

-

-            r.Offset(i - 1, CREP_HIR) = rcd(i).qtrs(1).c_pat_HIR

-            r.Offset(i - 1, CREP_TER) = rcd(i).qtrs(1).c_pat_TER

-            r.Offset(i - 1, CREP_CAR) = rcd(i).qtrs(1).c_pat_CRD

-            r.Offset(i - 1, CREP_FACT) = rcd(i).qtrs(1).c_sale_ALL

-            r.Offset(i - 1, CREP_PAT_LPU) = rcd(i).qtrs(1).c_pat_LPU

-            r.Offset(i - 1, CREP_BDGT) = rcd(i).qtrs(1).c_bdgt_LPU

-            If rcd(i).qtrs(1).c_bdgt_LPU > 0 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = rcd(i).qtrs(1).c_sale_ALL / rcd(i).qtrs(1).c_bdgt_LPU

-            End If

-            If r.Offset(i - 1, CREP_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-

-

-<<<<<<
-======================
-mREP_LIST
->>>>>>
-Attribute VB_Name = "mREP_LIST"

-Option Explicit

-

-Public Const CREP_AREA As String = "B12"

-Public Const CREP_NAME As Integer = 0

-Public Const CREP_NAME1 As Integer = 1

-Public Const CREP_NAME2 As Integer = 2

-Public Const CREP_ID As Integer = 3

-Public Const CREP_BEDS As Integer = 4

-Public Const CREP_NFG As Integer = 5

-Public Const CREP_NMG As Integer = 6

-Public Const CREP_HIR As Integer = 7

-Public Const CREP_TER As Integer = 8

-Public Const CREP_CAR As Integer = 9

-Public Const CREP_FACT As Integer = 10

-Public Const CREP_PLAN As Integer = 11

-Public Const CREP_PAT_LPU As Integer = 16

-Public Const CREP_BDGT As Integer = 17

-Public Const CREP_PAT_ALL As Integer = 16

-

-

-

-Sub EditREP(cRep As tREPID, ent_date As String)

-    NoFunc

-End Sub

-

-Sub Rep_Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-        End If

-    Next i

-

-End Sub

-

-Sub Rep_Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btREP_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = "RM_QTR"

-    End With

-    ThisWorkbook.Worksheets("RM_QTR").Activate

-End Sub

-

-

-Sub btREP_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim rep_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("REP_LST_DETALS")

-    With Worksheets("REP_LIST")

-        rep_id = .getCurrentREP_ID

-        

-        Select Case i

-            Case 1:

-                .SelectREP_QTR rep_id

-            Case 2:

-                ent_date = .getEnt_date()

-                .SelectREP_LPU rep_id, ent_date

-        End Select

-    End With

-    

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-

-

-

-<<<<<<
-======================
-cdbREP
->>>>>>
-Attribute VB_Name = "cdbREP"

-Option Explicit

-

-Public Type tREPID_COMMON

-    rep As tREPID

-    i_qtrs As Integer

-    qtrs() As tQTR_COMMON

-End Type

-

-Function Get_REP_CommonList_by_QTR(ByRef rcd() As tREPID_COMMON, ent_date As String) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_REP_CommonList_by_QTR = dbGet_REP_CommonList_by_QTR(dbConnection, rcd, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_REP_CommonList_by_QTR(dbConnection As Object, ByRef rcd() As tREPID_COMMON, ent_date As String) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim k As Long

-    Dim allREPID() As tREPID

-    

-    i = dbGetAll_REPID_Records_by_QTR(dbConnection, allREPID, ent_date)

-    dbGet_REP_CommonList_by_QTR = i

-    If i > 0 Then

-        ReDim rcd(i)

-        For i = 1 To UBound(allREPID)

-            rcd(i).rep = allREPID(i)

-            rcd(i).i_qtrs = Get_QTR_CommonList_by_REP(rcd(i).qtrs, ent_date, allREPID(i).rep_id)

-        Next i

-    End If

-End Function

-

-

-

-<<<<<<
-======================
-CHRT_PAT_LPU_A
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU_A"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-cdbRegion
->>>>>>
-Attribute VB_Name = "cdbRegion"

-Option Explicit

-

-Type tREGION

-    ent_date As String

-    total_SALE As Long ' общий объем продаж

-    total_BDGT As Long ' бюджет всех ЛПУ

-    total_BDGT_NMG As Long ' бюджет всех ЛПУ на НМГ

-    total_LPU As Long ' число ЛПУ

-    total_REP   As Long ' число репов

-    total_BEDS As Long ' общее число коек

-    total_HIR As Long '  общее число пациентов на клексане в хирургии

-    total_TER As Long '  общее число пациентов на клексане в терапии

-    total_ACS As Long '  общее число пациентов на клексане в кардиологии

-    sale_PLAN As Long '  план продаж Авентиса

-End Type

-

-Function GetRGN_COMM_DATA(ByRef reg_data() As tREGION) As Integer

-    Dim q_date() As String

-    Dim q_count As Integer, i As Integer

-    

-    q_count = getAllQTRNames(q_date)

-    If q_count > 0 Then

-        ReDim reg_data(q_count)

-        For i = 1 To q_count

-            Dim current_rep_count As Integer

-            current_rep_count = getREGION_by_QTR(q_date(i), reg_data(i))

-        Next i

-    End If

-    

-    GetRGN_COMM_DATA = q_count

-End Function

-

-Function getAllQTRNames(ByRef qtr_lst() As String) As Integer

-    

-    Dim sql As String

-    Dim i As Integer

-    Dim db As Object, rs As Object

-    

-    

-    sql = "SELECT DISTINCT entry_date FROM lpu_budget"

-    i = 0

-    

-    dbOpenConnection db

-    Set rs = CreateObject("ADODB.Recordset")

-    

-    rs.Open sql, db

-        

-        If Not rs.BOF Then

-            Do While Not rs.EOF

-                i = i + 1

-                ReDim Preserve qtr_lst(i)

-                qtr_lst(i) = rs("entry_date")

-                rs.MoveNext

-            Loop

-        Else

-            getAllQTRNames = 0

-            Exit Function

-        End If

-    getAllQTRNames = i

-    dbCloseConnection db

-End Function

-

-Function getREGION_by_QTR(ent_date As String, treg As tREGION) As Integer

-    Dim rep_count As Integer

-    rep_count = 0

-    

-    Dim reps() As tREPID_COMMON

-    rep_count = Get_REP_CommonList_by_QTR(reps, ent_date)

-    

-    treg.ent_date = ent_date

-    treg.total_BDGT = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.total_BDGT_NMG = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.sale_PLAN = 0 ' quarter.sale_plan

-    treg.total_SALE = 0 'summ of

-    ' hir = (amb40+st40)*pr40 + (amb20+st20)*pr20

-    'ter (amb_clx+stat_clx)*price

-    ' acs xxx

-    'price per rep

-    treg.total_HIR = 0 'patiens clxn

-    treg.total_TER = 0 'patiens clxn

-    treg.total_ACS = 0 'patiens clxn

-    treg.total_LPU = 0 'lpu

-    treg.total_BEDS = 0 'lpu.beds

-    treg.total_REP = 0 '

-    

-    If rep_count > 0 Then

-        Dim i As Integer

-        

-        For i = 1 To UBound(reps)

-            ' current rep is reps(i)

-            With reps(i)

-                treg.total_BDGT = treg.total_BDGT + .qtrs(1).c_bdgt_NFG + .qtrs(1).c_bdgt_NMG

-                treg.total_BDGT_NMG = treg.total_BDGT_NMG + .qtrs(1).c_bdgt_NMG

-                treg.sale_PLAN = treg.sale_PLAN + .qtrs(1).c_sale_PLAN

-                treg.total_SALE = treg.total_SALE + .qtrs(1).c_sale_ALL

-                treg.total_HIR = treg.total_HIR + .qtrs(1).c_pat_HIR

-                treg.total_TER = treg.total_TER + .qtrs(1).c_pat_TER

-                treg.total_ACS = treg.total_ACS + .qtrs(1).c_pat_CRD

-                treg.total_LPU = treg.total_LPU + .qtrs(1).i_lcd

-                treg.total_BEDS = treg.total_BEDS + .qtrs(1).c_beds

-                treg.total_REP = treg.total_REP + 1

-            End With

-            

-        Next i

-        

-    End If

-    

-    getREGION_by_QTR = treg.total_REP

-End Function

-

-<<<<<<
-======================
-mRM_QTR
->>>>>>
-Attribute VB_Name = "mRM_QTR"

-Option Explicit

-

-Sub btRM_QTR_Do_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    Dim i As Integer

-    Dim def_dir As String

-    Dim flist() As String

-    

-    idx = Worksheets(VAR_SHEET).Range("RM_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            def_dir = GetWBPath(ThisWorkbook.FullName)

-            If GetImportDirectory(def_dir, flist) Then

-                Dim db_list() As String

-                i = GetDBList(flist(0), db_list)

-                If i > 0 Then

-                    MergeGlobal db_list, GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-                End If

-            End If

-            Worksheets(RM_QTR_SHEET).update_history

-        Case 2

-            Worksheets("REP_LIST").Select

-        Case 3

-            cmExport

-    End Select

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-End Sub

-

-<<<<<<
-======================
-mImport
->>>>>>
-Attribute VB_Name = "mImport"

-    Option Explicit

-

-Const OFN_ALLOWMULTISELECT As Long = 512

-Const OFN_EXPLORER As Long = 524288

-Const OFN_HIDEREADONLY As Long = 4

-Const OFN_NONETWORKBUTTON As Long = 131072

-Const OFN_READONLY As Long = 1

-       

-Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _

-    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

-

-Private Type OPENFILENAME

-    lStructSize As Long

-    hWndOwner As Long

-    hInstance As Long

-    lpstrFilter As String

-    lpstrCustomFilter As String

-    nMaxCustFilter As Long

-    nFilterIndex As Long

-    lpstrFile As String

-    nMaxFile As Long

-    lpstrFileTitle As String

-    nMaxFileTitle As Long

-    lpstrInitialDir As String

-    lpstrTitle As String

-    flags As Long

-    nFileOffset As Integer

-    nFileExtension As Integer

-    lpstrDefExt As String

-    lCustData As Long

-    lpfnHook As Long

-    lpTemplateName As String

-End Type

-

-Function GetImportDirectory(DB_dir As String, flist() As String) As Boolean

-    Dim OpenFile As OPENFILENAME

-    Dim lReturn As Long

-    Dim sFilter As String

-    

-    OpenFile.lStructSize = Len(OpenFile)

-    '         OpenFile.hwndOwner = Form1.hWnd

-    '         OpenFile.hInstance = App.hInstance

-    sFilter = "Clexane Data Files" & Chr(0) & PROGRAM_IMPORTNAME & PROGRAM_DATAEXT & Chr(0)

-    OpenFile.lpstrFilter = sFilter

-    OpenFile.nFilterIndex = 1

-    OpenFile.lpstrFile = String(257, 0)

-    OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1

-    OpenFile.lpstrFileTitle = OpenFile.lpstrFile

-    OpenFile.nMaxFileTitle = OpenFile.nMaxFile

-    OpenFile.lpstrInitialDir = DB_dir

-    OpenFile.lpstrTitle = "Импорт данных"

-    OpenFile.flags = OFN_HIDEREADONLY + OFN_ALLOWMULTISELECT + OFN_EXPLORER

-    lReturn = GetOpenFileName(OpenFile)

-    If lReturn = 0 Then

-        GetImportDirectory = False

-    Else

-        GetImportDirectory = True

- 

-        flist = Split(OpenFile.lpstrFile, Chr(0), Compare:=vbBinaryCompare)

-        Dim i As Integer

-        i = 0

-        Do While flist(i) <> ""

-            i = i + 1

-        Loop

-        If i = 1 Then

-            flist(1) = flist(0)

-            flist(0) = GetWBPath(flist(1))

-            flist(1) = GetWBName(flist(1))

-        Else

-            flist(0) = flist(0) & "\"

-        End If

-    End If

-End Function

-<<<<<<
-======================
-mImport2
->>>>>>
-Attribute VB_Name = "mImport2"

-Option Explicit

-

-Sub FOpen()

-    Dim flist As String

-    Dim fileToOpen, s

-    flist = ""

-    fileToOpen = Application _

-        .GetOpenFileName("Data Files (*.mdb), mr*.mdb", title:="Импорт данных", MultiSelect:=True)

-    If fileToOpen <> False Then

-        For Each s In fileToOpen

-            flist = flist & s & "; "

-        Next s

-        MsgBox "Open " & flist

-    End If

-End Sub

-

-Sub t2()

-    Dim d As dlgImprtDB

-    Set d = New dlgImprtDB

-    d.Show

-End Sub

-

-<<<<<<
-======================
-dlgImprtDB
->>>>>>
-Attribute VB_Name = "dlgImprtDB"

-Attribute VB_Base = "0{F682E458-9834-4879-8411-9164089DF582}{EDF8D6E7-B9DC-4122-B717-981CD221F3E8}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Private Sub btSelAll_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = True

-    Next i

-End Sub

-

-Private Sub btUnselect_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = False

-    Next i

-End Sub

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    

-    Application.EnableEvents = True

-    Set MyAppEvents.app = Application

-    

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    

-    set_work_mode

-    

-    CheckUser

-    

-    MyAppEvents.CheckWorkBooksArround ThisWorkbook

-    

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-    Application.ScreenUpdating = True

-

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-    Application.Calculate

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    

-    Application.Caption = Empty

-    Application.CommandBars("Worksheet Menu Bar").Reset

-    

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-    

-    With ThisWorkbook

-        .Application.DisplayAlerts = False

-        xlRestoreView

-        .Save

-    End With

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-    Dim MaxX, MaxY As Integer

-    With ThisWorkbook.Worksheets(REP_QTR_SHEET)

-        .Select

-        MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-        MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-    End With

-

-    With ThisWorkbook.Application

-        .ScreenUpdating = False

-        .WindowState = xlNormal

-        .Height = MaxY

-        .Width = MaxX

-    End With

-End Sub

-

-

-

-

-

-<<<<<<
-======================
-REP_QTR
->>>>>>
-Attribute VB_Name = "REP_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CQTR_QT As Integer = 0

-Const CQTR_ID As Integer = 1

-Const CQTR_PLN As Integer = 2

-Const CQTR_FCT As Integer = 3

-Const CQTR_BDG As Integer = 4

-Const CQTR_CNT As Integer = 5

-Const CQTR_BEDS As Integer = 6

-Const CQTR_HIR As Integer = 7

-Const CQTR_TER As Integer = 8

-Const CQTR_CRD As Integer = 9

-Const CQTR_CLXN_BDG As Integer = 10

-Const CQTR_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub update_history()

-    Dim objQTR() As tQTR

-    Dim i As Long

-    Dim r As Range

-    Dim cRep As tREP

-    

-    cRep = GetREPRecord

-    Range("D4") = cRep.LastName

-    Range("D5") = cRep.FirstName

-    

-    Range("H4") = GetRegionName(cRep.Region)

-    Range("H5") = GetCityName(cRep.Region, cRep.City)

-    

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    i = GetAll_QTR_Records(objQTR, "%")

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CQTR_QT) = objQTR(i).entry_date

-        Next i

-    End If

-    Dim qcd() As tQTR_COMMON

-    i = Get_QTR_CommonList(qcd)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(qcd)

-            r.Offset(i - 1, CQTR_QT) = qcd(i).qtr.entry_date

-            r.Offset(i - 1, CQTR_ID) = qcd(i).qtr.id

-            r.Offset(i - 1, CQTR_PLN) = qcd(i).qtr.sale_plan

-            r.Offset(i - 1, CQTR_FCT) = qcd(i).c_sale_ALL

-            r.Offset(i - 1, CQTR_BDG) = qcd(i).c_bdgt_LPU

-            r.Offset(i - 1, CQTR_CNT) = qcd(i).i_lcd

-            r.Offset(i - 1, CQTR_BEDS) = qcd(i).c_beds

-            r.Offset(i - 1, CQTR_HIR) = qcd(i).c_pat_HIR

-            r.Offset(i - 1, CQTR_TER) = qcd(i).c_pat_TER

-            r.Offset(i - 1, CQTR_CRD) = qcd(i).c_pat_CRD

-            If qcd(i).c_bdgt_LPU <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_BDG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_LPU

-            End If

-            If qcd(i).c_bdgt_NMG <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_NMG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CQTR_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRepQtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.Count > 1 And r_sel.Columns.Count < CRow_Width Or r_sel.Rows.Count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.Count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.Count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.Count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CQTR_ID + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    i = currRange.Column - Range(CINP_AREA).Column

-    

-    QTR_ID = r

-

-    If QTR_ID = 0 Then

-        Worksheets(VAR_SHEET).Range("USER_ACTION") = 1

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        If i > CQTR_FCT Then

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-            Range("LAST_FOCUS") = currRange.address

-        Else

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 3

-            Range("LAST_FOCUS") = currRange.address

-        End If

-    End If

-    Cancel = True

-    btHomeDo_IT

-End Sub

-

-<<<<<<
-======================
-mRep_QTR
->>>>>>
-Attribute VB_Name = "mRep_QTR"

-Option Explicit

-

-Sub DO_New_qtr()

-    Dim res As Variant

-    Dim objQTR As tQTR

-    Dim s As String

-    s = GetLastQtr

-    objQTR.entry_date = GetNextQTR(s)

-    

-    If objQTR.entry_date = "" Then

-        Exit Sub

-    End If

-    

-    DO_Price_qtr objQTR.entry_date

-

-End Sub

-

-Sub DO_Price_qtr(ent_date As String)

-    Dim qtr As tQTR

-    Dim res As Integer

-    

-    qtr = Get_QTR_Record(ent_date)

-    

-    If qtr.id = 0 Then

-        qtr.entry_date = ent_date

-

-        With Worksheets(VAR_SHEET)

-            qtr.ClxnH20mg = .Range("ClxnH20mg")

-            qtr.ClxnH40mg = .Range("ClxnH40mg")

-            qtr.ClxnT40mg = .Range("ClxnT40mg")

-            qtr.ClxnC_ACS = .Range("ClxnC_ACS")

-            qtr.ClxnC_IM = .Range("ClxnC_IM")

-        End With

-    End If

-    

-    Dim dlg_nq As dlg_nextQTR

-    Set dlg_nq = New dlg_nextQTR

-    

-    With dlg_nq

-        .tb_qtr_name = qtr.entry_date

-        .tb_bdgt_avts = qtr.sale_plan

-        .tb_qtr_name = qtr.entry_date

-        .tb_ClxnH20mg = qtr.ClxnH20mg

-        .tb_ClxnH40mg = qtr.ClxnH40mg

-        .tb_ClxnT40mg = qtr.ClxnT40mg

-        .tb_ClxnC_ACS = qtr.ClxnC_ACS

-        .tb_ClxnC_IM = qtr.ClxnC_IM

-    End With

-    

-    dlg_nq.Show

-    res = dlg_nq.Tag

-    

-    If res = vbOK Then

-        With dlg_nq

-            If Not IsNumeric(.tb_bdgt_avts) Then

-                MsgBox "Введите план продаж", vbOK, PROGRAM_NAME

-            Else

-                If .tb_bdgt_avts = 0 Then

-                    MsgBox "Введите план продаж", vbOK, PROGRAM_NAME

-                    Exit Sub

-                End If

-            End If

-            Dim bool As Boolean

-            bool = IsNumeric(.tb_ClxnH20mg) _

-                And IsNumeric(.tb_ClxnH40mg) _

-                And IsNumeric(.tb_ClxnT40mg) _

-                And IsNumeric(.tb_ClxnC_ACS) _

-                And IsNumeric(.tb_ClxnC_IM)

-            If Not bool Then

-                MsgBox "Вводите правильно цыфры", vbOK, PROGRAM_NAME

-                Exit Sub

-            End If

-            qtr.sale_plan = .tb_bdgt_avts

-            qtr.entry_date = .tb_qtr_name

-            qtr.ClxnH20mg = .tb_ClxnH20mg

-            qtr.ClxnH40mg = .tb_ClxnH40mg

-            qtr.ClxnT40mg = .tb_ClxnT40mg

-            qtr.ClxnC_ACS = .tb_ClxnC_ACS

-            qtr.ClxnC_IM = .tb_ClxnC_IM

-        End With

-        Insert_QTR_Record qtr

-    End If

-End Sub

-

-Sub DO_Edit_qtr(ent_date As String)

-    If ent_date = "" Then

-        DO_New_qtr

-    Else

-        With ThisWorkbook.Worksheets("LPU_LIST")

-            .Range("VIEW_ONLY") = False

-            .Range("ent_date") = ent_date

-            .Select

-        End With

-    End If

-End Sub

-

-Sub DO_Delete_qtr(ent_date As String)

-    If ent_date <> "" Then

-        Dim i As Integer

-        i = MsgBox("Удалить данные за период [" & ent_date & "]?", vbDefaultButton2 + vbOKCancel, PROGRAM_NAME)

-        If i = vbOK Then

-            Dim objQTR As tQTR

-            If ent_date <> "" Then

-                objQTR.entry_date = ent_date

-                objQTR = Get_QTR_Record(ent_date)

-                Delete_QTR_Record objQTR

-                Worksheets(TITLE_SHEET).Select

-                Worksheets(REP_QTR_SHEET).Select

-            End If

-        End If

-    End If

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-

-Sub btHomeDo_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    idx = Worksheets(VAR_SHEET).Range("USER_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            DO_New_qtr

-            ' Обновляем экран

-        Case 2

-            DO_Edit_qtr ent_date

-        Case 3

-            DO_Price_qtr ent_date

-        Case 4

-            dbExport

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    End Select

-    If idx <> 2 Then

-        With ThisWorkbook

-            .Worksheets(TITLE_SHEET).Select

-            .Worksheets(REP_QTR_SHEET).Select

-        End With

-    End If

-End Sub

-

-Sub Delete_qtr()

-    Dim ent_date As String

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    DO_Delete_qtr ent_date

-End Sub

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma"

-Public Const PROGRAM_VERSION As String = "Clexane[MR] ver 1.3"

-Public Const PROGRAM_FILENAME As String = "clexane-mr"

-Public Const PROGRAM_EXPORTNAME As String = "mr-export-"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-

-

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20030329

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "O40"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-

-End Sub

-

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.Count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.name = VAR_SHEET Or sh.name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-<<<<<<
-======================
-Var
->>>>>>
-Attribute VB_Name = "Var"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-title
->>>>>>
-Attribute VB_Name = "title"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LPU_LIST
->>>>>>
-Attribute VB_Name = "LPU_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentLPU_ID() As Long

-    Dim r As Range

-    

-    With Worksheets("LPU_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CLPU_ID)

-    End With

-    

-    getCurrentLPU_ID = r

-End Function

-

-Public Sub LPU_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectLPU_NAME(lpu_id As Long, ent_date As String)

-    If Range("VIEW_ONLY") = True Then

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    Dim cLPU As tLPU

-    If lpu_id = 0 Then

-        cLPU.id = 0

-        cLPU.rep_id = 0

-        cLPU.address = ""

-        cLPU.name = ""

-    Else

-        cLPU = Get_LPU_Record(lpu_id)

-    End If

-    EditLPU cLPU, getEnt_date

-    Worksheet_Activate

-End Sub

-        

-Sub SelectLPU_BDGT(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    If lpu_id = 0 Then

-        SelectLPU_NAME lpu_id, ent_date

-    Else

-        With ThisWorkbook.Worksheets("LPU_BDGT")

-            .Range("VIEW_ONLY") = vo

-            .Range("ret_addr") = "LPU_LIST"

-            .Range("ent_date") = ent_date

-            .Range("lpu_id") = lpu_id

-        End With

-    End If

-End Sub

-

-Sub SelectLPU_HIR(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_CLSN_HIR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-                   

-Sub SelectLPU_TER(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_CLSN_TER")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-       

-Sub SelectLPU_C_ACS(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_CLSN_C_ACS")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    

-    Range("LAST_FOCUS") = CINP_AREA

-    

-    UpdateLPUList

-    

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.Count > 1 And r_sel.Columns.Count < CINP_WIDTH Or r_sel.Rows.Count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.Count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.Count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.Count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim lpu_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-    

-    ent_date = getEnt_date

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-    

-    Set r = Range(CINP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CINP_AREA).row, CLPU_ID)

-        

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-    

-    lpu_id = r

-    

-    i = Range(Range("LAST_FOCUS")).Column - Range(CINP_AREA).Column

-    

-    If lpu_id = 0 Then

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    End If

-    

-    If lpu_id = 0 Then

-        i = CLPU_NAME

-        Range("JUMP") = ""

-    End If

-    Select Case i

-        Case CLPU_NAME, CLPU_NAME1, CLPU_NAME2, CLPU_BEDS

-            SelectLPU_NAME lpu_id, ent_date

-            Range("JUMP") = ""

-

-        Case CLPU_NMG, CLPU_NFG, CLPU_PLAN, CLPU_FACT

-            SelectLPU_BDGT lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-            

-        Case CLPU_HIR

-            SelectLPU_HIR lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_HIR"

-        

-        Case CLPU_TER

-            SelectLPU_TER lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_TER"

-        

-        Case CLPU_CAR

-            SelectLPU_C_ACS lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_C_ACS"

-        

-        Case Else

-            Range("JUMP") = ""

-    End Select

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-    

-    is_input_range = INPUT_NO

-    

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateLPUList()

-    Dim lcd() As tLPU_COMMON

-    

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-    Dim objQTR As tQTR

-    Dim cRep As tREP

-    

-    ' ent_date = "%" ' % - all records

-    ent_date = getEnt_date

-    

-    objQTR = Get_QTR_Record(ent_date)

-    i = Get_LPU_CommonQTR(lcd, objQTR)

-     

-    ' стираем ФИО

-    Range("C3:C4").ClearContents

-    cRep = GetREPRecord

-    

-    Range("C3") = cRep.LastName

-    Range("C4") = cRep.FirstName

-    Range("G3") = GetRegionName(cRep.Region)

-    Range("G4") = GetCityName(cRep.Region, cRep.City)

-    Range("G5") = objQTR.sale_plan

-    

-

-    

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-        

-        For i = 1 To UBound(lcd)

-            r.Offset(i - 1, CLPU_NAME) = lcd(i).lpu.name

-            r.Offset(i - 1, CLPU_ID) = lcd(i).lpu.id

-            r.Offset(i - 1, CLPU_BEDS) = lcd(i).lpu.beds

-            

-         

-            r.Offset(i - 1, CLPU_NFG) = lcd(i).bdgt.bdgt_NFG

-            r.Offset(i - 1, CLPU_NMG) = lcd(i).bdgt.bdgt_NMG

-            r.Offset(i - 1, CLPU_PLAN) = lcd(i).bdgt.sale_plan

-            

-            r.Offset(i - 1, CLPU_HIR) = lcd(i).pat_HIR

-            r.Offset(i - 1, CLPU_TER) = lcd(i).pat_TER

-            r.Offset(i - 1, CLPU_CAR) = lcd(i).pat_CRD

-            r.Offset(i - 1, CLPU_FACT) = lcd(i).sale_ALL

-            r.Offset(i - 1, CLPU_PAT_LPU) = lcd(i).pat_LPU

-            r.Offset(i - 1, CLPU_BDGT) = lcd(i).bdgt_LPU

-            If lcd(i).bdgt_LPU > 0 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = lcd(i).sale_ALL / lcd(i).bdgt_LPU

-            End If

-            If r.Offset(i - 1, CLPU_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = 1

-            End If

-            

-        Next i

-    End If

-End Sub

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{80F5BB2F-5609-4CB2-84B1-E80CE1E8A90C}{3D34390E-B837-4471-AFE0-B5C8399582D8}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-dbACS
->>>>>>
-Attribute VB_Name = "dbACS"

-Option Explicit

-

-Public Type tACS

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    patients_with_geparins As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objACS.ID <> 0 then updatre else insert

-Sub Insert_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objACS.id <> 0 Then

-        dbUpdate_ACS_Record dbConnection, objACS

-    Else

-        dbInsert_ACS_Record dbConnection, objACS

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_ACS_RecordsByLPU_ID(ByRef all_ACS_() As tACS, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_ACS_RecordsByLPU_ID = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, all_ACS_, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_ACS_Record dbConnection, objACS

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub dbInsert_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_acs", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objACS

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("patients_with_geparins") = .patients_with_geparins

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objACS.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim Update_SQL As String

-    

-    With objACS

-        Update_SQL = "UPDATE lpu_acs SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "patients_with_geparins=" & .patients_with_geparins & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_ACS_RecordsbyLPU_ID(dbConnection As Object, all_ACS() As tACS, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_ACS_SQL As String

-    Dim getAll_ACS_SQL As String

-    Dim ACS_Count As Long

-    ACS_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_ACS_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        ACS_Count = dbRecordset("ACS_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_ACS_RecordsbyLPU_ID = ACS_Count

-    

-    If ACS_Count > 0 Then

-        'we have records

-        ReDim all_ACS(1 To ACS_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_ACS_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_ACS As tACS

-                 With tmp_ACS

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .patients_with_geparins = dbRecordset("patients_with_geparins")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 all_ACS(index) = tmp_ACS

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE ID=" & objACS.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_ACS_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_HIR
->>>>>>
-Attribute VB_Name = "LPU_CLSN_HIR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-    

-        Dim objHir As tHIRURGIA

-        

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objHir

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .operations_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L9")

-                .patients_ambulator_clexan_20mg = Range("L10")

-                .patients_ambulator_clexan_40mg = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L19")

-                .patients_stationar_clexan_20mg = Range("L20")

-                .patients_stationar_clexan_40mg = Range("L21")

-            End With

-            Insert_Hir_Record objHir

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objHir.id = Range("rec_id")

-                    If objHir.id <> 0 Then

-                        Delete_Hir_Record objHir

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objHir As tHIRURGIA)

-    Dim qtr As tQTR

-    Dim formula As String

-

-    With objHir

-        Range("rec_id") = .id

-        Range("F6") = .operations_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L9") = .patients_ambulator_clexan

-        Range("L10") = .patients_ambulator_clexan_20mg

-        Range("I21") = .patients_stationar_nmg

-        Range("L19") = .patients_stationar_clexan

-        Range("L20") = .patients_stationar_clexan_20mg

-        

-        qtr = Get_QTR_Record(.entry_date)

-        formula = "=" & qtr.ClxnH20mg & "*($L$10+$L$20)+" & qtr.ClxnH40mg & "*($L$11+$L$21)"

-        Range("F11").formula = formula

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    

-    Range("h_DepFlag") = False

-    

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objHir() As tHIRURGIA

-        Dim i As Integer

-        i = GetAll_Hir_RecordsByLPU_ID(objHir, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.3

-        Else

-            SetupData objHir(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-mSapes
->>>>>>
-Attribute VB_Name = "mSapes"

-Option Explicit

-

-Const SHAPE_COLOR As Integer = 1

-Const SHAPE_NAME As Integer = 2

-

-

-Sub ShapeView(r_sh_finite_state As Range)

-    Dim chk As Range

-    Dim s As String

-    Dim c, idx As Integer

-    For Each chk In r_sh_finite_state

-        idx = 0

-        If chk = "+" Then

-            c = chk.Offset(0, idx + SHAPE_COLOR)

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While c <> 0

-                ShapeFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s)), c

-                idx = idx + 2

-                c = chk.Offset(0, idx + SHAPE_COLOR)

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        Else

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While s <> ""

-                ShapeUnFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s))

-                idx = idx + 2

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        End If

-    Next chk

-End Sub

-

-Sub ShapeFill(sh As ShapeRange, ByVal color As Integer)

-    sh.Fill.Visible = msoTrue

-    sh.Fill.Solid

-    sh.Fill.ForeColor.SchemeColor = color

-    sh.Fill.Transparency = 0#

-End Sub

-

-Sub ShapeUnFill(sh As ShapeRange)

-    sh.Fill.Visible = msoFalse

-    sh.Fill.Transparency = 0#

-End Sub

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Public Const INPUT_NO = 0

-Public Const INPUT_NUMBER = 1

-Public Const INPUT_PERCENT = 2

-Public Const INPUT_STRING = 3

-Public Const INPUT_CHECK = 4

-

-Public Const INP_IDX_TYPE = 1

-Public Const INP_IDX_NEXT = 2

-Public Const INP_IDX_MIN = 3

-Public Const INP_IDX_MAX = 4

-Public Const INP_IDX_DEP = 5

-Public Const INP_IDX_ALT = 7

-

-

-Public Type tInputSet

-    vType As Integer

-    vMin As Long

-    vMax As Long

-    rChk As String

-End Type

-

-Function is_input_cell(ByVal Target As Range, inputs As Range) As tInputSet

-    Dim t As Range

-    Dim iset As tInputSet

-    Dim test As Range

-    iset.vType = INPUT_NO

-    iset.vMin = 0

-    iset.vMax = 0

-    iset.rChk = ""

-    is_input_cell = iset

-

-' Закоментировать следующую сточку для работы

-'  Exit Function

-

-    Set test = Target.Cells(1, 1)

-    For Each t In inputs

-        If Range(t).Column = test.Column And Range(t).row = test.row Then

-            iset.vType = t.Offset(0, INP_IDX_TYPE).Value

-            Select Case iset.vType

-                Case INPUT_CHECK

-                    iset.rChk = t.Offset(0, INP_IDX_ALT)

-                Case INPUT_NUMBER, INPUT_PERCENT

-                    iset.vMin = t.Offset(0, INP_IDX_MIN).Value

-                    iset.vMax = t.Offset(0, INP_IDX_MAX).Value

-            End Select

-            is_input_cell = iset

-            Exit Function

-        End If

-    Next t

-End Function

-

-Function GetFocusAddress(ByVal r As Range, f_next As Range) As String

-    Dim chk, t As Range

-    

-    For Each chk In f_next

-        For Each t In r

-            If t.address = chk Then

-                GetFocusAddress = chk

-                Exit Function

-            End If

-            If Range(chk).Column = t.Column - 1 And Range(chk).row = t.row _

-            Or Range(chk).Column = t.Column And Range(chk).row = t.row - 1 _

-            Then

-                If Range(chk) <> "" Then

-                    If Range(chk) = 0 Then

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_ALT)).address

-                    Else

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_NEXT)).address

-                    End If

-                Else

-                    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-                End If

-                Exit Function

-            End If

-        Next t

-    Next chk

-    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-End Function

-

-Sub SetDependet(r As Range, inputs As Range)

-    Dim chk As Range

-    Dim s, serr As String

-    Dim idx As Integer

-    Dim iset As tInputSet

-    Dim err_found As Boolean

-    

-    If r.Count > 1 Then

-        Exit Sub

-    End If

-    

-    err_found = False

-    For Each chk In inputs

-        idx = INP_IDX_DEP

-        

-        

-        iset.vType = chk.Offset(0, INP_IDX_TYPE).Value

-        Select Case iset.vType

-            Case INPUT_NUMBER, INPUT_PERCENT

-                iset.vMin = chk.Offset(0, INP_IDX_MIN).Value

-                iset.vMax = chk.Offset(0, INP_IDX_MAX).Value

-                

-                If Range(chk) > iset.vMax Then

-                    err_found = True

-                    Range(chk) = iset.vMax

-                    serr = "Выход за дозволенный диапазон [" & iset.vMin & ".." & iset.vMax & "]! Данные скорректированы."

-                End If

-                

-                If Range(chk) = "" Then

-                    s = chk.Offset(0, idx)

-                    Do While s <> ""

-                        Range(s) = ""

-                        idx = idx + 1

-                        s = chk.Offset(0, idx)

-                    Loop

-                End If

-        End Select

-    Next chk

-    If err_found Then

-        MsgBox serr, vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Function CheckInputData(inputs As Range) As Boolean

-    Dim r As Range

-    

-    CheckInputData = True

-    For Each r In inputs

-        If Range(r) = "" Then

-            CheckInputData = False

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100.", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Sub Check_Int_Number(Target As Range, Def_Val As Long)

-    Dim err As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    err = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                err = True

-            End If

-        End If

-    Next r

-    If err Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_TER
->>>>>>
-Attribute VB_Name = "LPU_CLSN_TER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim objTer As tTERAPIA

-        

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objTer

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .patients_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L20")

-            End With

-            Insert_Ter_Record objTer

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objTer.id = Range("rec_id")

-                    If objTer.id <> 0 Then

-                        Delete_Ter_Record objTer

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objTer As tTERAPIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    With objTer

-        Range("rec_id") = .id

-        Range("F6") = .patients_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L11") = .patients_ambulator_clexan

-        Range("I21") = .patients_stationar_nmg

-        Range("L20") = .patients_stationar_clexan

-        

-        qtr = Get_QTR_Record(.entry_date)

-        formula = "=" & qtr.ClxnT40mg & "*($L$12+$L$20)"

-        Range("F11").formula = formula

-        

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    

-    Range("h_DepFlag") = False

-    

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objTer() As tTERAPIA

-        Dim i As Integer

-        i = GetAll_Ter_RecordsByLPU_ID(objTer, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.25

-        Else

-            SetupData objTer(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-    

-    Dim s As String

-    Dim iset As tInputSet

-    

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    

-    Select Case iset.vType

-        Case INPUT_NO

-        

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-            

-            Application.ScreenUpdating = False

-            

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-            

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-        

-        Case INPUT_STRING

-        

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{B6A605B8-0DA5-4237-9732-C6EF328660B9}{B79DCFAC-9872-4E14-9F9A-4DD3E710171A}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-LPU_BDGT
->>>>>>
-Attribute VB_Name = "LPU_BDGT"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub SetDefFocus()

-    Range(Range("DEF_FOCUS")).Select

-End Sub

-

-Public Sub ClearData()

-    ClearSheetData

-End Sub

-

-Sub ClearSheetData()

-    If Range("F10") = 0 And Range("F13") = 0 Then

-        Range("F11:F18") = ""

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("F11:F13") = ""

-    End If

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim bdgt As tBUDGET

-        Dim test As Long

-        With bdgt

-            .lpu_id = Range("lpu_id")

-            .id = Range("rec_id")

-            .entry_date = Range("ent_date")

-            .bdgt_NMG = Round(Range("F11").Value, 0)

-            .bdgt_NFG = Round(Range("F12").Value, 0)

-            .sale_plan = Round(Range("F13").Value, 0)

-            

-            test = .bdgt_NFG + .bdgt_NMG - .sale_plan

-        End With

-        If test <> 0 Then

-            If test < 0 Then

-                If vbYes = MsgBox("Ваш план превышает выделенный на гепарины бюджет. Сохранить данные?", _

-                        vbYesNo, PROGRAM_NAME) Then

-                    test = 1

-                End If

-            End If

-            If test > 0 Then

-                Insert_BDGT_Record bdgt

-            End If

-        Else

-            If bdgt.id <> 0 Then

-                If vbYes = MsgBox("Удалить данные из базы!", vbYesNo, PROGRAM_NAME) Then

-                    Insert_BDGT_Record bdgt

-                End If

-                ret_back Range("DEF_FOCUS").Worksheet

-                Exit Sub

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-    End If

-    

-   ClearData

-   ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(cLPU As tLPU_COMMON)

-    Dim t_sum As Long

-    t_sum = 0

-' Setup budget data

-    Range("F11") = cLPU.bdgt.bdgt_NMG

-    Range("F12") = cLPU.bdgt.bdgt_NFG

-    Range("F13") = cLPU.bdgt.sale_plan

-    

-    With cLPU

-        Range("F14") = .pat_ALL

-        Range("F15") = .pat_HIR

-        Range("F16") = .pat_TER

-        Range("F17") = .pat_CRD

-        Range("F18") = .sale_ALL

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    ws_activate

-End Sub

-

-

-Sub ws_activate()

-    Dim cLPU As tLPU_COMMON

-    Dim objQTR As tQTR

-    Dim objLPU As tLPU

-    Dim ent_date As String

-    Dim id As Long

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    id = Range("lpu_id").Value

-    ent_date = Range("ent_date")

-    objQTR = Get_QTR_Record(ent_date)

-    objLPU = Get_LPU_Record(id)

-    Get_LPU_Common cLPU, objLPU, objQTR

-    

-    If cLPU.lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = cLPU.lpu.beds

-        Range("lpu_name") = cLPU.lpu.name

-        Range("lpu_addr") = cLPU.lpu.address

-        Range("rec_id") = cLPU.bdgt.id

-        

-        SetupData cLPU

-        

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-'    MsgBox Target.address

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Dim s As String

-    Dim iset As tInputSet

-    

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    

-    Select Case iset.vType

-        Case INPUT_NO

-        

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-            

-        Case INPUT_PERCENT

-        

-        Case INPUT_STRING

-        

-        Case INPUT_CHECK

-            

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{9A49AB78-5384-4123-B3D4-70ECF403CCE3}{88B43E2F-B316-403D-AD13-A598E9B13611}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mSheets
->>>>>>
-Attribute VB_Name = "mSheets"

-Option Explicit

-

-Function am_load_now() As Boolean

-    am_load_now = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE")

-End Function

-

-Sub Wks_select(RetSheet As String)

-    Dim sheet As Worksheet

-    For Each sheet In ThisWorkbook.Worksheets

-        If sheet.name = RetSheet Then

-            ThisWorkbook.Worksheets(RetSheet).Select

-            Exit Sub

-        End If

-    Next sheet

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub ret_back(sh As Worksheet)

-    Dim RetSheet As String

-    RetSheet = sh.Range("ret_addr")

-    sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    sh.Range("ret_addr") = ""

-    sh.Range("rec_id") = ""

-    sh.Range("lpu_id") = ""

-    sh.Range("ent_date") = ""

-    sh.Range("lpu_name") = ""

-    sh.Range("lpu_addr") = ""

-    sh.Range("lpu_beds") = ""

-    Wks_select RetSheet

-End Sub

-

-Sub ClearSheetData(r_start As Range)

-    If r_start <> "" Then

-        r_start.Worksheet.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        r_start = ""

-    Else

-        ret_back r_start.Worksheet

-    End If

-End Sub

-

-Sub wks_sel_chng(iset As tInputSet, ByVal Target As Range, sh As Worksheet)

-    Dim DebugMode As Boolean

-    Dim in_range As Range

-    

-    DebugMode = Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-

-    If DebugMode Then

-        sh.Unprotect

-    Else

-        sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    End If

-

-    If iset.vType = INPUT_CHECK Then

-        Set in_range = Target.Worksheet.Range(iset.rChk)

-    Else

-        Set in_range = Target

-    End If

-    

-    Dim str As String

-    str = GetFocusAddress(in_range, sh.Range("h_inputs"))

-

-'    MsgBox Target.Address & "; " & str

-    If str <> Target.address Then

-        sh.Range(str).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-Dlg_lpu_card
->>>>>>
-Attribute VB_Name = "Dlg_lpu_card"

-Attribute VB_Base = "0{D31C532A-2C7C-4596-A9A8-E0070AA2354F}{9955E423-13F2-430C-B27E-744B8EB93350}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbLPU_List_Change()

-    Dim src As Range

-    Dim idx_src As Integer

-    

-    Set src = Worksheets(VAR_SHEET).Range(Me.cbLPU_List.RowSource)

-    idx_src = Me.cbLPU_List.ListIndex + 1

-    Me.tb_lpu_name.Text = src.Cells(idx_src, 1)

-    Me.tb_lpu_address.Text = src.Cells(idx_src, 2)

-    Me.tbBedsCount.Text = src.Cells(idx_src, 3)

-End Sub

-

-

-Private Sub cbxLPU_List_Enable_Click()

-    

-    If Me.cbxLPU_List_Enable Then

-        

-        Me.tb_lpu_name.Text = ""

-        Me.tb_lpu_name.Enabled = False

-        

-        Me.tb_lpu_address.Text = ""

-        Me.tb_lpu_address.Enabled = False

-        

-        Me.tbBedsCount.Text = ""

-        Me.tbBedsCount.Enabled = False

-        

-        Me.cbLPU_List.Enabled = True

-        cbLPU_List_Change

-    Else

-        Me.tb_lpu_name.Enabled = True

-        Me.tb_lpu_name.Text = ""

-        

-        Me.tb_lpu_address.Enabled = True

-        Me.tb_lpu_address.Text = ""

-        

-        Me.tbBedsCount.Enabled = True

-        Me.tbBedsCount.Text = ""

-        

-        Me.cbLPU_List.Enabled = False

-    End If

-End Sub

-

-<<<<<<
-======================
-UserInfo
->>>>>>
-Attribute VB_Name = "UserInfo"

-Attribute VB_Base = "0{475C43B4-C5EF-409D-A491-EE3F7DA14735}{29835B05-A665-4A6A-BDFA-6750CAA14FF0}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Tag = vbOK

-End Sub

-

-Private Sub cbCity_Change()

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_CITY") = Me.cbCity.ListIndex

-        .Calculate

-    End With

-End Sub

-

-Private Sub cbRegion_Change()

-    Dim LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        NewRangeOffsetCol = cbRegion.Value * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).address

-        NewSumRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).address

-        .Calculate

-        .Range("IDX_CITY") = 0

-        cbCity.RowSource = NewCbxRange

-

-    End With

-    cbCity.ListIndex = 0

-End Sub

-

-<<<<<<
-======================
-mREP
->>>>>>
-Attribute VB_Name = "mREP"

-Option Explicit

-

-Sub hwnew()

-    Dim rs As Range

-    Dim re As Object

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    HWReset

-    With Application

-        .DisplayAlerts = False

-        .Quit

-    End With

-End Sub

-

-Sub CheckUser()

-    If Range("HW_Number") = "" Then

-        StoreHWInfo

-    End If

-    If CheckHWInfo <> True Then

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    Else

-        SetupUser

-    End If

-End Sub

-

-

-Sub SetupUser()

-    Dim cUser As tREP

-    Dim idx As Integer

-    Dim dlg_ui As UserInfo

-    

-    Set dlg_ui = New UserInfo

-    

-    cUser = GetREPRecord()

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_REGION") = cUser.Region

-        .Range("IDX_CITY") = cUser.City

-    End With

-        

-    With dlg_ui

-        .cbRegion = cUser.Region

-        .cbCity = cUser.City

-        .tbFName = cUser.FirstName

-        .tbLName = cUser.LastName

-    End With

-    

-    dlg_ui.Show

-    Worksheets(REGS_SHEET).Calculate

-    

-    If dlg_ui.Tag = vbOK Then

-        With cUser

-            .Region = dlg_ui.cbRegion.Value

-            .City = dlg_ui.cbCity.Value

-            .FirstName = dlg_ui.tbFName.Value

-            .LastName = dlg_ui.tbLName.Value

-        End With

-        SetREPRecord cUser

-    Else

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-Sub StoreHWInfo()

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim objHW() As Long

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    Set r = Range("HW_Number")

-    i = 1

-    For Each d In dc

-        If d.drivetype = 2 Then

-            r = d.SerialNumber

-            Set r = r.Offset(1, 0)

-            ReDim Preserve objHW(i)

-            objHW(i) = d.SerialNumber

-            i = i + 1

-        End If

-    Next

-    

-    UpdateHWRecords objHW

-End Sub

-

-Function CheckHWInfo()

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim objHW() As Long

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    

-    CheckHWInfo = False

-    

-    i = GetHWRecords(objHW)

-    If i = 0 And Range("HW_Number") <> 0 Then

-        Exit Function

-    End If

-    For Each d In dc

-        If d.drivetype = 2 Then

-            Set r = Range("HW_Number")

-            Do While r <> ""

-                If r = d.SerialNumber Then

-                    For i = 1 To UBound(objHW)

-                        If d.SerialNumber = objHW(i) Then

-                            CheckHWInfo = True

-                            Exit Function

-                        End If

-                    Next i

-                End If

-                Set r = r.Offset(1, 0)

-            Loop

-        End If

-    Next

-End Function

-<<<<<<
-======================
-dbBudget
->>>>>>
-Attribute VB_Name = "dbBudget"

-Option Explicit

-

-Public Type tBUDGET

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    bdgt_NMG As Long

-    bdgt_NFG As Long

-    sale_plan As Long

-End Type

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function GetAll_BDGT_RecordsByLPU_ID(ByRef allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_BDGT_RecordsByLPU_ID = dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection, allBDGT, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function Get_BDGT_Record(ByVal lpu_id As Long, ByVal ent_date As String) As tBUDGET

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    Get_BDGT_Record = dbGet_BDGT_Record(dbConnection, lpu_id, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objBDGT.ID <> 0 then updatre else insert

-Public Sub Insert_BDGT_Record(objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    If objBDGT.id <> 0 Then

-        dbUpdate_BDGT_Record dbConnection, objBDGT

-    Else

-        dbInsert_BDGT_Record dbConnection, objBDGT

-    End If

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Public Sub Delete_BDGT_Record(ByRef objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    dbDelete_BDGT_Record dbConnection, objBDGT

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_BDGT_Record(dbConnection As Object, ByVal lpu_id As Long, ent_date As String) As tBUDGET

-    

-    Dim SQL As String

-    Dim objBDGT As tBUDGET

-    

-    With objBDGT

-        .id = 0

-        .lpu_id = lpu_id

-        .entry_date = ent_date

-        .bdgt_NMG = 0

-        .bdgt_NFG = 0

-        .sale_plan = 0

-    End With

-        

-    

-    SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        With objBDGT

-            .entry_date = dbRecordset("entry_date")

-            .id = dbRecordset("id")

-            .lpu_id = dbRecordset("lpu_id")

-            .bdgt_NFG = dbRecordset("bdgt_NFG")

-            .bdgt_NMG = dbRecordset("bdgt_NMG")

-            .sale_plan = dbRecordset("sale_PLAN")

-        End With

-    End If

-    

-    dbGet_BDGT_Record = objBDGT

-End Function

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection As Object, allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_BDGT_SQL As String

-    Dim getAll_BDGT_SQL As String

-    Dim BDGT_Count As Long

-    BDGT_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_BDGT_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        BDGT_Count = dbRecordset("BDGT_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_BDGT_RecordsbyLPU_ID = BDGT_Count

-    

-    If BDGT_Count > 0 Then

-        'we have records

-        ReDim allBDGT(1 To BDGT_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_BDGT_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpBDGT As tBUDGET

-                 With tmpBDGT

-                    .entry_date = dbRecordset("entry_date")

-                    .id = dbRecordset("id")

-                    .lpu_id = dbRecordset("lpu_id")

-                    .bdgt_NFG = dbRecordset("bdgt_NFG")

-                    .bdgt_NMG = dbRecordset("bdgt_NMG")

-                    .sale_plan = dbRecordset("sale_PLAN")

-                 End With

-                 

-                 allBDGT(index) = tmpBDGT

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbInsert_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "lpu_budget", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    dbRecordset("entry_date") = objBDGT.entry_date

-    dbRecordset("lpu_id") = objBDGT.lpu_id

-    dbRecordset("bdgt_NMG") = objBDGT.bdgt_NMG

-    dbRecordset("bdgt_NFG") = objBDGT.bdgt_NFG

-    dbRecordset("sale_PLAN") = objBDGT.sale_plan

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objBDGT.id = dbRecordset("id")

-  

-End Sub

-

-Public Sub dbUpdate_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu_budget SET " & _

-    "entry_date='" & objBDGT.entry_date & "'," & _

-    "lpu_id=" & objBDGT.lpu_id & "," & _

-    "bdgt_NMG=" & objBDGT.bdgt_NMG & "," & _

-    "bdgt_NFG=" & objBDGT.bdgt_NFG & "," & _

-    "sale_PLAN=" & objBDGT.sale_plan & _

-    " WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-Public Sub dbDelete_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_BDGT_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbDatabase
->>>>>>
-Attribute VB_Name = "dbDatabase"

-Option Explicit

-

-

-Sub dbOpenConnection(dbConnection As Object)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, SQL As String)

-    dbConnection.Execute (SQL)

-End Sub

-

-<<<<<<
-======================
-dbLPU
->>>>>>
-Attribute VB_Name = "dbLPU"

-Option Explicit

-

-Public Type tLPU

-    id As Long

-    rep_id As Long

-    name As String

-    address As String

-    beds As Integer

-End Type

-

-Function Get_LPU_Record(ByVal lpu_id As Long) As tLPU

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_LPU_Record = dbGet_LPU_Record(dbConnection, lpu_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAllLPU(allLPU() As tLPU) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAllLPU = dbGetAllLPU(dbConnection, allLPU)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAllLPUbyQTR(allLPU() As tLPU, ent_date As String) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAllLPUbyQTR = dbGetAllLPUbyQTR(dbConnection, allLPU, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objLPU.id = 0 then insert else update

-Sub Insert_LPU_Record(ByRef objLPU As tLPU)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    If objLPU.id = 0 Then

-        dbInsert_LPU_Record dbConnection, objLPU

-    Else

-        dbUpdate_LPU_Record dbConnection, objLPU

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub Delete_LPU_Record(ByRef objLPU As tLPU)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDelete_LPU_Record dbConnection, objLPU

-    dbCloseConnection dbConnection

-End Sub

-

-Sub Delete_LPU_RecordQTR(ByRef objLPU As tLPU, ent_date As String)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Hir_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Ter_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_ACS_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    

-    dbCloseConnection dbConnection

-    

-End Sub

-

-Function dbGet_LPU_Record(dbConnection As Object, ByVal lpu_id As Long) As tLPU

-    

-    Dim SQL As String

-    Dim objLPU As tLPU

-    

-    objLPU.id = lpu_id

-    objLPU.name = ""

-    objLPU.address = ""

-    

-    SQL = "SELECT * FROM lpu WHERE id=" & lpu_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objLPU.name = dbRecordset("name")

-        objLPU.address = dbRecordset("address")

-        objLPU.rep_id = dbRecordset("rep_id")

-        objLPU.beds = dbRecordset("beds")

-    End If

-    

-    dbGet_LPU_Record = objLPU

-

-End Function

-

-Sub dbInsert_LPU_Record(dbConnection As Object, ByRef objLPU As tLPU)

-  

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu", dbConnection, 2, 2

-    dbRecordset.addnew

-    dbRecordset("name") = objLPU.name

-    dbRecordset("address") = objLPU.address

-    dbRecordset("rep_id") = objLPU.rep_id

-    dbRecordset("beds") = objLPU.beds

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objLPU.id = dbRecordset("id")

-  

-End Sub

-

-Sub dbUpdate_LPU_Record(dbConnection As Object, ByRef objLPU As tLPU)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu SET " & _

-    "name='" & objLPU.name & "'," & _

-    "address='" & objLPU.address & "'," & _

-    "beds=" & objLPU.beds & "," & _

-    "rep_id=" & objLPU.rep_id& & _

-    " WHERE id=" & objLPU.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-

-Function dbGetAllLPU(dbConnection As Object, allLPU() As tLPU) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu"

-    getAll_LPU_SQL = "SELECT * FROM lpu"

-

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAllLPU = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-Function dbGetAllLPUbyQTR(dbConnection As Object, allLPU() As tLPU, ent_date As String) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    Dim where As String

-    where = "WHERE lpu_budget.entry_date like '" & ent_date & "'"

-    

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu_budget " & where

-    

-    getAll_LPU_SQL = "SELECT lpu.id as id, lpu.rep_id as rep_id, lpu.name as name, lpu.address as address, lpu.beds AS beds " & _

-    "FROM lpu, lpu_budget " & where & " AND lpu.id=lpu_budget.lpu_id"

-    

-

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAllLPUbyQTR = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-Sub dbDelete_LPU_Record(dbConnection As Object, ByRef objLPU As tLPU)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu " & _

-    "WHERE id=" & objLPU.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByLPU_ID dbConnection, objLPU.id

-    dbDelete_Hir_RecordsByLPU_ID dbConnection, objLPU.id

-    dbDelete_Ter_RecordsByLPU_ID dbConnection, objLPU.id

-    dbDelete_ACS_RecordsByLPU_ID dbConnection, objLPU.id

-    

-End Sub

-

-Sub dbDelete_LPU_RecordQTR(dbConnection As Object, ByRef objLPU As tLPU, ent_date As String)

-    

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Hir_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Ter_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_ACS_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    

-End Sub

-

-<<<<<<
-======================
-dbREP
->>>>>>
-Attribute VB_Name = "dbREP"

-Option Explicit

-

-Public Type tREP

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function GetREPRecord() As tREP

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetREPRecord = dbGetREPRecord(dbConnection)

-    dbCloseConnection dbConnection

-End Function

-

-Sub SetREPRecord(cUser As tREP)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbSetREPRecord dbConnection, cUser

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGetREPRecord(dbConnection As Object) As tREP

-    

-    Dim SQL As String

-    Dim objREP As tREP

-    

-    objREP.FirstName = ""

-    objREP.LastName = ""

-    objREP.Region = 0

-    objREP.City = 0

-    SQL = "SELECT firstname, lastname, region, city FROM " & _

-          "rep"

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open SQL, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREP.FirstName = dbRecordset("firstname")

-        objREP.LastName = dbRecordset("lastname")

-        objREP.Region = dbRecordset("region")

-        objREP.City = dbRecordset("city")

-        

-    End If

-    

-    dbGetREPRecord = objREP

-        

-End Function

-

-Public Sub dbSetREPRecord(dbConnection As Object, ByRef objREP As tREP)

-  

-    Dim DeleteSQL As String

-    Dim InsertSQL As String

-    

-    DeleteSQL = "DELETE FROM rep"

-    InsertSQL = "INSERT INTO rep (firstname, lastname, region, city) VALUES (" & _

-    "'" & objREP.FirstName & "', " & _

-    "'" & objREP.LastName & "', " & _

-    objREP.Region & ", " & _

-    objREP.City & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    dbRecordset.Open InsertSQL, dbConnection

-       

-End Sub

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    CheckWorkBooksArround Wb

-End Sub

-

-

-Sub CheckWorkBooksArround(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If app.Workbooks.Count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKOnly, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-        Exit Sub

-    End If

-

-End Sub

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub GetState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-        ActiveWorkbook.DisplayDrawingObjects = xlDisplayShapes

-        

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.Count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars("Worksheet Menu Bar").Visible = False

-End Sub

-

-

-Public Sub RestoreState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars("Worksheet Menu Bar").Visible = True

-End Sub

-

-

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Export"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 620

-                        .OnAction = "cmExport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(flag As Boolean)

-    If flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars("Worksheet Menu Bar")

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmExport()

-    dbExport

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    Dim dlg As dlgAbout

-    Set dlg = New dlgAbout

-    

-    dlg.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlg.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlg.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlg.Show

-End Sub

-

-Sub cmMail2Support()

-    Dim err_description As String

-    Dim dlg_msg As dlg_Mail

-    Set dlg_msg = New dlg_Mail

-    With dlg_msg

-        .Show

-        If .Tag = vbOK Then

-            ThisWorkbook.Worksheets(VAR_SHEET).Range("ERR_MESSAGE") _

-                = .tbMessage.Text

-            ThisWorkbook.Save

-            ThisWorkbook.SendMail Recipients:="infra@i-rs.ru", Subject:=PROGRAM_NAME & " ver.:" & PROGRAM_VERSION

-            MsgBox "Сообщение об ошибке отправлено. Перезагрузите программу.", vbOKOnly, PROGRAM_NAME

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-    End With

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-'        helppath = "hh.exe " & .Path & "\Telfast.chm"

-'        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub set_work_mode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-End Sub

-

-Sub cmSetStandaloneMode()

-    set_work_mode

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    Dim dlg As dlgGetPwd

-    rp = common_pwd

-    

-    Set dlg = New dlgGetPwd

-    dlg.edPwd = ""

-    dlg.Show

-    

-    If dlg.edPwd = rp Then

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-        xlRestoreView

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    Dim dlg_prn As dlgPrint

-    

-    Set dlg_prn = New dlgPrint

-    

-    With dlg_prn

-        .cbMainReport = True

-        .cbMainBudget = False

-        .cbSrcData = False

-        .cbAllSheets = False

-    

-        .Show

-    

-        If .Tag = vbCancel Then

-            Exit Sub

-        End If

-    End With

-    

-    Dim PrnIdx As Integer

-    

-    With dlg_prn

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("REP_QTR", "budget", "Final")

-    Case 1111

-        plist = Array("REP_QTR", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("REP_QTR")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Clexane bar"

-Public Const common_pwd As String = "password"

-

-

-Sub SetEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    With Application

-        .Caption = PROGRAM_NAME

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .GetState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = False

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    If cWindow.Type = xlWorkbook Then

-                        cWindow.DisplayHeadings = True

-                    End If

-                Next

-            End If

-        Next

-        .Worksheets(REP_QTR_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu (True)

-        End If

-        With mobjAppState

-            .RestoreState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Option Explicit

-

-Sub UpdateHWRecords(objHW() As Long)

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    dbUpdateHWRecords dbConnection, objHW

-    dbCloseConnection dbConnection

-End Sub

-

-Function GetHWRecords(objHW() As Long) As Integer

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    GetHWRecords = dbGetHWRecords(dbConnection, objHW)

-    dbCloseConnection dbConnection

-End Function

-

-Sub HWReset()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbInsertHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    

-    Dim dbRecordset As Object

-    Dim i As Long

-    

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "hw", dbConnection, 2, 2

-    

-    For i = 1 To UBound(objHW)

-        dbRecordset.addnew

-        dbRecordset("num") = objHW(i)

-        dbRecordset.Update

-    Next i

-    

-End Sub

-

-Sub dbUpdateHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    dbDeleteHWRecord dbConnection

-    dbInsertHWRecords dbConnection, objHW

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-dbHir
->>>>>>
-Attribute VB_Name = "dbHir"

-Option Explicit

-

-Public Type tHIRURGIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    operations_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_ambulator_clexan_40mg As Integer

-    patients_ambulator_clexan_20mg As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-    patients_stationar_clexan_40mg As Integer

-    patients_stationar_clexan_20mg As Integer

-End Type

-

-' if objHir.ID <> 0 then updatre else insert

-Sub Insert_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objHir.id <> 0 Then

-        dbUpdate_Hir_Record dbConnection, objHir

-    Else

-        dbInsert_Hir_Record dbConnection, objHir

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Hir_RecordsByLPU_ID(ByRef allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Hir_RecordsByLPU_ID = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, allHir, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Hir_Record dbConnection, objHir

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objHir.ID <> 0 then updatre else insert

-

-Sub dbInsert_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_hir", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objHir

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("operations_per_quarter") = .operations_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_ambulator_clexan_20mg") = .patients_ambulator_clexan_20mg

-        dbRecordset("patients_ambulator_clexan_40mg") = .patients_ambulator_clexan_40mg

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-        dbRecordset("patients_stationar_clexan_20mg") = .patients_stationar_clexan_20mg

-        dbRecordset("patients_stationar_clexan_40mg") = .patients_stationar_clexan_40mg

-        

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objHir.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim UpdateSQL As String

-    

-    With objHir

-        UpdateSQL = "UPDATE lpu_hir SET " & _

-            "entry_date='" & objHir.entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "operations_per_quarter=" & .operations_per_quarter & "," & _

-            "risk_percent=" & .risk_percent & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_ambulator_clexan_20mg=" & .patients_ambulator_clexan_20mg & "," & _

-            "patients_ambulator_clexan_40mg=" & .patients_ambulator_clexan_40mg & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & "," & _

-            "patients_stationar_clexan_20mg=" & .patients_stationar_clexan_20mg & "," & _

-            "patients_stationar_clexan_40mg=" & .patients_stationar_clexan_40mg & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_Hir_RecordsbyLPU_ID(dbConnection As Object, allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Hir_SQL As String

-    Dim getAll_Hir_SQL As String

-    Dim Hir_Count As Long

-    Hir_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Hir_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Hir_Count = dbRecordset("HIR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Hir_RecordsbyLPU_ID = Hir_Count

-    

-    If Hir_Count > 0 Then

-        'we have records

-        ReDim allHir(1 To Hir_Count)

-        Dim index As Integer

-        index = 1

-        dbRecordset.Open getAll_Hir_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpHir As tHIRURGIA

-                 With tmpHir

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .operations_per_quarter = dbRecordset("operations_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_ambulator_clexan_20mg = dbRecordset("patients_ambulator_clexan_20mg")

-                    .patients_ambulator_clexan_40mg = dbRecordset("patients_ambulator_clexan_40mg")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                    .patients_stationar_clexan_20mg = dbRecordset("patients_stationar_clexan_20mg")

-                    .patients_stationar_clexan_40mg = dbRecordset("patients_stationar_clexan_40mg")

-                 End With

-                 

-                 allHir(index) = tmpHir

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE ID=" & objHir.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Hir_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbTer
->>>>>>
-Attribute VB_Name = "dbTer"

-Option Explicit

-

-Public Type tTERAPIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objTer.ID <> 0 then updatre else insert

-Sub Insert_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objTer.id <> 0 Then

-        dbUpdate_Ter_Record dbConnection, objTer

-    Else

-        dbInsert_Ter_Record dbConnection, objTer

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Ter_RecordsByLPU_ID(ByRef allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Ter_RecordsByLPU_ID = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, allTer, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Ter_Record dbConnection, objTer

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objTer.ID <> 0 then updatre else insert

-

-Sub dbInsert_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_ter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objTer

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objTer.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim Update_SQL As String

-    

-    With objTer

-        Update_SQL = "UPDATE lpu_ter SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "risk_percent=" & .risk_percent & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_Ter_RecordsbyLPU_ID(dbConnection As Object, allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Ter_SQL As String

-    Dim getAll_Ter_SQL As String

-    Dim Ter_Count As Long

-    Ter_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Ter_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Ter_Count = dbRecordset("TER_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Ter_RecordsbyLPU_ID = Ter_Count

-    

-    If Ter_Count > 0 Then

-        'we have records

-        ReDim allTer(1 To Ter_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_Ter_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpTer As tTERAPIA

-                 With tmpTer

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 allTer(index) = tmpTer

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE ID=" & objTer.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Ter_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-mLPU_LIST
->>>>>>
-Attribute VB_Name = "mLPU_LIST"

-Option Explicit

-

-Public Const CINP_AREA As String = "B12"

-Public Const CLPU_NAME As Integer = 0

-Public Const CLPU_NAME1 As Integer = 1

-Public Const CLPU_NAME2 As Integer = 2

-Public Const CLPU_ID As Integer = 3

-Public Const CLPU_BEDS As Integer = 4

-Public Const CLPU_NFG As Integer = 5

-Public Const CLPU_NMG As Integer = 6

-Public Const CLPU_HIR As Integer = 7

-Public Const CLPU_TER As Integer = 8

-Public Const CLPU_CAR As Integer = 9

-Public Const CLPU_FACT As Integer = 10

-Public Const CLPU_PLAN As Integer = 11

-Public Const CLPU_PAT_LPU As Integer = 16

-Public Const CLPU_BDGT As Integer = 17

-Public Const CLPU_PAT_ALL As Integer = 16

-

-

-

-Sub EditLPU(cLPU As tLPU, ent_date As String)

-    Dim del_request As Integer

-    Dim allLPU() As tLPU

-    Dim lpu_count As Integer

-    Dim i As Integer

-    Dim tmp_LPU_List As Range

-    Dim tmp_LPU_List_Addr As String

-    Dim r_end As Range

-    Dim dlg As Dlg_lpu_card

-    

-    Set dlg = New Dlg_lpu_card

-    

-    lpu_count = GetAllLPU(allLPU)

-    With Worksheets(VAR_SHEET)

-        Set tmp_LPU_List = .Range("tmp_LPU_List")

-        Set r_end = .Range(tmp_LPU_List, tmp_LPU_List.End(xlDown))

-        Set r_end = .Range(r_end, r_end.End(xlToRight))

-        .Range(tmp_LPU_List, r_end).ClearContents

-    End With

-        

-    If lpu_count <> 0 Then

-        dlg.cbxLPU_List_Enable.Enabled = True

-        For i = 1 To UBound(allLPU)

-            tmp_LPU_List.Cells(i, 1) = allLPU(i).name

-            tmp_LPU_List.Cells(i, 2) = allLPU(i).address

-            tmp_LPU_List.Cells(i, 3) = allLPU(i).beds

-            tmp_LPU_List.Cells(i, 4) = allLPU(i).id

-        Next i

-    Else

-        dlg.cbxLPU_List_Enable.Enabled = False

-    End If

-    

-    tmp_LPU_List_Addr = Worksheets(VAR_SHEET).name & "!" & _

-            Worksheets(VAR_SHEET).Range(tmp_LPU_List, tmp_LPU_List.End(xlDown)).address

-

-    With dlg

-        .cbLPU_List.RowSource = tmp_LPU_List_Addr

-        .cbLPU_List.ListIndex = 0

-        .cbxLPU_List_Enable = False

-        .cbLPU_List.Enabled = False

-        If cLPU.id <> 0 Then

-            .cbxLPU_List_Enable.Enabled = False

-        Else

-            If lpu_count <> 0 Then

-                .cbxLPU_List_Enable.Enabled = True

-            Else

-                .cbxLPU_List_Enable.Enabled = False

-            End If

-        End If

-        .tb_lpu_name.Text = cLPU.name

-        .tb_lpu_address.Text = cLPU.address

-        .tbBedsCount = cLPU.beds

-

-        .Tag = vbCancel

-    End With

-    

-    dlg.Show

-    

-    If Not IsNumeric(dlg.Tag) Then

-        Exit Sub

-    End If

-    

-    If dlg.Tag = vbOK Then

-        Dim n As Variant

-        Dim test As Integer

-        test = 0

-        n = dlg.tbBedsCount.Value

-        If Not IsNumeric(n) Then

-            test = 1

-        Else

-            If n = 0 Then

-                test = 1

-            End If

-        End If

-        If test = 0 Then

-            

-            cLPU.name = dlg.tb_lpu_name.Text

-            cLPU.address = dlg.tb_lpu_address.Text

-            cLPU.beds = dlg.tbBedsCount.Value

-                                    

-            If cLPU.name = "" Or cLPU.address = "" Then

-                test = 2

-            End If

-        End If

-        Select Case test

-            Case 0

-                If dlg.cbxLPU_List_Enable.Enabled = True Then

-                    cLPU.id = tmp_LPU_List.Cells(dlg.cbLPU_List.ListIndex + 1, 4)

-                End If

-                Insert_LPU_Record cLPU

-                ' Проверить наличие данных для ЛПУ в квартале

-                Dim bdgt As tBUDGET

-                bdgt = Get_BDGT_Record(cLPU.id, ent_date)

-                ' Записи нет: создать пустую запись в lpu_budget

-                If bdgt.id = 0 Then

-                    bdgt.lpu_id = cLPU.id

-                    bdgt.entry_date = ent_date

-                    Insert_BDGT_Record bdgt

-                End If

-            Case 1

-                MsgBox "Коечная мощьность измеряется числом более чем 1!", vbOKOnly, PROGRAM_NAME

-            Case 2

-                MsgBox "Наименование и адрес ЛПУ не должны быть пустыми!", vbOKOnly, PROGRAM_NAME

-        End Select

-    End If

-End Sub

-

-Sub Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-        End If

-    Next i

-

-End Sub

-

-Sub Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btLPU_DEL_IT()

-    Dim cLPU As tLPU

-    Dim ent_date As String

-    Dim delete_all As Integer

-    Dim dlg_del As dlg_LPU_delete

-    

-    With Worksheets("LPU_LIST")

-        ent_date = .Range("ent_date")

-        cLPU.id = .getCurrentLPU_ID()

-    End With

-    

-    If cLPU.id = 0 Then

-        MsgBox "Укажите удаляемый объект", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    cLPU = Get_LPU_Record(cLPU.id)

-    

-    Set dlg_del = New dlg_LPU_delete

-    With dlg_del

-        .chbDeleteQTR.Value = True

-        .chbDeleteAll.Value = False

-        .lComment = ent_date & ": Удаление ЛПУ '" _

-        & cLPU.name & "', расположенного по адресу:" _

-        & cLPU.address & "."

-        .Show

-        

-        If .Tag = vbOK Then

-            If .chbDeleteAll.Value Then

-                delete_all = _

-                    MsgBox("Все записи об ЛПУ с именем '" & cLPU.name & _

-                    "' будут удалены навсегда.", vbOK, PROGRAM_NAME)

-                If delete_all = vbOK Then

-                    Delete_LPU_Record cLPU

-                End If

-            Else

-                Delete_LPU_RecordQTR cLPU, ent_date

-            End If

-        End If

-    End With

-    

-    With ThisWorkbook

-        .Worksheets(TITLE_SHEET).Select

-        .Worksheets("LPU_LIST").Select

-    End With

-End Sub

-

-Sub btLPU_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Activate

-End Sub

-

-

-Sub btLPU_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim lpu_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("QTR_ACTION").Value

-    With Worksheets("LPU_LIST")

-        ent_date = .getEnt_date()

-        

-    

-        lpu_id = .getCurrentLPU_ID

-        If lpu_id = 0 And i <> 6 Then

-            i = 1

-        End If

-        Select Case i

-            Case 1

-                .SelectLPU_NAME lpu_id, ent_date

-                .Range("JUMP") = ""

-            Case 2

-                .SelectLPU_BDGT lpu_id, ent_date

-                .Range("JUMP") = "LPU_BDGT"

-            Case 3

-                .SelectLPU_HIR lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_HIR"

-            

-            Case 4

-                .SelectLPU_TER lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_TER"

-                

-            Case 5

-                .SelectLPU_C_ACS lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_C_ACS"

-                

-        End Select

-    End With

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-dbQTR
->>>>>>
-Attribute VB_Name = "dbQTR"

-Option Explicit

-

-Public Type tQTR

-    id As Long

-    entry_date As String

-    rep_id As Long

-    sale_plan As Long

-    ClxnH20mg As Long

-    ClxnH40mg As Long

-    ClxnT40mg As Long

-    ClxnC_IM As Long

-    ClxnC_ACS As Long

-End Type

-

-

-Sub Insert_QTR_Record(ByRef objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objQTR.id <> 0 Then

-        dbUpdate_QTR_Record dbConnection, objQTR

-    Else

-        dbInsert_QTR_Record dbConnection, objQTR

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-Function Get_QTR_Record(ent_date As String) As tQTR

-    Dim dbConnection As Object

-    Dim allQTR() As tQTR

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    i = dbGetAll_QTR_Records(dbConnection, allQTR, ent_date)

-    If i <> 0 Then

-        Get_QTR_Record = allQTR(1)

-    End If

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTR_Records(ByRef all_QTR() As tQTR, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_QTR_Records = dbGetAll_QTR_Records(dbConnection, all_QTR, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_QTR_Record(ByRef objQTR As tQTR)

-    Dim dbConnection As Object

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_QTR_Record dbConnection, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objQTR.ID <> 0 then updatre else insert

-Sub dbInsert_QTR_Record(dbConnection As Object, ByRef objQTR As tQTR)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "quarter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objQTR

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("sale_plan") = .sale_plan

-        dbRecordset("rep_id") = .rep_id

-        dbRecordset("ClxnH20mg") = .ClxnH20mg

-        dbRecordset("ClxnH40mg") = .ClxnH40mg

-        dbRecordset("ClxnT40mg") = .ClxnT40mg

-        dbRecordset("ClxnC_IM") = .ClxnC_IM

-        dbRecordset("ClxnC_ACS") = .ClxnC_ACS

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objQTR.id = dbRecordset("id")

-

-End Sub

-

-Sub dbUpdate_QTR_Record(dbConnection As Object, ByRef objQTR As tQTR)

-    Dim Update_SQL As String

-    

-    With objQTR

-        Update_SQL = "UPDATE quarter SET " & _

-            "entry_date='" & .entry_date & "'" & "," & _

-            "rep_id=" & .rep_id & "," & _

-            "sale_plan=" & .sale_plan & "," & _

-            "ClxnH20mg=" & .ClxnH20mg & "," & _

-            "ClxnH40mg=" & .ClxnH40mg & "," & _

-            "ClxnT40mg=" & .ClxnT40mg & "," & _

-            "ClxnC_IM=" & .ClxnC_IM & "," & _

-            "ClxnC_ACS=" & .ClxnC_ACS & _

-            " WHERE id=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if ent_date = % then all_records

-Function dbGetAll_QTR_Records(dbConnection As Object, all_QTR() As tQTR, ent_date As String) As Integer

-    

-    Dim getCount_QTR_SQL As String

-    Dim getAll_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter WHERE entry_date like '" & ent_date & "'"

-    getAll_QTR_SQL = "SELECT * FROM quarter WHERE entry_date like '" & ent_date & "' ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_QTR_Records = QTR_Count

-    

-    If QTR_Count > 0 Then

-        'we have records

-        ReDim all_QTR(1 To QTR_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTR_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTR As tQTR

-                 With tmp_QTR

-                    .entry_date = dbRecordset("entry_date")

-                    .rep_id = dbRecordset("rep_id")

-                    .sale_plan = dbRecordset("sale_plan")

-                    .ClxnH20mg = dbRecordset("ClxnH20mg")

-                    .ClxnH40mg = dbRecordset("ClxnH40mg")

-                    .ClxnT40mg = dbRecordset("ClxnT40mg")

-                    .ClxnC_IM = dbRecordset("ClxnC_IM")

-                    .ClxnC_ACS = dbRecordset("ClxnC_ACS")

-                    .id = dbRecordset("id")

-                 End With

-                 

-                 all_QTR(index) = tmp_QTR

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_QTR_Record(dbConnection As Object, ByRef objQTR As tQTR)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM quarter " & _

-    "WHERE id=" & objQTR.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByQTR dbConnection, objQTR.entry_date

-    dbDelete_Hir_RecordsByQTR dbConnection, objQTR.entry_date

-    dbDelete_Ter_RecordsByQTR dbConnection, objQTR.entry_date

-    dbDelete_ACS_RecordsByQTR dbConnection, objQTR.entry_date

-       

-End Sub

-<<<<<<
-======================
-cdbQTR
->>>>>>
-Attribute VB_Name = "cdbQTR"

-Option Explicit

-

-Public Type tQTR_COMMON

-    qtr As tQTR

-    i_lcd As Long           ' число ЛПУ в СПИСКЕ

-    lcd() As tLPU_COMMON    ' список ЛПУ

-    c_beds As Long          ' сумма коек

-    c_bdgt_NFG As Long      ' общий бюджет на НФГ

-    c_bdgt_NMG As Long      ' общий бюджет на НМГ

-    c_bdgt_LPU As Long      ' общий бюджет на гепарины

-    c_sale_PLAN As Long     ' план продаж репа

-    c_sale_ALL As Long      ' продажи

-    c_sale_HIR As Long      ' в хирургии

-    c_sale_TER  As Long     ' в терапии

-    c_sale_CRD  As Long     ' в кардиологии

-    c_pat_HIR   As Long     ' пациенты

-    c_pat_TER   As Long     '

-    c_pat_CRD   As Long     '

-    c_pat_ALL   As Long     '

-    c_pat_LPU   As Long     ' Всего операций

-End Type

-

-Function Get_QTR_CommonList(ByRef qcd() As tQTR_COMMON) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_QTR_CommonList = dbGet_QTR_CommonList(dbConnection, qcd)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_CommonList(dbConnection As Object, ByRef qcd() As tQTR_COMMON) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim allQTR() As tQTR

-    i = dbGetAll_QTR_Records(dbConnection, allQTR, "%")

-    dbGet_QTR_CommonList = i

-    If i > 0 Then

-        ReDim qcd(i)

-        For i = 1 To UBound(allQTR)

-            With qcd(i)

-                .qtr = allQTR(i)

-                .c_beds = 0

-                .c_bdgt_NFG = 0

-                .c_bdgt_NMG = 0

-                .c_bdgt_LPU = 0

-                .c_sale_PLAN = 0

-                .c_pat_HIR = 0

-                .c_pat_TER = 0

-                .c_pat_CRD = 0

-                .c_pat_ALL = 0

-                .c_sale_HIR = 0

-                .c_sale_TER = 0

-                .c_sale_CRD = 0

-                .c_sale_ALL = 0

-                .c_pat_LPU = 0

-                

-                j = dbGet_LPU_CommonQTR(dbConnection, .lcd, .qtr)

-                .i_lcd = j

-                If j > 0 Then

-                    For j = 1 To UBound(.lcd)

-                        .c_beds = .c_beds + .lcd(j).lpu.beds

-                        .c_bdgt_NFG = .c_bdgt_NFG + .lcd(j).bdgt.bdgt_NFG

-                        .c_bdgt_NMG = .c_bdgt_NMG + .lcd(j).bdgt.bdgt_NMG

-                        .c_bdgt_LPU = .c_bdgt_LPU + .lcd(j).bdgt_LPU

-                        .c_sale_PLAN = .c_sale_PLAN + .lcd(j).bdgt.sale_plan

-                        .c_pat_HIR = .c_pat_HIR + .lcd(j).pat_HIR

-                        .c_pat_TER = .c_pat_TER + .lcd(j).pat_TER

-                        .c_pat_CRD = .c_pat_CRD + .lcd(j).pat_CRD

-                        .c_pat_ALL = .c_pat_ALL + .lcd(j).pat_ALL

-                        .c_sale_HIR = .c_sale_HIR + .lcd(j).sale_HIR

-                        .c_sale_TER = .c_sale_TER + .lcd(j).sale_TER

-                        .c_sale_CRD = .c_sale_CRD + .lcd(j).sale_CRD

-                        .c_sale_ALL = .c_sale_ALL + .lcd(j).sale_ALL

-                        .c_pat_LPU = .c_pat_LPU + .lcd(j).pat_LPU

-                    Next j

-                    

-                End If

-            End With

-        Next i

-    End If

-End Function

-

-Function GetLastQtr() As String

-    Dim s As String

-    Dim r As Range

-    Set r = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Do While r.Cells(1, 1) <> ""

-        s = r.Cells(1, 1)

-        Set r = r.Cells.Offset(1, 0)

-    Loop

-    GetLastQtr = s

-End Function

-

-Function GetNextQTR(ent_date As String) As String

-    Dim rd As Range

-    Dim idx As Integer

-    Dim b As Variant

-    Dim dlg As dlg_newQTR

-    Set dlg = New dlg_newQTR

-    

-    If ent_date = "" Then

-        Dim ir As Variant

-        idx = 0

-        dlg.Show

-        b = dlg.Tag

-            

-        If IsNumeric(b) Then

-            GetNextQTR = dlg.cbQTR

-        Else

-            GetNextQTR = ""

-        End If

-    Else

-        Set rd = Worksheets(VAR_SHEET).Range("Date_Lst")

-        idx = WorksheetFunction.Match(ent_date, rd, 0)

-        GetNextQTR = WorksheetFunction.index(rd, idx + 1, 1)

-    End If

-End Function

-<<<<<<
-======================
-mRestView
->>>>>>
-Attribute VB_Name = "mRestView"

-Option Explicit

-

-Sub xlRestoreView()

-Attribute xlRestoreView.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute xlRestoreView.VB_ProcData.VB_Invoke_Func = " \n14"

-    With Application

-        .CommandBars("Standard").Visible = True

-        .CommandBars("Formatting").Visible = True

-        .DisplayFormulaBar = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .DisplayStatusBar = True

-    End With

-End Sub

-<<<<<<
-======================
-dlg_newQTR
->>>>>>
-Attribute VB_Name = "dlg_newQTR"

-Attribute VB_Base = "0{CB598DF8-D744-4C0F-8E95-979C0EB2D31F}{07ECD06D-1C59-42FA-8A05-5C7059B89B88}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mDec2TS
->>>>>>
-Attribute VB_Name = "mDec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-CHRT_LPU_BBL
->>>>>>
-Attribute VB_Name = "CHRT_LPU_BBL"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PAT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PAT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-<<<<<<
-======================
-CHRT_PAT_LPU
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_nextQTR
->>>>>>
-Attribute VB_Name = "dlg_nextQTR"

-Attribute VB_Base = "0{7BCBD561-C46C-4F55-88AD-48A260810549}{EFA3446E-8602-4D47-A205-3F681A9D4151}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-cdbLPU
->>>>>>
-Attribute VB_Name = "cdbLPU"

-Option Explicit

-

-Public Type tLPU_COMMON

-    lpu As tLPU

-    bdgt As tBUDGET

-    i_hir As Long

-    hir() As tHIRURGIA

-    i_ter As Long

-    ter() As tTERAPIA

-    i_ACS As Long

-    ACS() As tACS

-    bdgt_LPU As Long

-    sale_HIR As Long

-    sale_TER As Long

-    sale_CRD As Long

-    sale_ALL As Long

-    pat_HIR As Long

-    pat_TER As Long

-    pat_CRD As Long

-    pat_ALL As Long     ' Сумма всех пациентов на клексане

-    pat_LPU As Long     ' Число потенциальных пациентов для продаж клексана

-End Type

-

-Function Get_LPU_CommonQTR(ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    Get_LPU_CommonQTR = dbGet_LPU_CommonQTR(dbConnection, lcd, objQTR)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_CommonQTR(dbConnection As Object, ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    i = dbGetAllLPUbyQTR(dbConnection, allLPU, objQTR.entry_date)

-    dbGet_LPU_CommonQTR = i

-    If i > 0 Then

-        ReDim lcd(i)

-        For i = 1 To UBound(allLPU)

-            dbGet_LPU_Common dbConnection, lcd(i), allLPU(i), objQTR

-        Next i

-    End If

-End Function

-

-Sub Get_LPU_Common(ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    dbGet_LPU_Common dbConnection, lcd, cLPU, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbGet_LPU_Common(dbConnection As Object, ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-

-    lcd.lpu = cLPU

-    lcd.bdgt = dbGet_BDGT_Record(dbConnection, cLPU.id, objQTR.entry_date)

-    lcd.i_hir = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, lcd.hir, cLPU.id, objQTR.entry_date)

-    lcd.i_ter = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, lcd.ter, cLPU.id, objQTR.entry_date)

-    lcd.i_ACS = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, lcd.ACS, cLPU.id, objQTR.entry_date)

-    With lcd

-        .bdgt_LPU = .bdgt.bdgt_NFG + .bdgt.bdgt_NMG

-        .pat_LPU = 0

-        If .i_hir > 0 Then

-            .pat_HIR = .hir(1).patients_ambulator_clexan + .hir(1).patients_stationar_clexan

-            .sale_HIR = objQTR.ClxnH20mg * (.hir(1).patients_ambulator_clexan_20mg + .hir(1).patients_stationar_clexan_20mg)

-            .sale_HIR = .sale_HIR + objQTR.ClxnH40mg * (.hir(1).patients_ambulator_clexan_40mg + .hir(1).patients_stationar_clexan_40mg)

-            .pat_LPU = .pat_LPU + .hir(1).operations_per_quarter

-        End If

-        If .i_ter > 0 Then

-            .pat_TER = .ter(1).patients_ambulator_clexan + .ter(1).patients_stationar_clexan

-            .sale_TER = .pat_TER * objQTR.ClxnT40mg

-            .pat_LPU = .pat_LPU + .ter(1).patients_per_quarter

-        End If

-        If .i_ACS > 0 Then

-            .pat_CRD = .ACS(1).patients_stationar_clexan

-            .sale_CRD = .pat_CRD * objQTR.ClxnC_ACS

-            .pat_LPU = .pat_LPU + .ACS(1).patients_per_quarter

-        End If

-        .pat_ALL = .pat_HIR + .pat_TER + .pat_CRD

-        .sale_ALL = .sale_HIR + .sale_TER + .sale_CRD

-    End With

-End Sub

-

-<<<<<<
-======================
-CHRT_PIE
->>>>>>
-Attribute VB_Name = "CHRT_PIE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PLN_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PLN_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_BDGT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_BDGT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_LPU_delete
->>>>>>
-Attribute VB_Name = "dlg_LPU_delete"

-Attribute VB_Base = "0{D9DD256D-F23B-4FD6-88F0-FE8DAA2B3BB1}{7AF34CC3-6E90-457A-A3A8-7BF91A89A158}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlg_Mail
->>>>>>
-Attribute VB_Name = "dlg_Mail"

-Attribute VB_Base = "0{E3301CDB-CB6A-4294-B02F-936DCCCFF7FB}{AA37504B-6245-47E7-AEC0-729CA3A51508}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dbREP_id
->>>>>>
-Attribute VB_Name = "dbREP_id"

-Public Type tID_REP

-    id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Public Type tID_REP_COMMON

-    id_rep As tID_REP

-    i_qtr As Long

-    qtrs As tQTR_COMMON

-End Type

-<<<<<<
-======================
-cdbExport
->>>>>>
-Attribute VB_Name = "cdbExport"

-Option Explicit

-

-Function GetDBSN() As String

-    Dim n As Long

-    Randomize Timer

-    n = Int((100000000 - 1000000 + 1) * Rnd + 1000000)

-    GetDBSN = Dec2ThirtySix(n)

-End Function

-

-Sub dbExport()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim old_file As String

-    

-    On Error GoTo ErrHandler

-    

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    old_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & "*.*"

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & GetDBSN() & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.DeleteFile old_file, True

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Данные экспортированы в файл:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для передачи", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-Exit Sub

-

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-<<<<<<
-======================
-mRegs
->>>>>>
-Attribute VB_Name = "mRegs"

-Option Explicit

-

-Function GetRegionName(idx As Integer) As String

-    GetRegionName = Worksheets(REGS_SHEET).Range("LST_REGIONS").Cells(idx + 1, 1).Text

-End Function

-

-Function GetCityName(idx_reg As Integer, idx_city As Integer) As String

-    GetCityName = Worksheets(REGS_SHEET).Range("CITY_TABLES").Offset(idx_city + 1, idx_reg * 2).Text

-End Function

-

-Sub t()

-    Dim r As Integer

-    Dim c As Integer

-    Dim s As String

-    

-    r = 3

-    c = 3

-    s = GetRegionName(r)

-    s = s & ", " & GetCityName(r, c)

-    MsgBox s

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    

-    Application.EnableEvents = True

-    Set MyAppEvents.app = Application

-    

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    

-    set_work_mode

-    

-    MyAppEvents.CheckWorkBooksArround ThisWorkbook

-    

-    CheckUser

-    

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-    Application.ScreenUpdating = True

-

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-    ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-    Application.Calculate

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    

-    Application.Caption = Empty

-    Application.CommandBars("Worksheet Menu Bar").Reset

-    

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-    

-    With ThisWorkbook

-        xlRestoreView

-        .Application.DisplayAlerts = False

-        .Save

-    End With

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-    Dim MaxX, MaxY As Integer

-    With ThisWorkbook.Worksheets(RM_QTR_SHEET)

-        .Select

-        MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-        MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-    End With

-

-    With ThisWorkbook.Application

-        .ScreenUpdating = False

-        .WindowState = xlNormal

-        .Height = MaxY

-        .Width = MaxX

-    End With

-End Sub

-

-

-

-

-

-<<<<<<
-======================
-REP_QTR
->>>>>>
-Attribute VB_Name = "REP_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CQTR_QT As Integer = 0

-Const CQTR_ID As Integer = 1

-Const CQTR_PLN As Integer = 2

-Const CQTR_FCT As Integer = 3

-Const CQTR_BDG As Integer = 4

-Const CQTR_CNT As Integer = 5

-Const CQTR_BEDS As Integer = 6

-Const CQTR_HIR As Integer = 7

-Const CQTR_TER As Integer = 8

-Const CQTR_CRD As Integer = 9

-Const CQTR_CLXN_BDG As Integer = 10

-Const CQTR_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub update_history()

-    Dim objQTR() As tQTR

-    Dim i As Long

-    Dim r As Range

-    Dim cRep As tREPID

-

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    Range("D4") = cRep.LastName

-    Range("D5") = cRep.FirstName

-

-    Range("H4") = GetRegionName(cRep.Region)

-    Range("H5") = GetCityName(cRep.Region, cRep.City)

-

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetAll_QTR_Records_by_REP(objQTR, "%", cRep.rep_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CQTR_QT) = objQTR(i).entry_date

-        Next i

-    End If

-    Dim qcd() As tQTR_COMMON

-    i = Get_QTR_CommonList_by_REP(qcd, "%", cRep.rep_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(qcd)

-            r.Offset(i - 1, CQTR_QT) = qcd(i).qtr.entry_date

-            r.Offset(i - 1, CQTR_ID) = qcd(i).qtr.id

-            r.Offset(i - 1, CQTR_PLN) = qcd(i).qtr.sale_PLAN

-            r.Offset(i - 1, CQTR_FCT) = qcd(i).c_sale_ALL

-            r.Offset(i - 1, CQTR_BDG) = qcd(i).c_bdgt_LPU

-            r.Offset(i - 1, CQTR_CNT) = qcd(i).i_lcd

-            r.Offset(i - 1, CQTR_BEDS) = qcd(i).c_beds

-            r.Offset(i - 1, CQTR_HIR) = qcd(i).c_pat_HIR

-            r.Offset(i - 1, CQTR_TER) = qcd(i).c_pat_TER

-            r.Offset(i - 1, CQTR_CRD) = qcd(i).c_pat_CRD

-            If qcd(i).c_bdgt_LPU <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_BDG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_LPU

-            End If

-            If qcd(i).c_bdgt_NMG <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_NMG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CQTR_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRepQtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CQTR_ID + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    i = currRange.Column - Range(CINP_AREA).Column

-

-    QTR_ID = r

-

-    If QTR_ID = 0 Then

-        Worksheets(VAR_SHEET).Range("USER_ACTION") = 1

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        If i > CQTR_FCT Then

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-            Range("LAST_FOCUS") = currRange.address

-        Else

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 3

-            Range("LAST_FOCUS") = currRange.address

-        End If

-    End If

-    Cancel = True

-    btHomeDo_IT

-End Sub

-

-<<<<<<
-======================
-mRep_QTR
->>>>>>
-Attribute VB_Name = "mRep_QTR"

-Option Explicit

-

-Sub NoFunc()

-    MsgBox "Функция не доступна", vbOKOnly, PROGRAM_NAME

-End Sub

-

-Sub DO_Price_qtr(ent_date As String)

-    Dim qtr As tQTR

-    Dim res As Integer

-    Dim cRep As tREPID

-

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    qtr = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-

-    If qtr.id = 0 Then

-        qtr.entry_date = ent_date

-

-        With Worksheets(VAR_SHEET)

-            qtr.ClxnH20mg = .Range("ClxnH20mg")

-            qtr.ClxnH40mg = .Range("ClxnH40mg")

-            qtr.ClxnT40mg = .Range("ClxnT40mg")

-            qtr.ClxnC_ACS = .Range("ClxnC_ACS")

-            qtr.ClxnC_IM = .Range("ClxnC_IM")

-        End With

-    End If

-

-    Dim dlg_nq As dlg_nextQTR

-    Set dlg_nq = New dlg_nextQTR

-

-    With dlg_nq

-        .tb_qtr_name = qtr.entry_date

-        .tb_bdgt_avts = qtr.sale_PLAN

-        .tb_qtr_name = qtr.entry_date

-        .tb_ClxnH20mg = qtr.ClxnH20mg

-        .tb_ClxnH40mg = qtr.ClxnH40mg

-        .tb_ClxnT40mg = qtr.ClxnT40mg

-        .tb_ClxnC_ACS = qtr.ClxnC_ACS

-        .tb_ClxnC_IM = qtr.ClxnC_IM

-    End With

-

-    dlg_nq.Show

-End Sub

-

-Sub DO_Edit_qtr(ent_date As String)

-    If ent_date = "" Then

-        NoFunc

-    Else

-        Dim rep_id As Long

-        rep_id = Worksheets(REP_QTR_SHEET).Range("REP_ID")

-        With ThisWorkbook.Worksheets("LPU_LIST")

-            .Range("VIEW_ONLY") = True

-            .Range("ent_date") = ent_date

-            .Range("REP_ID") = rep_id

-            .Select

-        End With

-    End If

-End Sub

-

-Sub DO_Delete_qtr(ent_date As String)

-    If ent_date <> "" Then

-        MsgBox "Удалить данные за период [" & ent_date & "] нельзя ", vbOKOnly, PROGRAM_NAME

-    End If

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-

-Sub btHomeDo_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    idx = Worksheets(VAR_SHEET).Range("USER_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            NoFunc

-            ' Обновляем экран

-        Case 2

-            DO_Edit_qtr ent_date

-        Case 3

-            DO_Price_qtr ent_date

-        Case 4

-            NoFunc

-    End Select

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-Sub Delete_qtr()

-'    Dim ent_date As String

-'    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-'    DO_Delete_qtr ent_date

-End Sub

-

-Sub btREP_QTR_RET_IT()

-    Dim s As String

-    With Worksheets("REP_QTR")

-        .Range("LAST_FOCUS") = ""

-        s = .Range("ret_addr")

-        .Range("ret_addr") = ""

-    End With

-    If s <> "" Then

-        ThisWorkbook.Worksheets(s).Select

-    Else

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane[RM]"

-Public Const PROGRAM_VERSION As String = "Clexane[RM] ver 1.0"

-Public Const PROGRAM_FILENAME As String = "clexane-rm"

-Public Const PROGRAM_EXPORTNAME As String = "rm-export-"

-Public Const PROGRAM_IMPORTNAME As String = "mr-export-*"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20030329

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "P40"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-Public Const RM_QTR_SHEET As String = "RM_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-

-End Sub

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetWBName(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBName = Right(FullName, s_len - pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.name = VAR_SHEET Or sh.name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-<<<<<<
-======================
-Var
->>>>>>
-Attribute VB_Name = "Var"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-title
->>>>>>
-Attribute VB_Name = "title"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LPU_LIST
->>>>>>
-Attribute VB_Name = "LPU_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentLPU_ID() As Long

-    Dim r As Range

-

-    With Worksheets("LPU_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CLPU_ID)

-    End With

-

-    getCurrentLPU_ID = r

-End Function

-

-Public Sub LPU_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectLPU_NAME(lpu_id As Long, ent_date As String)

-    If Range("VIEW_ONLY") = True Then

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    Dim cLPU As tLPU

-    If lpu_id = 0 Then

-        cLPU.id = 0

-        cLPU.rep_id = 0

-        cLPU.address = ""

-        cLPU.name = ""

-    Else

-        cLPU = Get_LPU_Record(lpu_id)

-    End If

-    EditLPU cLPU, getEnt_date

-    Worksheet_Activate

-End Sub

-

-Sub SelectLPU_BDGT(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    vo = Range("VIEW_ONLY")

-    If lpu_id = 0 Then

-        SelectLPU_NAME lpu_id, ent_date

-    Else

-        With ThisWorkbook.Worksheets("LPU_BDGT")

-            .Range("VIEW_ONLY") = vo

-            .Range("ret_addr") = "LPU_LIST"

-            .Range("REP_ID") = r_id

-            .Range("ent_date") = ent_date

-            .Range("lpu_id") = lpu_id

-        End With

-    End If

-End Sub

-

-Sub SelectLPU_HIR(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_HIR")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Sub SelectLPU_TER(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_TER")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Sub SelectLPU_C_ACS(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_C_ACS")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateLPUList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-'    Dim r_sel As Range

-'    If Not chk_input_range(Target) Then

-'        Set r_sel = Range(CINP_AREA)

-'    Else

-'        Set r_sel = Target

-'    End If

-'

-'    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-'        Set r_sel = r_sel.Cells(1, 1)

-'    End If

-'

-'    If r_sel.count = 1 Then

-'        Range("LAST_FOCUS") = r_sel.address

-'        InpRowSelect r_sel

-'    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim lpu_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CINP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CINP_AREA).row, CLPU_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    lpu_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CINP_AREA).Column

-

-    If lpu_id = 0 Then

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    End If

-

-    If lpu_id = 0 Then

-        i = CLPU_NAME

-        Range("JUMP") = ""

-    End If

-    Select Case i

-        Case CLPU_NAME, CLPU_NAME1, CLPU_NAME2, CLPU_BEDS

-            SelectLPU_NAME lpu_id, ent_date

-            Range("JUMP") = ""

-

-        Case CLPU_NMG, CLPU_NFG, CLPU_PLAN, CLPU_FACT

-            SelectLPU_BDGT lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-

-        Case CLPU_HIR

-            SelectLPU_HIR lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_HIR"

-

-        Case CLPU_TER

-            SelectLPU_TER lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_TER"

-

-        Case CLPU_CAR

-            SelectLPU_C_ACS lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        Case Else

-            Range("JUMP") = ""

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateLPUList()

-    Dim lcd() As tLPU_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-    Dim objQTR As tQTR

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    ent_date = getEnt_date

-

-'     ent_date = "%" ' % - all records

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-    i = Get_LPU_CommonQTR(lcd, objQTR)

-

-'     стираем ФИО

-    Range("C3:C4").ClearContents

-

-    Range("C3") = cRep.LastName

-    Range("C4") = cRep.FirstName

-    Range("G3") = GetRegionName(cRep.Region)

-    Range("G4") = GetCityName(cRep.Region, cRep.City)

-    Range("G5") = objQTR.sale_PLAN

-

-

-

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(lcd)

-            r.Offset(i - 1, CLPU_NAME) = lcd(i).lpu.name

-            r.Offset(i - 1, CLPU_ID) = lcd(i).lpu.id

-            r.Offset(i - 1, CLPU_BEDS) = lcd(i).lpu.beds

-

-

-            r.Offset(i - 1, CLPU_NFG) = lcd(i).bdgt.bdgt_NFG

-            r.Offset(i - 1, CLPU_NMG) = lcd(i).bdgt.bdgt_NMG

-            r.Offset(i - 1, CLPU_PLAN) = lcd(i).bdgt.sale_PLAN

-

-            r.Offset(i - 1, CLPU_HIR) = lcd(i).pat_HIR

-            r.Offset(i - 1, CLPU_TER) = lcd(i).pat_TER

-            r.Offset(i - 1, CLPU_CAR) = lcd(i).pat_CRD

-            r.Offset(i - 1, CLPU_FACT) = lcd(i).sale_ALL

-            r.Offset(i - 1, CLPU_PAT_LPU) = lcd(i).pat_LPU

-            r.Offset(i - 1, CLPU_BDGT) = lcd(i).bdgt_LPU

-            If lcd(i).bdgt_LPU > 0 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = lcd(i).sale_ALL / lcd(i).bdgt_LPU

-            End If

-            If r.Offset(i - 1, CLPU_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{A5C75EBA-B704-40A8-8703-4024BEBD3C62}{7FC65B94-0A91-420F-9DF8-7707F2D795DE}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-dbACS
->>>>>>
-Attribute VB_Name = "dbACS"

-Option Explicit

-

-Public Type tACS

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    patients_with_geparins As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objACS.ID <> 0 then updatre else insert

-Sub Insert_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objACS.id <> 0 Then

-        dbUpdate_ACS_Record dbConnection, objACS

-    Else

-        dbInsert_ACS_Record dbConnection, objACS

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_ACS_RecordsByLPU_ID(ByRef all_ACS_() As tACS, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_ACS_RecordsByLPU_ID = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, all_ACS_, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_ACS_Record dbConnection, objACS

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub dbInsert_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_acs", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objACS

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("patients_with_geparins") = .patients_with_geparins

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objACS.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim Update_SQL As String

-    

-    With objACS

-        Update_SQL = "UPDATE lpu_acs SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "patients_with_geparins=" & .patients_with_geparins & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_ACS_RecordsbyLPU_ID(dbConnection As Object, all_ACS() As tACS, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_ACS_SQL As String

-    Dim getAll_ACS_SQL As String

-    Dim ACS_Count As Long

-    ACS_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_ACS_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        ACS_Count = dbRecordset("ACS_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_ACS_RecordsbyLPU_ID = ACS_Count

-    

-    If ACS_Count > 0 Then

-        'we have records

-        ReDim all_ACS(1 To ACS_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_ACS_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_ACS As tACS

-                 With tmp_ACS

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .patients_with_geparins = dbRecordset("patients_with_geparins")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 all_ACS(index) = tmp_ACS

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE ID=" & objACS.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_ACS_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_HIR
->>>>>>
-Attribute VB_Name = "LPU_CLSN_HIR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-

-        Dim objHir As tHIRURGIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objHir

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .operations_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L9")

-                .patients_ambulator_clexan_20mg = Range("L10")

-                .patients_ambulator_clexan_40mg = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L19")

-                .patients_stationar_clexan_20mg = Range("L20")

-                .patients_stationar_clexan_40mg = Range("L21")

-            End With

-            Insert_Hir_Record objHir

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objHir.id = Range("rec_id")

-                    If objHir.id <> 0 Then

-                        Delete_Hir_Record objHir

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objHir As tHIRURGIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    With objHir

-        Range("rec_id") = .id

-        Range("F6") = .operations_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L9") = .patients_ambulator_clexan

-        Range("L10") = .patients_ambulator_clexan_20mg

-        Range("I21") = .patients_stationar_nmg

-        Range("L19") = .patients_stationar_clexan

-        Range("L20") = .patients_stationar_clexan_20mg

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id)

-

-        formula = "=" & qtr.ClxnH20mg & "*($L$10+$L$20)+" & qtr.ClxnH40mg & "*($L$11+$L$21)"

-        Range("F11").formula = formula

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objHir() As tHIRURGIA

-        Dim i As Integer

-        i = GetAll_Hir_RecordsByLPU_ID(objHir, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.3

-        Else

-            SetupData objHir(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-mSapes
->>>>>>
-Attribute VB_Name = "mSapes"

-Option Explicit

-

-Const SHAPE_COLOR As Integer = 1

-Const SHAPE_NAME As Integer = 2

-

-

-Sub ShapeView(r_sh_finite_state As Range)

-    Dim chk As Range

-    Dim s As String

-    Dim c, idx As Integer

-    For Each chk In r_sh_finite_state

-        idx = 0

-        If chk = "+" Then

-            c = chk.Offset(0, idx + SHAPE_COLOR)

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While c <> 0

-                ShapeFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s)), c

-                idx = idx + 2

-                c = chk.Offset(0, idx + SHAPE_COLOR)

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        Else

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While s <> ""

-                ShapeUnFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s))

-                idx = idx + 2

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        End If

-    Next chk

-End Sub

-

-Sub ShapeFill(sh As ShapeRange, ByVal color As Integer)

-    sh.Fill.Visible = msoTrue

-    sh.Fill.Solid

-    sh.Fill.ForeColor.SchemeColor = color

-    sh.Fill.Transparency = 0#

-End Sub

-

-Sub ShapeUnFill(sh As ShapeRange)

-    sh.Fill.Visible = msoFalse

-    sh.Fill.Transparency = 0#

-End Sub

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Public Const INPUT_NO = 0

-Public Const INPUT_NUMBER = 1

-Public Const INPUT_PERCENT = 2

-Public Const INPUT_STRING = 3

-Public Const INPUT_CHECK = 4

-

-Public Const INP_IDX_TYPE = 1

-Public Const INP_IDX_NEXT = 2

-Public Const INP_IDX_MIN = 3

-Public Const INP_IDX_MAX = 4

-Public Const INP_IDX_DEP = 5

-Public Const INP_IDX_ALT = 7

-

-

-Public Type tInputSet

-    vType As Integer

-    vMin As Long

-    vMax As Long

-    rChk As String

-End Type

-

-Function is_input_cell(ByVal Target As Range, inputs As Range) As tInputSet

-    Dim t As Range

-    Dim iset As tInputSet

-    Dim test As Range

-    iset.vType = INPUT_NO

-    iset.vMin = 0

-    iset.vMax = 0

-    iset.rChk = ""

-    is_input_cell = iset

-

-' Закоментировать следующую сточку для работы

-'  Exit Function

-

-    Set test = Target.Cells(1, 1)

-    For Each t In inputs

-        If Range(t).Column = test.Column And Range(t).row = test.row Then

-            iset.vType = t.Offset(0, INP_IDX_TYPE).Value

-            Select Case iset.vType

-                Case INPUT_CHECK

-                    iset.rChk = t.Offset(0, INP_IDX_ALT)

-                Case INPUT_NUMBER, INPUT_PERCENT

-                    iset.vMin = t.Offset(0, INP_IDX_MIN).Value

-                    iset.vMax = t.Offset(0, INP_IDX_MAX).Value

-            End Select

-            is_input_cell = iset

-            Exit Function

-        End If

-    Next t

-End Function

-

-Function GetFocusAddress(ByVal r As Range, f_next As Range) As String

-    Dim chk, t As Range

-    

-    For Each chk In f_next

-        For Each t In r

-            If t.address = chk Then

-                GetFocusAddress = chk

-                Exit Function

-            End If

-            If Range(chk).Column = t.Column - 1 And Range(chk).row = t.row _

-            Or Range(chk).Column = t.Column And Range(chk).row = t.row - 1 _

-            Then

-                If Range(chk) <> "" Then

-                    If Range(chk) = 0 Then

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_ALT)).address

-                    Else

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_NEXT)).address

-                    End If

-                Else

-                    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-                End If

-                Exit Function

-            End If

-        Next t

-    Next chk

-    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-End Function

-

-Sub SetDependet(r As Range, inputs As Range)

-    Dim chk As Range

-    Dim s, serr As String

-    Dim idx As Integer

-    Dim iset As tInputSet

-    Dim err_found As Boolean

-    

-    If r.count > 1 Then

-        Exit Sub

-    End If

-    

-    err_found = False

-    For Each chk In inputs

-        idx = INP_IDX_DEP

-        

-        

-        iset.vType = chk.Offset(0, INP_IDX_TYPE).Value

-        Select Case iset.vType

-            Case INPUT_NUMBER, INPUT_PERCENT

-                iset.vMin = chk.Offset(0, INP_IDX_MIN).Value

-                iset.vMax = chk.Offset(0, INP_IDX_MAX).Value

-                

-                If Range(chk) > iset.vMax Then

-                    err_found = True

-                    Range(chk) = iset.vMax

-                    serr = "Выход за дозволенный диапазон [" & iset.vMin & ".." & iset.vMax & "]! Данные скорректированы."

-                End If

-                

-                If Range(chk) = "" Then

-                    s = chk.Offset(0, idx)

-                    Do While s <> ""

-                        Range(s) = ""

-                        idx = idx + 1

-                        s = chk.Offset(0, idx)

-                    Loop

-                End If

-        End Select

-    Next chk

-    If err_found Then

-        MsgBox serr, vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Function CheckInputData(inputs As Range) As Boolean

-    Dim r As Range

-    

-    CheckInputData = True

-    For Each r In inputs

-        If Range(r) = "" Then

-            CheckInputData = False

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100.", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Sub Check_Int_Number(Target As Range, Def_Val As Long)

-    Dim err As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    err = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                err = True

-            End If

-        End If

-    Next r

-    If err Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_TER
->>>>>>
-Attribute VB_Name = "LPU_CLSN_TER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim objTer As tTERAPIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objTer

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .patients_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L20")

-            End With

-            Insert_Ter_Record objTer

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objTer.id = Range("rec_id")

-                    If objTer.id <> 0 Then

-                        Delete_Ter_Record objTer

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objTer As tTERAPIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    With objTer

-        Range("rec_id") = .id

-        Range("F6") = .patients_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L11") = .patients_ambulator_clexan

-        Range("I21") = .patients_stationar_nmg

-        Range("L20") = .patients_stationar_clexan

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id)

-        formula = "=" & qtr.ClxnT40mg & "*($L$12+$L$20)"

-        Range("F11").formula = formula

-

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objTer() As tTERAPIA

-        Dim i As Integer

-        i = GetAll_Ter_RecordsByLPU_ID(objTer, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.25

-        Else

-            SetupData objTer(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{889AFC38-1F8F-490E-A345-A59FE5C6253E}{35BDEA9B-C00F-4BA2-BC41-F1D5364C2DFD}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-LPU_BDGT
->>>>>>
-Attribute VB_Name = "LPU_BDGT"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub SetDefFocus()

-    Range(Range("DEF_FOCUS")).Select

-End Sub

-

-Public Sub ClearData()

-    ClearSheetData

-End Sub

-

-Sub ClearSheetData()

-    If Range("F10") = 0 And Range("F13") = 0 Then

-        Range("F11:F18") = ""

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("F11:F13") = ""

-    End If

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim bdgt As tBUDGET

-        Dim test As Long

-        With bdgt

-            .lpu_id = Range("lpu_id")

-            .id = Range("rec_id")

-            .entry_date = Range("ent_date")

-            .bdgt_NMG = Round(Range("F11").Value, 0)

-            .bdgt_NFG = Round(Range("F12").Value, 0)

-            .sale_PLAN = Round(Range("F13").Value, 0)

-

-            test = .bdgt_NFG + .bdgt_NMG - .sale_PLAN

-        End With

-        If test <> 0 Then

-            If test < 0 Then

-                If vbYes = MsgBox("Ваш план превышает выделенный на гепарины бюджет. Сохранить данные?", _

-                        vbYesNo, PROGRAM_NAME) Then

-                    test = 1

-                End If

-            End If

-            If test > 0 Then

-                Insert_BDGT_Record bdgt

-            End If

-        Else

-            If bdgt.id <> 0 Then

-                If vbYes = MsgBox("Удалить данные из базы!", vbYesNo, PROGRAM_NAME) Then

-                    Delete_BDGT_Record bdgt

-                End If

-                ret_back Range("DEF_FOCUS").Worksheet

-                Exit Sub

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-    End If

-

-   ClearData

-   ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(cLPU As tLPU_COMMON)

-    Dim t_sum As Long

-    t_sum = 0

-' Setup budget data

-    Range("F11") = cLPU.bdgt.bdgt_NMG

-    Range("F12") = cLPU.bdgt.bdgt_NFG

-    Range("F13") = cLPU.bdgt.sale_PLAN

-

-    With cLPU

-        Range("F14") = .pat_ALL

-        Range("F15") = .pat_HIR

-        Range("F16") = .pat_TER

-        Range("F17") = .pat_CRD

-        Range("F18") = .sale_ALL

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    ws_activate

-End Sub

-

-

-Sub ws_activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Dim cLPU As tLPU_COMMON

-    Dim objQTR As tQTR

-    Dim objLPU As tLPU

-    Dim ent_date As String

-    Dim id As Long

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    id = Range("lpu_id").Value

-    ent_date = Range("ent_date")

-    

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-

-    objLPU = Get_LPU_Record(id)

-    Get_LPU_Common cLPU, objLPU, objQTR

-

-    If cLPU.lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = cLPU.lpu.beds

-        Range("lpu_name") = cLPU.lpu.name

-        Range("lpu_addr") = cLPU.lpu.address

-        Range("rec_id") = cLPU.bdgt.id

-

-        SetupData cLPU

-

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-'    MsgBox Target.address

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case INPUT_CHECK

-

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{54164808-BEEF-4504-84F7-7D50FB8316D5}{D4B9E98D-F32D-4EE7-B1C5-E9E2FCD7143A}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mSheets
->>>>>>
-Attribute VB_Name = "mSheets"

-Option Explicit

-

-Function am_load_now() As Boolean

-    am_load_now = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE")

-End Function

-

-Sub Wks_select(RetSheet As String)

-    Dim sheet As Worksheet

-    For Each sheet In ThisWorkbook.Worksheets

-        If sheet.name = RetSheet Then

-            ThisWorkbook.Worksheets(RetSheet).Select

-            Exit Sub

-        End If

-    Next sheet

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub ret_back(sh As Worksheet)

-    Dim RetSheet As String

-    RetSheet = sh.Range("ret_addr")

-    sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    sh.Range("ret_addr") = ""

-    sh.Range("rec_id") = ""

-    sh.Range("lpu_id") = ""

-    sh.Range("ent_date") = ""

-    sh.Range("lpu_name") = ""

-    sh.Range("lpu_addr") = ""

-    sh.Range("lpu_beds") = ""

-    Wks_select RetSheet

-End Sub

-

-Sub ClearSheetData(r_start As Range)

-    If r_start <> "" Then

-        r_start.Worksheet.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        r_start = ""

-    Else

-        ret_back r_start.Worksheet

-    End If

-End Sub

-

-Sub wks_sel_chng(iset As tInputSet, ByVal Target As Range, sh As Worksheet)

-    Dim DebugMode As Boolean

-    Dim in_range As Range

-    

-    DebugMode = Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-

-    If DebugMode Then

-        sh.Unprotect

-    Else

-        sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    End If

-

-    If iset.vType = INPUT_CHECK Then

-        Set in_range = Target.Worksheet.Range(iset.rChk)

-    Else

-        Set in_range = Target

-    End If

-    

-    Dim str As String

-    str = GetFocusAddress(in_range, sh.Range("h_inputs"))

-

-'    MsgBox Target.Address & "; " & str

-    If str <> Target.address Then

-        sh.Range(str).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-Dlg_lpu_card
->>>>>>
-Attribute VB_Name = "Dlg_lpu_card"

-Attribute VB_Base = "0{D4A3C142-06CF-4021-88A8-2E2128F43892}{89EBA4E1-4361-4E6E-8736-B0C415B09198}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbLPU_List_Change()

-    Dim src As Range

-    Dim idx_src As Integer

-    

-    Set src = Worksheets(VAR_SHEET).Range(Me.cbLPU_List.RowSource)

-    idx_src = Me.cbLPU_List.ListIndex + 1

-    Me.tb_lpu_name.Text = src.Cells(idx_src, 1)

-    Me.tb_lpu_address.Text = src.Cells(idx_src, 2)

-    Me.tbBedsCount.Text = src.Cells(idx_src, 3)

-End Sub

-

-

-Private Sub cbxLPU_List_Enable_Click()

-    

-    If Me.cbxLPU_List_Enable Then

-        

-        Me.tb_lpu_name.Text = ""

-        Me.tb_lpu_name.Enabled = False

-        

-        Me.tb_lpu_address.Text = ""

-        Me.tb_lpu_address.Enabled = False

-        

-        Me.tbBedsCount.Text = ""

-        Me.tbBedsCount.Enabled = False

-        

-        Me.cbLPU_List.Enabled = True

-        cbLPU_List_Change

-    Else

-        Me.tb_lpu_name.Enabled = True

-        Me.tb_lpu_name.Text = ""

-        

-        Me.tb_lpu_address.Enabled = True

-        Me.tb_lpu_address.Text = ""

-        

-        Me.tbBedsCount.Enabled = True

-        Me.tbBedsCount.Text = ""

-        

-        Me.cbLPU_List.Enabled = False

-    End If

-End Sub

-

-<<<<<<
-======================
-UserInfo
->>>>>>
-Attribute VB_Name = "UserInfo"

-Attribute VB_Base = "0{B2D56DB4-2D56-4C94-8B79-7CD6E29F4FFC}{1749C8F9-6882-464E-B9A9-669E72EEAC4D}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Tag = vbOK

-End Sub

-

-Private Sub cbCity_Change()

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_CITY") = Me.cbCity.ListIndex

-        .Calculate

-    End With

-End Sub

-

-Private Sub cbRegion_Change()

-    Dim LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        NewRangeOffsetCol = cbRegion.Value * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).address

-        NewSumRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).address

-        .Calculate

-        .Range("IDX_CITY") = 0

-        cbCity.RowSource = NewCbxRange

-

-    End With

-    cbCity.ListIndex = 0

-End Sub

-

-<<<<<<
-======================
-mREGMAN
->>>>>>
-Attribute VB_Name = "mREGMAN"

-Option Explicit

-

-Sub hwnew()

-    Dim rs As Range

-    Dim re As Object

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    HWReset

-    With Application

-        .DisplayAlerts = False

-        .Quit

-    End With

-End Sub

-

-Sub CheckUser()

-    If Range("HW_Number") = "" Then

-        StoreHWInfo

-    End If

-    If CheckHWInfo <> True Then

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    Else

-        SetupUser

-    End If

-End Sub

-

-

-Sub SetupUser()

-    Dim cREGMAN As tREGMAN

-    Dim idx As Integer

-    Dim dlg_ui As UserInfo

-    

-    Set dlg_ui = New UserInfo

-    

-    cREGMAN = Get_REGMAN_Record()

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_REGION") = cREGMAN.Region

-        .Range("IDX_CITY") = cREGMAN.City

-    End With

-        

-    With dlg_ui

-        .cbRegion = cREGMAN.Region

-        .cbCity = cREGMAN.City

-        .tbFName = cREGMAN.FirstName

-        .tbLName = cREGMAN.LastName

-    End With

-    

-    dlg_ui.Show

-    Worksheets(REGS_SHEET).Calculate

-    

-    If dlg_ui.Tag = vbOK Then

-        With cREGMAN

-            .Region = dlg_ui.cbRegion.Value

-            .City = dlg_ui.cbCity.Value

-            .FirstName = dlg_ui.tbFName.Value

-            .LastName = dlg_ui.tbLName.Value

-        End With

-        Set_REGMAN_Record cREGMAN

-    Else

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-Sub StoreHWInfo()

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim objHW() As Long

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    Set r = Range("HW_Number")

-    i = 1

-    For Each d In dc

-        If d.drivetype = 2 Then

-            r = d.SerialNumber

-            Set r = r.Offset(1, 0)

-            ReDim Preserve objHW(i)

-            objHW(i) = d.SerialNumber

-            i = i + 1

-        End If

-    Next

-    

-    UpdateHWRecords objHW

-End Sub

-

-Function CheckHWInfo()

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim objHW() As Long

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    

-    CheckHWInfo = False

-    

-    i = GetHWRecords(objHW)

-    If i = 0 And Range("HW_Number") <> 0 Then

-        Exit Function

-    End If

-    For Each d In dc

-        If d.drivetype = 2 Then

-            Set r = Range("HW_Number")

-            Do While r <> ""

-                If r = d.SerialNumber Then

-                    For i = 1 To UBound(objHW)

-                        If d.SerialNumber = objHW(i) Then

-                            CheckHWInfo = True

-                            Exit Function

-                        End If

-                    Next i

-                End If

-                Set r = r.Offset(1, 0)

-            Loop

-        End If

-    Next

-End Function

-<<<<<<
-======================
-dbBudget
->>>>>>
-Attribute VB_Name = "dbBudget"

-Option Explicit

-

-Public Type tBUDGET

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    bdgt_NMG As Long

-    bdgt_NFG As Long

-    sale_PLAN As Long

-End Type

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function GetAll_BDGT_RecordsByLPU_ID(ByRef allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_BDGT_RecordsByLPU_ID = dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection, allBDGT, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function Get_BDGT_Record(ByVal lpu_id As Long, ByVal ent_date As String) As tBUDGET

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    Get_BDGT_Record = dbGet_BDGT_Record(dbConnection, lpu_id, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objBDGT.ID <> 0 then updatre else insert

-Public Sub Insert_BDGT_Record(objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    If objBDGT.id <> 0 Then

-        dbUpdate_BDGT_Record dbConnection, objBDGT

-    Else

-        dbInsert_BDGT_Record dbConnection, objBDGT

-    End If

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Public Sub Delete_BDGT_Record(ByRef objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    dbDelete_BDGT_Record dbConnection, objBDGT

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_BDGT_Record(dbConnection As Object, ByVal lpu_id As Long, ent_date As String) As tBUDGET

-    

-    Dim sql As String

-    Dim objBDGT As tBUDGET

-    

-    With objBDGT

-        .id = 0

-        .lpu_id = lpu_id

-        .entry_date = ent_date

-        .bdgt_NMG = 0

-        .bdgt_NFG = 0

-        .sale_PLAN = 0

-    End With

-        

-    

-    sql = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        With objBDGT

-            .entry_date = dbRecordset("entry_date")

-            .id = dbRecordset("id")

-            .lpu_id = dbRecordset("lpu_id")

-            .bdgt_NFG = dbRecordset("bdgt_NFG")

-            .bdgt_NMG = dbRecordset("bdgt_NMG")

-            .sale_PLAN = dbRecordset("sale_PLAN")

-        End With

-    End If

-    

-    dbGet_BDGT_Record = objBDGT

-End Function

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection As Object, allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_BDGT_SQL As String

-    Dim getAll_BDGT_SQL As String

-    Dim BDGT_Count As Long

-    BDGT_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_BDGT_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        BDGT_Count = dbRecordset("BDGT_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_BDGT_RecordsbyLPU_ID = BDGT_Count

-    

-    If BDGT_Count > 0 Then

-        'we have records

-        ReDim allBDGT(1 To BDGT_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_BDGT_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpBDGT As tBUDGET

-                 With tmpBDGT

-                    .entry_date = dbRecordset("entry_date")

-                    .id = dbRecordset("id")

-                    .lpu_id = dbRecordset("lpu_id")

-                    .bdgt_NFG = dbRecordset("bdgt_NFG")

-                    .bdgt_NMG = dbRecordset("bdgt_NMG")

-                    .sale_PLAN = dbRecordset("sale_PLAN")

-                 End With

-                 

-                 allBDGT(index) = tmpBDGT

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbInsert_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "lpu_budget", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    dbRecordset("entry_date") = objBDGT.entry_date

-    dbRecordset("lpu_id") = objBDGT.lpu_id

-    dbRecordset("bdgt_NMG") = objBDGT.bdgt_NMG

-    dbRecordset("bdgt_NFG") = objBDGT.bdgt_NFG

-    dbRecordset("sale_PLAN") = objBDGT.sale_PLAN

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objBDGT.id = dbRecordset("id")

-  

-End Sub

-

-Public Sub dbUpdate_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu_budget SET " & _

-    "entry_date='" & objBDGT.entry_date & "'," & _

-    "lpu_id=" & objBDGT.lpu_id & "," & _

-    "bdgt_NMG=" & objBDGT.bdgt_NMG & "," & _

-    "bdgt_NFG=" & objBDGT.bdgt_NFG & "," & _

-    "sale_PLAN=" & objBDGT.sale_PLAN & _

-    " WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-Public Sub dbDelete_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_BDGT_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbDatabase
->>>>>>
-Attribute VB_Name = "dbDatabase"

-Option Explicit

-

-

-Sub dbOpenConnection(dbConnection As Object)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-<<<<<<
-======================
-dbLPU
->>>>>>
-Attribute VB_Name = "dbLPU"

-Option Explicit

-

-Public Type tLPU

-    id As Long

-    rep_id As Long

-    name As String

-    address As String

-    beds As Integer

-End Type

-

-Function Get_LPU_Record(ByVal lpu_id As Long) As tLPU

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_LPU_Record = dbGet_LPU_Record(dbConnection, lpu_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_LPU_byQTR(allLPU() As tLPU, ent_date As String, rep_id As Long) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_LPU_byQTR = dbGetAll_LPU_byQTR(dbConnection, allLPU, ent_date, rep_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_Record(dbConnection As Object, ByVal lpu_id As Long) As tLPU

-    

-    Dim sql As String

-    Dim objLPU As tLPU

-    

-    objLPU.id = lpu_id

-    objLPU.name = ""

-    objLPU.address = ""

-    

-    sql = "SELECT * FROM lpu WHERE id=" & lpu_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objLPU.name = dbRecordset("name")

-        objLPU.address = dbRecordset("address")

-        objLPU.rep_id = dbRecordset("rep_id")

-        objLPU.beds = dbRecordset("beds")

-    End If

-    

-    dbGet_LPU_Record = objLPU

-

-End Function

-

-Function dbGetAll_LPU_byQTR(dbConnection As Object, allLPU() As tLPU, ent_date As String, rep_id As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    Dim Where As String

-    Where = "WHERE lpu_budget.entry_date like '" & ent_date & "'" & " AND lpu.id=lpu_budget.lpu_id AND lpu.rep_id=" & rep_id

-

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu_budget, lpu " & Where

-    

-    getAll_LPU_SQL = "SELECT lpu.id as id, lpu.rep_id as rep_id, lpu.name as name, lpu.address as address, lpu.beds AS beds " & _

-    "FROM lpu, lpu_budget " & Where

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_LPU_byQTR = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-dbREP
->>>>>>
-Attribute VB_Name = "dbREP"

-'Option Explicit

-'

-'Public Type tREP

-'    FirstName As String

-'    LastName As String

-'    Region As Integer

-'    City As Integer

-'End Type

-'

-'Function GetREPRecord() As tREP

-'    Dim dbConnection As Object

-'

-'    dbOpenConnection dbConnection

-'    GetREPRecord = dbGetREPRecord(dbConnection)

-'    dbCloseConnection dbConnection

-'End Function

-'

-'Sub SetREPRecord(cUser As tREP)

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbSetREPRecord dbConnection, cUser

-'    dbCloseConnection dbConnection

-'End Sub

-'

-'Public Function dbGetREPRecord(dbConnection As Object) As tREP

-'

-'    Dim SQL As String

-'    Dim objREP As tREP

-'

-'    objREP.FirstName = ""

-'    objREP.LastName = ""

-'    objREP.Region = 0

-'    objREP.City = 0

-'    SQL = "SELECT firstname, lastname, region, city FROM " & _

-'          "rep"

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open SQL, dbConnection

-'    ', 3, 3

-'    If Not dbRecordset.BOF Then

-'

-'        objREP.FirstName = dbRecordset("firstname")

-'        objREP.LastName = dbRecordset("lastname")

-'        objREP.Region = dbRecordset("region")

-'        objREP.City = dbRecordset("city")

-'

-'    End If

-'

-'    dbGetREPRecord = objREP

-'

-'End Function

-'

-'Public Sub dbSetREPRecord(dbConnection As Object, ByRef objREP As tREP)

-'

-'    Dim DeleteSQL As String

-'    Dim InsertSQL As String

-'

-'    DeleteSQL = "DELETE FROM rep"

-'    InsertSQL = "INSERT INTO rep (firstname, lastname, region, city) VALUES (" & _

-'    "'" & objREP.FirstName & "', " & _

-'    "'" & objREP.LastName & "', " & _

-'    objREP.Region & ", " & _

-'    objREP.City & ")"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-'

-'End Sub

-'

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    CheckWorkBooksArround Wb

-End Sub

-

-

-Sub CheckWorkBooksArround(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If app.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKOnly, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-        Exit Sub

-    End If

-

-End Sub

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub GetState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-        ActiveWorkbook.DisplayDrawingObjects = xlDisplayShapes

-        

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars("Worksheet Menu Bar").Visible = False

-End Sub

-

-

-Public Sub RestoreState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars("Worksheet Menu Bar").Visible = True

-End Sub

-

-

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Export"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 620

-                        .OnAction = "cmExport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(flag As Boolean)

-    If flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars("Worksheet Menu Bar")

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmExport()

-    dbExport

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    Dim dlg As dlgAbout

-    Set dlg = New dlgAbout

-    

-    dlg.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlg.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlg.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlg.Show

-End Sub

-

-Sub cmMail2Support()

-    Dim err_description As String

-    Dim dlg_msg As dlg_Mail

-    Set dlg_msg = New dlg_Mail

-    With dlg_msg

-        .Show

-        If .Tag = vbOK Then

-            ThisWorkbook.Worksheets(VAR_SHEET).Range("ERR_MESSAGE") _

-                = .tbMessage.Text

-            ThisWorkbook.Save

-            ThisWorkbook.SendMail Recipients:="infra@i-rs.ru", Subject:=PROGRAM_NAME & " ver.:" & PROGRAM_VERSION

-            MsgBox "Сообщение об ошибке отправлено. Перезагрузите программу.", vbOKOnly, PROGRAM_NAME

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-    End With

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-'        helppath = "hh.exe " & .Path & "\Telfast.chm"

-'        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub set_work_mode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-End Sub

-

-Sub cmSetStandaloneMode()

-    set_work_mode

-    ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    Dim dlg As dlgGetPwd

-    rp = common_pwd

-    

-    Set dlg = New dlgGetPwd

-    dlg.edPwd = ""

-    dlg.Show

-    

-    If dlg.edPwd = rp Then

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-        xlRestoreView

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    Dim dlg_prn As dlgPrint

-    

-    Set dlg_prn = New dlgPrint

-    

-    With dlg_prn

-        .cbMainReport = True

-        .cbMainBudget = False

-        .cbSrcData = False

-        .cbAllSheets = False

-    

-        .Show

-    

-        If .Tag = vbCancel Then

-            Exit Sub

-        End If

-    End With

-    

-    Dim PrnIdx As Integer

-    

-    With dlg_prn

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("REP_QTR", "budget", "Final")

-    Case 1111

-        plist = Array("REP_QTR", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("REP_QTR")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Clexane bar"

-Public Const common_pwd As String = "password"

-

-

-Sub SetEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    With Application

-        .Caption = PROGRAM_NAME

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .GetState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = False

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    If cWindow.Type = xlWorkbook Then

-                        cWindow.DisplayHeadings = True

-                    End If

-                Next

-            End If

-        Next

-        .Worksheets(REP_QTR_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu (True)

-        End If

-        With mobjAppState

-            .RestoreState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Option Explicit

-

-Sub UpdateHWRecords(objHW() As Long)

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    dbUpdateHWRecords dbConnection, objHW

-    dbCloseConnection dbConnection

-End Sub

-

-Function GetHWRecords(objHW() As Long) As Integer

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    GetHWRecords = dbGetHWRecords(dbConnection, objHW)

-    dbCloseConnection dbConnection

-End Function

-

-Sub HWReset()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbInsertHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    

-    Dim dbRecordset As Object

-    Dim i As Long

-    

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "hw", dbConnection, 2, 2

-    

-    For i = 1 To UBound(objHW)

-        dbRecordset.addnew

-        dbRecordset("num") = objHW(i)

-        dbRecordset.Update

-    Next i

-    

-End Sub

-

-Sub dbUpdateHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    dbDeleteHWRecord dbConnection

-    dbInsertHWRecords dbConnection, objHW

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-dbHir
->>>>>>
-Attribute VB_Name = "dbHir"

-Option Explicit

-

-Public Type tHIRURGIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    operations_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_ambulator_clexan_40mg As Integer

-    patients_ambulator_clexan_20mg As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-    patients_stationar_clexan_40mg As Integer

-    patients_stationar_clexan_20mg As Integer

-End Type

-

-' if objHir.ID <> 0 then updatre else insert

-Sub Insert_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objHir.id <> 0 Then

-        dbUpdate_Hir_Record dbConnection, objHir

-    Else

-        dbInsert_Hir_Record dbConnection, objHir

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Hir_RecordsByLPU_ID(ByRef allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Hir_RecordsByLPU_ID = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, allHir, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Hir_Record dbConnection, objHir

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objHir.ID <> 0 then updatre else insert

-

-Sub dbInsert_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_hir", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objHir

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("operations_per_quarter") = .operations_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_ambulator_clexan_20mg") = .patients_ambulator_clexan_20mg

-        dbRecordset("patients_ambulator_clexan_40mg") = .patients_ambulator_clexan_40mg

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-        dbRecordset("patients_stationar_clexan_20mg") = .patients_stationar_clexan_20mg

-        dbRecordset("patients_stationar_clexan_40mg") = .patients_stationar_clexan_40mg

-        

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objHir.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim UpdateSQL As String

-    

-    With objHir

-        UpdateSQL = "UPDATE lpu_hir SET " & _

-            "entry_date='" & objHir.entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "operations_per_quarter=" & .operations_per_quarter & "," & _

-            "risk_percent=" & .risk_percent & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_ambulator_clexan_20mg=" & .patients_ambulator_clexan_20mg & "," & _

-            "patients_ambulator_clexan_40mg=" & .patients_ambulator_clexan_40mg & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & "," & _

-            "patients_stationar_clexan_20mg=" & .patients_stationar_clexan_20mg & "," & _

-            "patients_stationar_clexan_40mg=" & .patients_stationar_clexan_40mg & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_Hir_RecordsbyLPU_ID(dbConnection As Object, allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Hir_SQL As String

-    Dim getAll_Hir_SQL As String

-    Dim Hir_Count As Long

-    Hir_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Hir_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Hir_Count = dbRecordset("HIR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Hir_RecordsbyLPU_ID = Hir_Count

-    

-    If Hir_Count > 0 Then

-        'we have records

-        ReDim allHir(1 To Hir_Count)

-        Dim index As Integer

-        index = 1

-        dbRecordset.Open getAll_Hir_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpHir As tHIRURGIA

-                 With tmpHir

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .operations_per_quarter = dbRecordset("operations_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_ambulator_clexan_20mg = dbRecordset("patients_ambulator_clexan_20mg")

-                    .patients_ambulator_clexan_40mg = dbRecordset("patients_ambulator_clexan_40mg")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                    .patients_stationar_clexan_20mg = dbRecordset("patients_stationar_clexan_20mg")

-                    .patients_stationar_clexan_40mg = dbRecordset("patients_stationar_clexan_40mg")

-                 End With

-                 

-                 allHir(index) = tmpHir

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE ID=" & objHir.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Hir_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbTer
->>>>>>
-Attribute VB_Name = "dbTer"

-Option Explicit

-

-Public Type tTERAPIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objTer.ID <> 0 then updatre else insert

-Sub Insert_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objTer.id <> 0 Then

-        dbUpdate_Ter_Record dbConnection, objTer

-    Else

-        dbInsert_Ter_Record dbConnection, objTer

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Ter_RecordsByLPU_ID(ByRef allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Ter_RecordsByLPU_ID = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, allTer, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Ter_Record dbConnection, objTer

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objTer.ID <> 0 then updatre else insert

-

-Sub dbInsert_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_ter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objTer

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objTer.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim Update_SQL As String

-    

-    With objTer

-        Update_SQL = "UPDATE lpu_ter SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "risk_percent=" & .risk_percent & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_Ter_RecordsbyLPU_ID(dbConnection As Object, allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Ter_SQL As String

-    Dim getAll_Ter_SQL As String

-    Dim Ter_Count As Long

-    Ter_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Ter_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Ter_Count = dbRecordset("TER_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Ter_RecordsbyLPU_ID = Ter_Count

-    

-    If Ter_Count > 0 Then

-        'we have records

-        ReDim allTer(1 To Ter_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_Ter_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpTer As tTERAPIA

-                 With tmpTer

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 allTer(index) = tmpTer

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE ID=" & objTer.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Ter_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-mLPU_LIST
->>>>>>
-Attribute VB_Name = "mLPU_LIST"

-Option Explicit

-

-Public Const CINP_AREA As String = "B12"

-Public Const CLPU_NAME As Integer = 0

-Public Const CLPU_NAME1 As Integer = 1

-Public Const CLPU_NAME2 As Integer = 2

-Public Const CLPU_ID As Integer = 3

-Public Const CLPU_BEDS As Integer = 4

-Public Const CLPU_NFG As Integer = 5

-Public Const CLPU_NMG As Integer = 6

-Public Const CLPU_HIR As Integer = 7

-Public Const CLPU_TER As Integer = 8

-Public Const CLPU_CAR As Integer = 9

-Public Const CLPU_FACT As Integer = 10

-Public Const CLPU_PLAN As Integer = 11

-Public Const CLPU_PAT_LPU As Integer = 16

-Public Const CLPU_BDGT As Integer = 17

-Public Const CLPU_PAT_ALL As Integer = 16

-

-

-

-Sub EditLPU(cLPU As tLPU, ent_date As String)

-    NoFunc

-End Sub

-

-Sub Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-        End If

-    Next i

-

-End Sub

-

-Sub Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btLPU_DEL_IT()

-    Dim cLPU As tLPU

-    Dim ent_date As String

-    Dim delete_all As Integer

-    Dim dlg_del As dlg_LPU_delete

-

-    With Worksheets("LPU_LIST")

-        ent_date = .Range("ent_date")

-        cLPU.id = .getCurrentLPU_ID()

-    End With

-

-    If cLPU.id = 0 Then

-        MsgBox "Укажите удаляемый объект", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    cLPU = Get_LPU_Record(cLPU.id)

-

-    Set dlg_del = New dlg_LPU_delete

-    With dlg_del

-        .chbDeleteQTR.Value = True

-        .chbDeleteAll.Value = False

-        .lComment = ent_date & ": Удаление ЛПУ '" _

-        & cLPU.name & "', расположенного по адресу:" _

-        & cLPU.address & " не разрешено."

-        .Show

-    End With

-End Sub

-

-Sub btLPU_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        

-        Wks_select .Range("ret_addr")

-    End With

-

-End Sub

-

-

-Sub btLPU_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim lpu_id As Long

-

-    i = Worksheets(VAR_SHEET).Range("QTR_ACTION").Value

-    With Worksheets("LPU_LIST")

-        ent_date = .getEnt_date()

-

-

-        lpu_id = .getCurrentLPU_ID

-        If lpu_id = 0 And i <> 6 Then

-            i = 1

-        End If

-        Select Case i

-            Case 1

-                .SelectLPU_NAME lpu_id, ent_date

-                .Range("JUMP") = ""

-            Case 2

-                .SelectLPU_BDGT lpu_id, ent_date

-                .Range("JUMP") = "LPU_BDGT"

-            Case 3

-                .SelectLPU_HIR lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_HIR"

-

-            Case 4

-                .SelectLPU_TER lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_TER"

-

-            Case 5

-                .SelectLPU_C_ACS lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        End Select

-    End With

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-dbQTR
->>>>>>
-Attribute VB_Name = "dbQTR"

-Option Explicit

-

-Public Type tQTR

-    id As Long

-    entry_date As String

-    rep_id As Long

-    sale_PLAN As Long

-    ClxnH20mg As Long

-    ClxnH40mg As Long

-    ClxnT40mg As Long

-    ClxnC_IM As Long

-    ClxnC_ACS As Long

-End Type

-

-Function Get_QTR_Record(ByVal QTR_ID As Long) As tQTR

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_QTR_Record = dbGet_QTR_Record(dbConnection, QTR_ID)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_Record(dbConnection As Object, ByVal QTR_ID As Long) As tQTR

-    

-    Dim sql As String

-    Dim objQTR As tQTR

-    

-    With objQTR

-        .ClxnC_ACS = 0

-        .ClxnC_IM = 0

-        .ClxnH20mg = 0

-        .ClxnH40mg = 0

-        .ClxnT40mg = 0

-        .entry_date = ""

-        .id = QTR_ID

-    End With

-    

-    sql = "SELECT * FROM quarter WHERE id=" & QTR_ID

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objQTR.entry_date = dbRecordset("entry_date")

-        objQTR.rep_id = dbRecordset("rep_id")

-        objQTR.sale_PLAN = dbRecordset("sale_plan")

-        objQTR.ClxnH20mg = dbRecordset("ClxnH20mg")

-        objQTR.ClxnH40mg = dbRecordset("ClxnH40mg")

-        objQTR.ClxnT40mg = dbRecordset("ClxnT40mg")

-        objQTR.ClxnC_IM = dbRecordset("ClxnC_IM")

-        objQTR.ClxnC_ACS = dbRecordset("ClxnC_ACS")

-        objQTR.id = dbRecordset("id")

-    End If

-    

-    dbGet_QTR_Record = objQTR

-

-End Function

-

-

-Function Get_QTR_Record_by_REP(ent_date As String, rep_id As Long) As tQTR

-    Dim dbConnection As Object

-    Dim allQTR() As tQTR

-    Dim i As Long

-

-    dbOpenConnection dbConnection

-

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id)

-    If i <> 0 Then

-        Get_QTR_Record_by_REP = allQTR(1)

-    End If

-

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTR_Records_by_REP(ByRef all_QTR() As tQTR, ent_date As String, rep_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-

-    GetAll_QTR_Records_by_REP = dbGetAll_QTR_Records_By_REP(dbConnection, all_QTR, ent_date, rep_id)

-

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGetAll_QTR_Records_By_REP(dbConnection As Object, all_QTR() As tQTR, ent_date As String, rep_id As Long) As Integer

-

-    Dim getCount_QTR_SQL As String

-    Dim getAll_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter " & _

-    "WHERE entry_date like '" & ent_date & "' AND rep_id=" & rep_id

-    getAll_QTR_SQL = "SELECT * FROM quarter " & _

-    "WHERE entry_date like '" & ent_date & "' AND rep_id=" & rep_id & " ORDER BY entry_date"

-

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-

-    dbRecordset.Close

-

-    dbGetAll_QTR_Records_By_REP = QTR_Count

-

-    If QTR_Count > 0 Then

-        'we have records

-        ReDim all_QTR(1 To QTR_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTR_SQL, dbConnection

-

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTR As tQTR

-                 With tmp_QTR

-                    .entry_date = dbRecordset("entry_date")

-                    .rep_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .ClxnH20mg = dbRecordset("ClxnH20mg")

-                    .ClxnH40mg = dbRecordset("ClxnH40mg")

-                    .ClxnT40mg = dbRecordset("ClxnT40mg")

-                    .ClxnC_IM = dbRecordset("ClxnC_IM")

-                    .ClxnC_ACS = dbRecordset("ClxnC_ACS")

-                    .id = dbRecordset("id")

-                 End With

-

-                 all_QTR(index) = tmp_QTR

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-cdbQTR
->>>>>>
-Attribute VB_Name = "cdbQTR"

-Option Explicit

-

-Public Type tQTR_COMMON

-    qtr As tQTR

-    i_lcd As Long           ' число ЛПУ в СПИСКЕ

-    lcd() As tLPU_COMMON    ' список ЛПУ

-    c_beds As Long          ' сумма коек

-    c_bdgt_NFG As Long      ' общий бюджет на НФГ

-    c_bdgt_NMG As Long      ' общий бюджет на НМГ

-    c_bdgt_LPU As Long      ' общий бюджет на гепарины

-    c_sale_PLAN As Long     ' план продаж репа

-    c_sale_ALL As Long      ' продажи

-    c_sale_HIR As Long      ' в хирургии

-    c_sale_TER  As Long     ' в терапии

-    c_sale_CRD  As Long     ' в кардиологии

-    c_pat_HIR   As Long     ' пациенты

-    c_pat_TER   As Long     '

-    c_pat_CRD   As Long     '

-    c_pat_ALL   As Long     '

-    c_pat_LPU   As Long     ' Всего операций

-End Type

-

-Function Get_QTR_CommonList_by_REP(ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_QTR_CommonList_by_REP = dbGet_QTR_CommonList_by_REP(dbConnection, qcd, ent_date, rep_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_CommonList_by_REP(dbConnection As Object, ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim allQTR() As tQTR

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id)

-    dbGet_QTR_CommonList_by_REP = i

-    If i > 0 Then

-        ReDim qcd(i)

-        For i = 1 To UBound(allQTR)

-            With qcd(i)

-                .qtr = allQTR(i)

-                .c_beds = 0

-                .c_bdgt_NFG = 0

-                .c_bdgt_NMG = 0

-                .c_bdgt_LPU = 0

-                .c_sale_PLAN = 0

-                .c_pat_HIR = 0

-                .c_pat_TER = 0

-                .c_pat_CRD = 0

-                .c_pat_ALL = 0

-                .c_sale_HIR = 0

-                .c_sale_TER = 0

-                .c_sale_CRD = 0

-                .c_sale_ALL = 0

-                .c_pat_LPU = 0

-                

-                j = dbGet_LPU_CommonQTR(dbConnection, .lcd, .qtr)

-                .i_lcd = j

-                If j > 0 Then

-                    For j = 1 To UBound(.lcd)

-                        .c_beds = .c_beds + .lcd(j).lpu.beds

-                        .c_bdgt_NFG = .c_bdgt_NFG + .lcd(j).bdgt.bdgt_NFG

-                        .c_bdgt_NMG = .c_bdgt_NMG + .lcd(j).bdgt.bdgt_NMG

-                        .c_bdgt_LPU = .c_bdgt_LPU + .lcd(j).bdgt_LPU

-                        .c_sale_PLAN = .c_sale_PLAN + .lcd(j).bdgt.sale_PLAN

-                        .c_pat_HIR = .c_pat_HIR + .lcd(j).pat_HIR

-                        .c_pat_TER = .c_pat_TER + .lcd(j).pat_TER

-                        .c_pat_CRD = .c_pat_CRD + .lcd(j).pat_CRD

-                        .c_pat_ALL = .c_pat_ALL + .lcd(j).pat_ALL

-                        .c_sale_HIR = .c_sale_HIR + .lcd(j).sale_HIR

-                        .c_sale_TER = .c_sale_TER + .lcd(j).sale_TER

-                        .c_sale_CRD = .c_sale_CRD + .lcd(j).sale_CRD

-                        .c_sale_ALL = .c_sale_ALL + .lcd(j).sale_ALL

-                        .c_pat_LPU = .c_pat_LPU + .lcd(j).pat_LPU

-                    Next j

-                    

-                End If

-            End With

-        Next i

-    End If

-End Function

-

-Function GetLastQtr() As String

-    Dim s As String

-    Dim r As Range

-    Set r = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Do While r.Cells(1, 1) <> ""

-        s = r.Cells(1, 1)

-        Set r = r.Cells.Offset(1, 0)

-    Loop

-    GetLastQtr = s

-End Function

-

-Function GetNextQTR(ent_date As String) As String

-    Dim rd As Range

-    Dim idx As Integer

-    Dim b As Variant

-    Dim dlg As dlg_newQTR

-    Set dlg = New dlg_newQTR

-    

-    If ent_date = "" Then

-        Dim ir As Variant

-        idx = 0

-        dlg.Show

-        b = dlg.Tag

-            

-        If IsNumeric(b) Then

-            GetNextQTR = dlg.cbQTR

-        Else

-            GetNextQTR = ""

-        End If

-    Else

-        Set rd = Worksheets(VAR_SHEET).Range("Date_Lst")

-        idx = WorksheetFunction.Match(ent_date, rd, 0)

-        GetNextQTR = WorksheetFunction.index(rd, idx + 1, 1)

-    End If

-End Function

-<<<<<<
-======================
-mRestView
->>>>>>
-Attribute VB_Name = "mRestView"

-Option Explicit

-

-Sub xlRestoreView()

-Attribute xlRestoreView.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute xlRestoreView.VB_ProcData.VB_Invoke_Func = " \n14"

-    With Application

-        .CommandBars("Standard").Visible = True

-        .CommandBars("Formatting").Visible = True

-        .DisplayFormulaBar = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .DisplayStatusBar = True

-    End With

-End Sub

-<<<<<<
-======================
-dlg_newQTR
->>>>>>
-Attribute VB_Name = "dlg_newQTR"

-Attribute VB_Base = "0{24511B6B-2B0B-44FC-89C5-FF43FB41B0A0}{5414F65F-196D-435B-AD61-075BCD7AFFDF}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mDec2TS
->>>>>>
-Attribute VB_Name = "mDec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-CHRT_LPU_BBL
->>>>>>
-Attribute VB_Name = "CHRT_LPU_BBL"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PAT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PAT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-<<<<<<
-======================
-CHRT_PAT_LPU
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_nextQTR
->>>>>>
-Attribute VB_Name = "dlg_nextQTR"

-Attribute VB_Base = "0{1644D09B-FC49-43ED-8016-8B6C094F4CFD}{73243B9F-5178-4882-A692-756A3F34EABA}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-cdbLPU
->>>>>>
-Attribute VB_Name = "cdbLPU"

-Option Explicit

-

-Public Type tLPU_COMMON

-    lpu As tLPU

-    bdgt As tBUDGET

-    i_hir As Long

-    hir() As tHIRURGIA

-    i_ter As Long

-    ter() As tTERAPIA

-    i_ACS As Long

-    ACS() As tACS

-    bdgt_LPU As Long

-    sale_HIR As Long

-    sale_TER As Long

-    sale_CRD As Long

-    sale_ALL As Long

-    pat_HIR As Long

-    pat_TER As Long

-    pat_CRD As Long

-    pat_ALL As Long     ' Сумма всех пациентов на клексане

-    pat_LPU As Long     ' Число потенциальных пациентов для продаж клексана

-End Type

-

-Function Get_LPU_CommonQTR(ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    Get_LPU_CommonQTR = dbGet_LPU_CommonQTR(dbConnection, lcd, objQTR)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_CommonQTR(dbConnection As Object, ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    i = dbGetAll_LPU_byQTR(dbConnection, allLPU, objQTR.entry_date, objQTR.rep_id)

-    dbGet_LPU_CommonQTR = i

-    If i > 0 Then

-        ReDim lcd(i)

-        For i = 1 To UBound(allLPU)

-            dbGet_LPU_Common dbConnection, lcd(i), allLPU(i), objQTR

-        Next i

-    End If

-End Function

-

-Sub Get_LPU_Common(ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    dbGet_LPU_Common dbConnection, lcd, cLPU, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbGet_LPU_Common(dbConnection As Object, ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-

-    lcd.lpu = cLPU

-    lcd.bdgt = dbGet_BDGT_Record(dbConnection, cLPU.id, objQTR.entry_date)

-    lcd.i_hir = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, lcd.hir, cLPU.id, objQTR.entry_date)

-    lcd.i_ter = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, lcd.ter, cLPU.id, objQTR.entry_date)

-    lcd.i_ACS = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, lcd.ACS, cLPU.id, objQTR.entry_date)

-    With lcd

-        .bdgt_LPU = .bdgt.bdgt_NFG + .bdgt.bdgt_NMG

-        .pat_LPU = 0

-        If .i_hir > 0 Then

-            .pat_HIR = .hir(1).patients_ambulator_clexan + .hir(1).patients_stationar_clexan

-            .sale_HIR = objQTR.ClxnH20mg * (.hir(1).patients_ambulator_clexan_20mg + .hir(1).patients_stationar_clexan_20mg)

-            .sale_HIR = .sale_HIR + objQTR.ClxnH40mg * (.hir(1).patients_ambulator_clexan_40mg + .hir(1).patients_stationar_clexan_40mg)

-            .pat_LPU = .pat_LPU + .hir(1).operations_per_quarter

-        End If

-        If .i_ter > 0 Then

-            .pat_TER = .ter(1).patients_ambulator_clexan + .ter(1).patients_stationar_clexan

-            .sale_TER = .pat_TER * objQTR.ClxnT40mg

-            .pat_LPU = .pat_LPU + .ter(1).patients_per_quarter

-        End If

-        If .i_ACS > 0 Then

-            .pat_CRD = .ACS(1).patients_stationar_clexan

-            .sale_CRD = .pat_CRD * objQTR.ClxnC_ACS

-            .pat_LPU = .pat_LPU + .ACS(1).patients_per_quarter

-        End If

-        .pat_ALL = .pat_HIR + .pat_TER + .pat_CRD

-        .sale_ALL = .sale_HIR + .sale_TER + .sale_CRD

-    End With

-End Sub

-

-<<<<<<
-======================
-CHRT_PIE
->>>>>>
-Attribute VB_Name = "CHRT_PIE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PLN_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PLN_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_BDGT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_BDGT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_LPU_delete
->>>>>>
-Attribute VB_Name = "dlg_LPU_delete"

-Attribute VB_Base = "0{8864A941-8AE3-4960-A65E-E5DC897679D4}{27B98C83-0140-4FB2-A117-ECEDB41A834D}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlg_Mail
->>>>>>
-Attribute VB_Name = "dlg_Mail"

-Attribute VB_Base = "0{8B7F84B3-4C60-489E-BA7D-9D25B479920C}{02D0D5BB-CB5C-44ED-B18C-0FA89CF34D3A}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dbREP_id
->>>>>>
-Attribute VB_Name = "dbREP_id"

-Public Type tREPID

-    rep_id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function GetAll_REPID_Records_by_QTR(ByRef all_REPID() As tREPID, ent_date As String) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_REPID_Records_by_QTR = dbGetAll_REPID_Records_by_QTR(dbConnection, all_REPID, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-Function Get_REPID_Record(id As Long) As tREPID

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REPID_Record = dbGet_REPID_Record(dbConnection, id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_REPID_Records(ByRef all_REPID() As tREPID) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_REPID_Records = dbGetAll_REPID_Records(dbConnection, all_REPID)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function dbGet_REPID_Record(dbConnection As Object, id As Long) As tREPID

-    

-    Dim sql As String

-    Dim objREPID As tREPID

-    

-    objREPID.FirstName = ""

-    objREPID.LastName = ""

-    objREPID.Region = 0

-    objREPID.City = 0

-    sql = "SELECT rep_id, firstname, lastname, region, city FROM " & _

-          "rep WHERE rep_id=" & id

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREPID.rep_id = dbRecordset("rep_id")

-        objREPID.FirstName = dbRecordset("firstname")

-        objREPID.LastName = dbRecordset("lastname")

-        objREPID.Region = dbRecordset("region")

-        objREPID.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REPID_Record = objREPID

-        

-End Function

-

-Function dbGetAll_REPID_Records_by_QTR(dbConnection As Object, ByRef all_REPID() As tREPID, ent_date As String) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    Dim Where As String

-    

-    REPID_Count = 0

-    Where = " WHERE lpu_budget.entry_date like '" & ent_date & "' " & _

-        "AND rep.rep_id=lpu.rep_id AND lpu.id=lpu_budget.lpu_id"

-    

-    

-    getAll_REPID_SQL = "SELECT distinct rep.* FROM rep, lpu, lpu_budget" & Where

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM (" & getAll_REPID_SQL & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records_by_QTR = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Function dbGetAll_REPID_Records(dbConnection As Object, ByRef all_REPID() As tREPID) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    REPID_Count = 0

-    

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM rep"

-    getAll_REPID_SQL = "SELECT * FROM rep"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-cdbExport
->>>>>>
-Attribute VB_Name = "cdbExport"

-Option Explicit

-

-Function GetDBSN() As String

-    Dim n As Long

-    Randomize Timer

-    n = Int((100000000 - 1000000 + 1) * Rnd + 1000000)

-    GetDBSN = Dec2ThirtySix(n)

-End Function

-

-Sub dbExport()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim old_file As String

-    

-    On Error GoTo ErrHandler

-    

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    old_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & "*.*"

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & GetDBSN() & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.DeleteFile old_file, True

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Данные экспортированы в файл:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для передачи", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-Exit Sub

-

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-<<<<<<
-======================
-mRegs
->>>>>>
-Attribute VB_Name = "mRegs"

-Option Explicit

-

-Function GetRegionName(idx As Integer) As String

-    GetRegionName = Worksheets(REGS_SHEET).Range("LST_REGIONS").Cells(idx + 1, 1).Text

-End Function

-

-Function GetCityName(idx_reg As Integer, idx_city As Integer) As String

-    GetCityName = Worksheets(REGS_SHEET).Range("CITY_TABLES").Offset(idx_city + 1, idx_reg * 2).Text

-End Function

-

-Sub testReg()

-    Dim r As Integer

-    Dim c As Integer

-    Dim s As String

-    

-    r = 3

-    c = 3

-    s = GetRegionName(r)

-    s = s & ", " & GetCityName(r, c)

-    MsgBox s

-End Sub

-

-<<<<<<
-======================
-RM_QTR
->>>>>>
-Attribute VB_Name = "RM_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CRGN_QT As Integer = 0

-Const CRGN_PLN As Integer = 2

-Const CRGN_FCT As Integer = 3

-Const CRGN_BDG As Integer = 4

-Const CRGN_LPU As Integer = 5

-Const CRGN_REP As Integer = 6

-Const CRGN_HIR As Integer = 7

-Const CRGN_TER As Integer = 8

-Const CRGN_CRD As Integer = 9

-Const CRGN_CLXN_BDG As Integer = 10

-Const CRGN_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub update_history()

-    Dim objRGN() As tREGION

-    Dim i As Long

-    Dim r As Range

-    Dim cRMan As tREGMAN

-

-    cRMan = Get_REGMAN_Record

-    

-    Range("D4") = cRMan.LastName

-    Range("D5") = cRMan.FirstName

-

-    Range("H4") = GetRegionName(cRMan.Region)

-    

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetRGN_COMM_DATA(objRGN)

-    

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objRGN)

-            r.Offset(i - 1, CRGN_QT) = objRGN(i).ent_date

-            r.Offset(i - 1, CRGN_FCT) = objRGN(i).total_SALE

-            r.Offset(i - 1, CRGN_PLN) = objRGN(i).sale_PLAN

-            r.Offset(i - 1, CRGN_BDG) = objRGN(i).total_BDGT

-            r.Offset(i - 1, CRGN_LPU) = objRGN(i).total_LPU

-            r.Offset(i - 1, CRGN_REP) = objRGN(i).total_REP

-            r.Offset(i - 1, CRGN_HIR) = objRGN(i).total_HIR

-            r.Offset(i - 1, CRGN_TER) = objRGN(i).total_TER

-            r.Offset(i - 1, CRGN_CRD) = objRGN(i).total_ACS

-            If objRGN(i).total_BDGT <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_BDG) = objRGN(i).total_SALE / objRGN(i).total_BDGT

-            End If

-            If objRGN(i).total_BDGT_NMG <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_NMG) = objRGN(i).total_SALE / objRGN(i).total_BDGT_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRGN_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRM_QtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR_RM

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR_RM

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR_RM

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = RM_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CRGN_QT + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    If r = "" Then

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = currRange.address

-        With Worksheets("REP_LIST")

-            .Range("ret_addr") = "RM_QTR"

-            .Range("ent_date") = r

-            .Range("VIEW_ONLY") = True

-        End With

-    End If

-    Cancel = True

-    btRM_QTR_Do_IT

-End Sub

-

-<<<<<<
-======================
-dbREG_MAN
->>>>>>
-Attribute VB_Name = "dbREG_MAN"

-Option Explicit

-

-Public Type tREGMAN

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function Get_REGMAN_Record() As tREGMAN

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REGMAN_Record = dbGet_REGMAN_Record(dbConnection)

-    dbCloseConnection dbConnection

-End Function

-

-Sub Set_REGMAN_Record(cREGMAN As tREGMAN)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbSet_REGMAN_Record dbConnection, cREGMAN

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_REGMAN_Record(dbConnection As Object) As tREGMAN

-    

-    Dim sql As String

-    Dim objREGMAN As tREGMAN

-    

-    objREGMAN.FirstName = ""

-    objREGMAN.LastName = ""

-    objREGMAN.Region = 0

-    objREGMAN.City = 0

-    sql = "SELECT firstname, lastname, region, city FROM " & _

-          "reg_man"

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREGMAN.FirstName = dbRecordset("firstname")

-        objREGMAN.LastName = dbRecordset("lastname")

-        objREGMAN.Region = dbRecordset("region")

-        objREGMAN.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REGMAN_Record = objREGMAN

-        

-End Function

-

-Public Sub dbSet_REGMAN_Record(dbConnection As Object, ByRef objREGMAN As tREGMAN)

-  

-    Dim DeleteSQL As String

-    Dim InsertSQL As String

-    

-    DeleteSQL = "DELETE FROM reg_man"

-    InsertSQL = "INSERT INTO reg_man (firstname, lastname, region, city) VALUES (" & _

-    "'" & objREGMAN.FirstName & "', " & _

-    "'" & objREGMAN.LastName & "', " & _

-    objREGMAN.Region & ", " & _

-    objREGMAN.City & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    dbRecordset.Open InsertSQL, dbConnection

-       

-End Sub

-

-

-

-<<<<<<
-======================
-dbDatabaseMerge
->>>>>>
-Attribute VB_Name = "dbDatabaseMerge"

-Option Explicit

-

-Public Type tDBFIELD

-    name As String

-End Type

-

-Public Type tDBTABLE

-    name As String

-    field() As tDBFIELD

-End Type

-

-

-Function dbGetConnection(dbAccessFileFullPath As String) As Object

-    Dim dbConnection As Object

-    Dim dbAccessFilePasswd As String

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFileFullPath & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    Set dbGetConnection = dbConnection

-End Function

-

-Sub dbCloseOpenedConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteOpenedSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-Function dbMergeREP(from_dbConnection As Object, to_dbConnection As Object) As Long

-

-    Dim getRecordset As Object

-    Dim getREPData_SQL As String

-    Dim REP_fn As String

-    Dim REP_ln As String

-    Dim REP_region As String

-    Dim REP_city As String

-

-

-    getREPData_SQL = "SELECT * FROM rep"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getREPData_SQL, from_dbConnection

-        

-        If Not getRecordset.BOF Then

-            REP_fn = getRecordset("firstname")

-            REP_ln = getRecordset("lastname")

-            REP_city = getRecordset("city")

-            REP_region = getRecordset("region")

-        Else

-            MsgBox "There is no information about rep! This database cannot be merged!!!"

-            dbMergeREP = -1

-            Exit Function

-        End If

-    

-    Dim insertRecordset As Object

-    Set insertRecordset = CreateObject("ADODB.Recordset")

-        

-    insertRecordset.Open "rep", to_dbConnection, 2, 2

-    insertRecordset.addnew

-        

-    insertRecordset("firstname") = REP_fn

-    insertRecordset("lastname") = REP_ln

-    insertRecordset("region") = REP_region

-    insertRecordset("city") = REP_city

-    insertRecordset.Update

-    insertRecordset.MoveLast

-    'new ID

-    

-    dbMergeREP = insertRecordset("rep_id")

-    

-End Function

-

-Sub dbMergeLPU(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getLPU_SQL As String

-    Dim getRecordset As Object

-    Dim idx As Long

-    idx = 1

-    

-    getLPU_SQL = "SELECT * FROM lpu"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getLPU_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            ReDim Preserve objLPU(1 To idx)

-            objLPU(idx).old_lpu_id = getRecordset("id")

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "lpu", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("name") = getRecordset("name")

-            insRS("address") = getRecordset("address")

-            insRS("beds") = getRecordset("beds")

-            insRS.Update

-            insRS.MoveLast

-            'new ID

-            

-            objLPU(idx).new_lpu_id = insRS("id")

-                        

-            idx = idx + 1

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about LPU! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-

-Sub dbMergeLPURelated(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object)

-

-    ' 6 tables to change

-    Dim tables(1 To 5) As tDBTABLE

-    

-    'lpu budget

-    tables(1).name = "lpu_budget"

-    ReDim tables(1).field(1 To 4)

-    

-    tables(1).field(1).name = "entry_date"

-    tables(1).field(2).name = "bdgt_NMG"

-    tables(1).field(3).name = "bdgt_NFG"

-    tables(1).field(4).name = "sale_PLAN"

-    

-    'lpu hir

-    tables(2).name = "lpu_hir"

-    ReDim tables(2).field(1 To 13)

-    

-    tables(2).field(1).name = "entry_date"

-    tables(2).field(2).name = "operations_per_quarter"

-    tables(2).field(3).name = "risk_percent"

-    tables(2).field(4).name = "patients_with_risk_ON"

-    tables(2).field(5).name = "patients_ambulator"

-    tables(2).field(6).name = "patients_ambulator_nmg"

-    tables(2).field(7).name = "patients_ambulator_clexan"

-    tables(2).field(8).name = "patients_ambulator_clexan_40mg"

-    tables(2).field(9).name = "patients_ambulator_clexan_20mg"

-    tables(2).field(10).name = "patients_stationar_nmg"

-    tables(2).field(11).name = "patients_stationar_clexan"

-    tables(2).field(12).name = "patients_stationar_clexan_40mg"

-    tables(2).field(13).name = "patients_stationar_clexan_20mg"

-    

-    

-    'lpu acs

-    tables(3).name = "lpu_acs"

-    ReDim tables(3).field(1 To 5)

-    

-    tables(3).field(1).name = "entry_date"

-    tables(3).field(2).name = "patients_with_geparins"

-    tables(3).field(3).name = "patients_per_quarter"

-    tables(3).field(4).name = "patients_stationar_nmg"

-    tables(3).field(5).name = "patients_stationar_clexan"

-    

-    'lpu acs

-    tables(4).name = "lpu_im"

-    ReDim tables(4).field(1 To 5)

-    

-    tables(4).field(1).name = "entry_date"

-    tables(4).field(2).name = "patients_with_geparins"

-    tables(4).field(3).name = "patients_per_quarter"

-    tables(4).field(4).name = "patients_stationar_nmg"

-    tables(4).field(5).name = "patients_stationar_clexan"

-    

-    

-    'lpu acs

-    tables(5).name = "lpu_ter"

-    ReDim tables(5).field(1 To 9)

-    

-    tables(5).field(1).name = "entry_date"

-    tables(5).field(2).name = "patients_per_quarter"

-    tables(5).field(3).name = "risk_percent"

-    tables(5).field(4).name = "patients_with_risk_ON"

-    tables(5).field(5).name = "patients_ambulator"

-    tables(5).field(6).name = "patients_ambulator_nmg"

-    tables(5).field(7).name = "patients_ambulator_clexan"

-    tables(5).field(8).name = "patients_stationar_nmg"

-    tables(5).field(9).name = "patients_stationar_clexan"

-    

-    

-    

-    Dim tbl_idx As Integer

-    

-    For tbl_idx = 1 To UBound(tables)

-        

-        Dim getSQL As String

-        Dim getRS As Object

-        

-        

-        

-        Set getRS = CreateObject("ADODB.Recordset")

-        

-        getSQL = "SELECT * FROM " & tables(tbl_idx).name

-        getRS.Open getSQL, from_db

-        

-        If Not getRS.BOF Then

-            Do While Not getRS.EOF

-                Dim insRS As Object

-                Set insRS = CreateObject("ADODB.Recordset")

-                

-                insRS.Open tables(tbl_idx).name, to_db, 2, 2

-                insRS.addnew

-                Dim fld_idx As Integer

-    

-                    For fld_idx = 1 To UBound(tables(tbl_idx).field)

-                        insRS(tables(tbl_idx).field(fld_idx).name) = getRS(tables(tbl_idx).field(fld_idx).name)

-                        insRS("lpu_id") = findNewLPU_IDByOld(objLPU, getRS("lpu_id"))

-                    Next fld_idx

-                    

-                insRS.Update

-                insRS.MoveLast

-                getRS.MoveNext

-            Loop

-        End If

-        

-        

-    Next tbl_idx

-

-End Sub

-

-Function findNewLPU_IDByOld(objLPU() As tLPUCONVERTION, old_id As Long)

-

-Dim i As Integer

-For i = 1 To UBound(objLPU)

-    If objLPU(i).old_lpu_id = old_id Then

-        findNewLPU_IDByOld = objLPU(i).new_lpu_id

-        Exit Function

-    End If

-Next i

-

-findNewLPU_IDByOld = -1

-End Function

-

-

-

-

-

-Sub dbMergeQTR(from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getQTR_SQL As String

-    Dim getRecordset As Object

-    

-    getQTR_SQL = "SELECT * FROM quarter"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getQTR_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "quarter", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("entry_date") = getRecordset("entry_date")

-            insRS("sale_plan") = getRecordset("sale_plan")

-            insRS("ClxnH20mg") = getRecordset("ClxnH20mg")

-            insRS("ClxnH40mg") = getRecordset("ClxnH40mg")

-            insRS("ClxnT40mg") = getRecordset("ClxnT40mg")

-            insRS("ClxnC_IM") = getRecordset("ClxnC_IM")

-            insRS("ClxnC_ACS") = getRecordset("ClxnC_ACS")

-            

-            

-            insRS.Update

-            

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about quarter budget! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-dbMerge
->>>>>>
-Attribute VB_Name = "dbMerge"

-Option Explicit

-

-Public Type tLPUCONVERTION

-    old_lpu_id As Long

-    new_lpu_id As Long

-End Type

-

-

-

-Sub Merge_Clear_All_Data(access_file_full_path As String)

-    

-    Dim db As Object

-    Dim tables_to_clear() As String

-    On Error GoTo ErrHandler

-    

-    ReDim tables_to_clear(1 To 8)

-    tables_to_clear(1) = "rep"

-    tables_to_clear(2) = "lpu"

-    tables_to_clear(3) = "lpu_budget"

-    tables_to_clear(4) = "lpu_hir"

-    tables_to_clear(5) = "lpu_ter"

-    tables_to_clear(6) = "lpu_acs"

-    tables_to_clear(7) = "lpu_im"

-    tables_to_clear(8) = "quarter"

-    

-    Set db = dbGetConnection(access_file_full_path)

-

-    Dim i As Integer

-    

-    For i = 1 To UBound(tables_to_clear)

-        

-        If tables_to_clear(i) <> "" Then

-            Dim Clear_SQL As String

-            Clear_SQL = "DELETE FROM " & tables_to_clear(i)

-            dbExecuteOpenedSQL db, Clear_SQL

-        Else

-            'do nothing or show message

-        End If

-    Next i

-    

-    dbCloseOpenedConnection db

-    Set db = Nothing

-    

-'    Dim Engine As Object

-'    Set Engine = CreateObject("JRO.JetEngine")

-'    Engine.CompactDatabase "Password=password;Data Source=" & access_file_full_path, _

-'    "Password=password;Data Source=c:\tmp\1.mdb"

-    

-Exit Sub

-

-ErrHandler:

-    MsgBox "something wrong: " & err.Description

-    Resume Next

-    

-End Sub

-

-Function MergeREP(from_file As String, to_file As String) As Long

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    Dim new_rep_id As Long

-

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    MergeREP = dbMergeREP(db1, db2)

-    'MsgBox "new rep ID is " & new_rep_id

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Function

-

-Sub MergeQTR(from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeQTR db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-

-Sub MergeLPU(objLPU() As tLPUCONVERTION, from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeLPU objLPU, db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-Sub MergeLPURelated(objLPU() As tLPUCONVERTION, from_file As String, to_file As String)

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    dbMergeLPURelated objLPU, db1, db2

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-

-End Sub

-

-Sub MergeGlobal(rep_files() As String, rm_file As String)

-

-    Dim i As Integer

-    'clear output file content

-    Merge_Clear_All_Data rm_file

-    

-    For i = 1 To UBound(rep_files)

-        

-        Dim rep_file As String

-        'setup input and output files

-        rep_file = rep_files(i)

-        

-        Dim new_rep_id As Long

-        ' insert REP data and get new rep_id

-        new_rep_id = MergeREP(rep_file, rm_file)

-        

-        Dim objLPU() As tLPUCONVERTION

-        'insert all LPU using new generated rep_id

-        'and populate objLPU old->new relation object

-        

-        MergeLPU objLPU, rep_file, rm_file, new_rep_id

-        'insert quarter data using new rep_id

-        MergeQTR rep_file, rm_file, new_rep_id

-        

-        

-        ' and.... insert all another data (5 tables excl version and hw)

-        'using objLPU old->new relation object

-        MergeLPURelated objLPU, rep_file, rm_file

-    

-    

-    Next i

-    

-End Sub

-

-Function GetDBList(MyPath As String, ByRef dblist() As String) As Integer

-    Dim i As Integer

-    Dim MyName, MyMask

-    MyMask = MyPath & PROGRAM_IMPORTNAME & PROGRAM_DATAEXT

-    i = 0

-    MyName = Dir(MyMask)      ' Retrieve the first entry.

-    Do While MyName <> ""    ' Start the loop.

-        ' Ignore the current directory and the encompassing directory.

-        If MyName <> "." And MyName <> ".." Then

-            ' Use bitwise comparison to make sure MyName is a directory.

-            i = i + 1

-            ReDim Preserve dblist(i)

-            dblist(i) = MyPath & MyName

-        End If

-        MyName = Dir    ' Get next entry.

-    Loop

-    GetDBList = i

-End Function

-

-Sub test_import()

-    Dim MyPath As String

-    Dim flist() As String

-    Dim i As Integer

-    MyPath = "g:\"

-    i = GetDBList(MyPath, flist)

-    If i > 0 Then

-        MergeGlobal flist, GetWBPath(ThisWorkbook.FullName) & "clexane-rm.mdb"

-    End If

-End Sub

-<<<<<<
-======================
-dbxyz_test
->>>>>>
-Attribute VB_Name = "dbxyz_test"

-Option Explicit

-

-Sub mrg_main()

-    Dim rep_files(1 To 2) As String

-    Dim rm_file As String

-    

-    'setup input and output files

-    rep_files(1) = "e:\work\aventis\clexane-mr1.mdb"

-    rep_files(2) = "e:\work\aventis\clexane-mr2.mdb"

-    

-    'setup output file

-    rm_file = "e:\work\aventis\clexane-rm.mdb"

-    

-    MergeGlobal rep_files, rm_file

-End Sub

-

-Sub ttt()

-    Dim rcd() As tREPID_COMMON

-    Dim i As Long

-    i = Get_REP_CommonList_by_QTR(rcd, "2003-III")

-End Sub

-

-Sub getallreps()

-    Dim i As Integer

-    Dim j As Integer

-    Dim k As Integer

-    Dim s As String

-    

-    Dim allREPID() As tREPID

-    Dim allQTRREP() As tQTR

-    Dim allLPU() As tLPU

-    

-    i = GetAll_REPID_Records(allREPID)

-    

-    If i > 0 Then

-        For i = 1 To UBound(allREPID)

-            j = GetAll_QTR_Records_by_REP(allQTRREP, "%", allREPID(i).rep_id)

-            If j > 0 Then

-                For j = 1 To UBound(allREPID)

-                    k = GetAll_LPU_byQTR(allLPU, allQTRREP(j).entry_date, allREPID(i).rep_id)

-                    If k > 0 Then

-                        For k = 1 To UBound(allLPU)

-                            MsgBox allLPU(k).name

-                        Next k

-                    End If

-                Next j

-            End If

-        Next i

-    End If

-End Sub

-

-<<<<<<
-======================
-dbQTR_RM
->>>>>>
-Attribute VB_Name = "dbQTR_RM"

-Option Explicit

-

-Public Type tQTRRM

-    id As Long

-    entry_date As String

-    rm_id As Long

-    sale_PLAN As Long

-End Type

-

-

-Sub Insert_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objQTRRM.id <> 0 Then

-        dbUpdate_QTRRM_Record dbConnection, objQTRRM

-    Else

-        dbInsert_QTRRM_Record dbConnection, objQTRRM

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-Function Get_QTRRM_Record(ent_date As String) As tQTRRM

-    Dim dbConnection As Object

-    Dim allQTRRM() As tQTRRM

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    i = dbGetAll_QTRRM_Records(dbConnection, allQTRRM, ent_date)

-    If i <> 0 Then

-        Get_QTRRM_Record = allQTRRM(1)

-    End If

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTRRM_Records(ByRef all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_QTRRM_Records = dbGetAll_QTRRM_Records(dbConnection, all_QTRRM, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_QTRRM_Record dbConnection, objQTRRM

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objQTRRM.ID <> 0 then updatre else insert

-Sub dbInsert_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "quarter_rm", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objQTRRM

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("sale_plan") = .sale_PLAN

-        dbRecordset("rm_id") = .rm_id

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objQTRRM.id = dbRecordset("id")

-

-End Sub

-

-Sub dbUpdate_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim Update_SQL As String

-    

-    With objQTRRM

-        Update_SQL = "UPDATE quarter_rm SET " & _

-            "entry_date='" & .entry_date & "'" & "," & _

-            "rm_id=" & .rm_id & "," & _

-            "sale_plan=" & .sale_PLAN & "," & _

-            " WHERE id=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if ent_date = % then all_records

-Function dbGetAll_QTRRM_Records(dbConnection As Object, all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    

-    Dim getCount_QTRRM_SQL As String

-    Dim getAll_QTRRM_SQL As String

-    Dim QTRRM_Count As Long

-    QTRRM_Count = 0

-    

-    getCount_QTRRM_SQL = "SELECT COUNT(*) AS QTRRM_TOTAL FROM quarter_rm WHERE entry_date like '" & ent_date & "'"

-    getAll_QTRRM_SQL = "SELECT * FROM quarter_rm WHERE entry_date like '" & ent_date & "' ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTRRM_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTRRM_Count = dbRecordset("QTRRM_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_QTRRM_Records = QTRRM_Count

-    

-    If QTRRM_Count > 0 Then

-        'we have records

-        ReDim all_QTRRM(1 To QTRRM_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTRRM_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTRRM As tQTRRM

-                 With tmp_QTRRM

-                    .entry_date = dbRecordset("entry_date")

-                    .rm_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .id = dbRecordset("id")

-                 End With

-                 

-                 all_QTRRM(index) = tmp_QTRRM

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM quarter_rm " & _

-    "WHERE id=" & objQTRRM.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-    

-    'delete related budget entries

-    MsgBox "remember delete related"

-'    dbDelete_BDGT_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Hir_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Ter_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_ACS_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-       

-End Sub

-

-

-<<<<<<
-======================
-REP_LIST
->>>>>>
-Attribute VB_Name = "REP_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentREP_ID() As Long

-    Dim r As Range

-

-    With Worksheets("REP_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CREP_ID)

-    End With

-

-    getCurrentREP_ID = r

-End Function

-

-Public Sub REP_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Rep_Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Rep_Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Rep_Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Rep_Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectREP_LPU(rep_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim r_id As Long

-    

-    Range("JUMP") = "LPU_LIST"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-        .Range("ent_date") = ent_date

-    End With

-End Sub

-

-Public Sub SelectREP_QTR(rep_id As Long)

-    Dim vo As Boolean

-    Dim r_id As Long

-    

-    Range("JUMP") = "REP_QTR"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("REP_QTR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateREPList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim rep_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CREP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CREP_AREA).row, CREP_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    rep_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CREP_AREA).Column

-    

-    If i < 4 Then

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 1

-    Else

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 2

-    End If

-    

-    If rep_id = 0 Then

-        Range("LAST_FOCUS") = Range(CREP_AREA).address

-    End If

-

-    If rep_id = 0 Then

-        i = CREP_NAME

-        Range("JUMP") = ""

-    Else

-        btREP_LIST_DO_IT

-    End If

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateREPList()

-    Dim rcd() As tREPID_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-

-    ent_date = getEnt_date

-

-    i = Get_REP_CommonList_by_QTR(rcd, ent_date)

-

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(rcd)

-            r.Offset(i - 1, CREP_NAME) = rcd(i).rep.FirstName & " " & rcd(i).rep.LastName

-            r.Offset(i - 1, CREP_ID) = rcd(i).rep.rep_id

-            r.Offset(i - 1, CREP_BEDS) = rcd(i).qtrs(1).c_beds

-

-            r.Offset(i - 1, CREP_NFG) = rcd(i).qtrs(1).c_bdgt_NFG

-            r.Offset(i - 1, CREP_NMG) = rcd(i).qtrs(1).c_bdgt_NMG

-

-            r.Offset(i - 1, CREP_PLAN) = rcd(i).qtrs(1).qtr.sale_PLAN

-

-            r.Offset(i - 1, CREP_HIR) = rcd(i).qtrs(1).c_pat_HIR

-            r.Offset(i - 1, CREP_TER) = rcd(i).qtrs(1).c_pat_TER

-            r.Offset(i - 1, CREP_CAR) = rcd(i).qtrs(1).c_pat_CRD

-            r.Offset(i - 1, CREP_FACT) = rcd(i).qtrs(1).c_sale_ALL

-            r.Offset(i - 1, CREP_PAT_LPU) = rcd(i).qtrs(1).c_pat_LPU

-            r.Offset(i - 1, CREP_BDGT) = rcd(i).qtrs(1).c_bdgt_LPU

-            If rcd(i).qtrs(1).c_bdgt_LPU > 0 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = rcd(i).qtrs(1).c_sale_ALL / rcd(i).qtrs(1).c_bdgt_LPU

-            End If

-            If r.Offset(i - 1, CREP_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-

-

-<<<<<<
-======================
-mREP_LIST
->>>>>>
-Attribute VB_Name = "mREP_LIST"

-Option Explicit

-

-Public Const CREP_AREA As String = "B12"

-Public Const CREP_NAME As Integer = 0

-Public Const CREP_NAME1 As Integer = 1

-Public Const CREP_NAME2 As Integer = 2

-Public Const CREP_ID As Integer = 3

-Public Const CREP_BEDS As Integer = 4

-Public Const CREP_NFG As Integer = 5

-Public Const CREP_NMG As Integer = 6

-Public Const CREP_HIR As Integer = 7

-Public Const CREP_TER As Integer = 8

-Public Const CREP_CAR As Integer = 9

-Public Const CREP_FACT As Integer = 10

-Public Const CREP_PLAN As Integer = 11

-Public Const CREP_PAT_LPU As Integer = 16

-Public Const CREP_BDGT As Integer = 17

-Public Const CREP_PAT_ALL As Integer = 16

-

-

-

-Sub EditREP(cRep As tREPID, ent_date As String)

-    NoFunc

-End Sub

-

-Sub Rep_Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-        End If

-    Next i

-

-End Sub

-

-Sub Rep_Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btREP_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = "RM_QTR"

-    End With

-    ThisWorkbook.Worksheets("RM_QTR").Activate

-End Sub

-

-

-Sub btREP_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim rep_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("REP_LST_DETALS")

-    With Worksheets("REP_LIST")

-        rep_id = .getCurrentREP_ID

-        

-        Select Case i

-            Case 1:

-                .SelectREP_QTR rep_id

-            Case 2:

-                ent_date = .getEnt_date()

-                .SelectREP_LPU rep_id, ent_date

-        End Select

-    End With

-    

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-

-

-

-<<<<<<
-======================
-cdbREP
->>>>>>
-Attribute VB_Name = "cdbREP"

-Option Explicit

-

-Public Type tREPID_COMMON

-    rep As tREPID

-    i_qtrs As Integer

-    qtrs() As tQTR_COMMON

-End Type

-

-Function Get_REP_CommonList_by_QTR(ByRef rcd() As tREPID_COMMON, ent_date As String) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_REP_CommonList_by_QTR = dbGet_REP_CommonList_by_QTR(dbConnection, rcd, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_REP_CommonList_by_QTR(dbConnection As Object, ByRef rcd() As tREPID_COMMON, ent_date As String) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim k As Long

-    Dim allREPID() As tREPID

-    

-    i = dbGetAll_REPID_Records_by_QTR(dbConnection, allREPID, ent_date)

-    dbGet_REP_CommonList_by_QTR = i

-    If i > 0 Then

-        ReDim rcd(i)

-        For i = 1 To UBound(allREPID)

-            rcd(i).rep = allREPID(i)

-            rcd(i).i_qtrs = Get_QTR_CommonList_by_REP(rcd(i).qtrs, ent_date, allREPID(i).rep_id)

-        Next i

-    End If

-End Function

-

-

-

-<<<<<<
-======================
-CHRT_PAT_LPU_A
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU_A"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-cdbRegion
->>>>>>
-Attribute VB_Name = "cdbRegion"

-Option Explicit

-

-Type tREGION

-    ent_date As String

-    total_SALE As Long ' общий объем продаж

-    total_BDGT As Long ' бюджет всех ЛПУ

-    total_BDGT_NMG As Long ' бюджет всех ЛПУ на НМГ

-    total_LPU As Long ' число ЛПУ

-    total_REP   As Long ' число репов

-    total_BEDS As Long ' общее число коек

-    total_HIR As Long '  общее число пациентов на клексане в хирургии

-    total_TER As Long '  общее число пациентов на клексане в терапии

-    total_ACS As Long '  общее число пациентов на клексане в кардиологии

-    sale_PLAN As Long '  план продаж Авентиса

-End Type

-

-Function GetRGN_COMM_DATA(ByRef reg_data() As tREGION) As Integer

-    Dim q_date() As String

-    Dim q_count As Integer, i As Integer

-    

-    q_count = getAllQTRNames(q_date)

-    If q_count > 0 Then

-        ReDim reg_data(q_count)

-        For i = 1 To q_count

-            Dim current_rep_count As Integer

-            current_rep_count = getREGION_by_QTR(q_date(i), reg_data(i))

-        Next i

-    End If

-    

-    GetRGN_COMM_DATA = q_count

-End Function

-

-Function getAllQTRNames(ByRef qtr_lst() As String) As Integer

-    

-    Dim sql As String

-    Dim i As Integer

-    Dim db As Object, rs As Object

-    

-    

-    sql = "SELECT DISTINCT entry_date FROM lpu_budget"

-    i = 0

-    

-    dbOpenConnection db

-    Set rs = CreateObject("ADODB.Recordset")

-    

-    rs.Open sql, db

-        

-        If Not rs.BOF Then

-            Do While Not rs.EOF

-                i = i + 1

-                ReDim Preserve qtr_lst(i)

-                qtr_lst(i) = rs("entry_date")

-                rs.MoveNext

-            Loop

-        Else

-            getAllQTRNames = 0

-            Exit Function

-        End If

-    getAllQTRNames = i

-    dbCloseConnection db

-End Function

-

-Function getREGION_by_QTR(ent_date As String, treg As tREGION) As Integer

-    Dim rep_count As Integer

-    rep_count = 0

-    

-    Dim reps() As tREPID_COMMON

-    rep_count = Get_REP_CommonList_by_QTR(reps, ent_date)

-    

-    treg.ent_date = ent_date

-    treg.total_BDGT = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.total_BDGT_NMG = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.sale_PLAN = 0 ' quarter.sale_plan

-    treg.total_SALE = 0 'summ of

-    ' hir = (amb40+st40)*pr40 + (amb20+st20)*pr20

-    'ter (amb_clx+stat_clx)*price

-    ' acs xxx

-    'price per rep

-    treg.total_HIR = 0 'patiens clxn

-    treg.total_TER = 0 'patiens clxn

-    treg.total_ACS = 0 'patiens clxn

-    treg.total_LPU = 0 'lpu

-    treg.total_BEDS = 0 'lpu.beds

-    treg.total_REP = 0 '

-    

-    If rep_count > 0 Then

-        Dim i As Integer

-        

-        For i = 1 To UBound(reps)

-            ' current rep is reps(i)

-            With reps(i)

-                treg.total_BDGT = treg.total_BDGT + .qtrs(1).c_bdgt_NFG + .qtrs(1).c_bdgt_NMG

-                treg.total_BDGT_NMG = treg.total_BDGT_NMG + .qtrs(1).c_bdgt_NMG

-                treg.sale_PLAN = treg.sale_PLAN + .qtrs(1).c_sale_PLAN

-                treg.total_SALE = treg.total_SALE + .qtrs(1).c_sale_ALL

-                treg.total_HIR = treg.total_HIR + .qtrs(1).c_pat_HIR

-                treg.total_TER = treg.total_TER + .qtrs(1).c_pat_TER

-                treg.total_ACS = treg.total_ACS + .qtrs(1).c_pat_CRD

-                treg.total_LPU = treg.total_LPU + .qtrs(1).i_lcd

-                treg.total_BEDS = treg.total_BEDS + .qtrs(1).c_beds

-                treg.total_REP = treg.total_REP + 1

-            End With

-            

-        Next i

-        

-    End If

-    

-    getREGION_by_QTR = treg.total_REP

-End Function

-

-<<<<<<
-======================
-mRM_QTR
->>>>>>
-Attribute VB_Name = "mRM_QTR"

-Option Explicit

-

-Sub btRM_QTR_Do_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    Dim i As Integer

-    Dim def_dir As String

-    Dim flist() As String

-    

-    idx = Worksheets(VAR_SHEET).Range("RM_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            def_dir = GetWBPath(ThisWorkbook.FullName)

-            If GetImportDirectory(def_dir, flist) Then

-                Dim db_list() As String

-                i = GetDBList(flist(0), db_list)

-                If i > 0 Then

-                    MergeGlobal db_list, GetWBPath(ThisWorkbook.FullName) & "clexane-rm.mdb"

-                End If

-            End If

-            Worksheets(RM_QTR_SHEET).update_history

-        Case 2

-            Worksheets("REP_LIST").Select

-        Case 3

-            cmExport

-    End Select

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-End Sub

-

-<<<<<<
-======================
-mImport
->>>>>>
-Attribute VB_Name = "mImport"

-    Option Explicit

-

-Const OFN_ALLOWMULTISELECT As Long = 512

-Const OFN_EXPLORER As Long = 524288

-Const OFN_HIDEREADONLY As Long = 4

-Const OFN_NONETWORKBUTTON As Long = 131072

-Const OFN_READONLY As Long = 1

-       

-Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _

-    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

-

-Private Type OPENFILENAME

-    lStructSize As Long

-    hWndOwner As Long

-    hInstance As Long

-    lpstrFilter As String

-    lpstrCustomFilter As String

-    nMaxCustFilter As Long

-    nFilterIndex As Long

-    lpstrFile As String

-    nMaxFile As Long

-    lpstrFileTitle As String

-    nMaxFileTitle As Long

-    lpstrInitialDir As String

-    lpstrTitle As String

-    flags As Long

-    nFileOffset As Integer

-    nFileExtension As Integer

-    lpstrDefExt As String

-    lCustData As Long

-    lpfnHook As Long

-    lpTemplateName As String

-End Type

-

-Function GetImportDirectory(DB_dir As String, flist() As String) As Boolean

-    Dim OpenFile As OPENFILENAME

-    Dim lReturn As Long

-    Dim sFilter As String

-    

-    OpenFile.lStructSize = Len(OpenFile)

-    '         OpenFile.hwndOwner = Form1.hWnd

-    '         OpenFile.hInstance = App.hInstance

-    sFilter = "Clexane Data Files" & Chr(0) & "mr*.mdb" & Chr(0)

-    OpenFile.lpstrFilter = sFilter

-    OpenFile.nFilterIndex = 1

-    OpenFile.lpstrFile = String(257, 0)

-    OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1

-    OpenFile.lpstrFileTitle = OpenFile.lpstrFile

-    OpenFile.nMaxFileTitle = OpenFile.nMaxFile

-    OpenFile.lpstrInitialDir = DB_dir

-    OpenFile.lpstrTitle = "Импорт данных"

-    OpenFile.flags = OFN_HIDEREADONLY + OFN_ALLOWMULTISELECT + OFN_EXPLORER

-    lReturn = GetOpenFileName(OpenFile)

-    If lReturn = 0 Then

-        GetImportDirectory = False

-    Else

-        GetImportDirectory = True

- 

-        flist = Split(OpenFile.lpstrFile, Chr(0), Compare:=vbBinaryCompare)

-        Dim i As Integer

-        i = 0

-        Do While flist(i) <> ""

-            i = i + 1

-        Loop

-        If i = 1 Then

-            flist(1) = flist(0)

-            flist(0) = GetWBPath(flist(1))

-            flist(1) = GetWBName(flist(1))

-        Else

-            flist(0) = flist(0) & "\"

-        End If

-    End If

-End Function

-<<<<<<
-======================
-mImport2
->>>>>>
-Attribute VB_Name = "mImport2"

-Option Explicit

-

-Sub FOpen()

-    Dim flist As String

-    Dim fileToOpen, s

-    flist = ""

-    fileToOpen = Application _

-        .GetOpenFileName("Data Files (*.mdb), mr*.mdb", title:="Импорт данных", MultiSelect:=True)

-    If fileToOpen <> False Then

-        For Each s In fileToOpen

-            flist = flist & s & "; "

-        Next s

-        MsgBox "Open " & flist

-    End If

-End Sub

-

-Sub t2()

-    Dim d As dlgImprtDB

-    Set d = New dlgImprtDB

-    d.Show

-End Sub

-

-<<<<<<
-======================
-dlgImprtDB
->>>>>>
-Attribute VB_Name = "dlgImprtDB"

-Attribute VB_Base = "0{F249176D-486B-46DB-9FFF-6CFEBC0CB94B}{8245F8BD-0F9B-47F4-947B-4ED30DA63EF1}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Private Sub btSelAll_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = True

-    Next i

-End Sub

-

-Private Sub btUnselect_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = False

-    Next i

-End Sub

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    

-    Application.EnableEvents = True

-    Set MyAppEvents.app = Application

-    

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    

-    set_work_mode

-    

-    MyAppEvents.CheckWorkBooksArround ThisWorkbook

-    

-    CheckUser

-    

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-    Application.ScreenUpdating = True

-

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-    ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-    Application.Calculate

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    

-    Application.Caption = Empty

-    Application.CommandBars("Worksheet Menu Bar").Reset

-    

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-    

-    With ThisWorkbook

-        xlRestoreView

-        .Application.DisplayAlerts = False

-        .Save

-    End With

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-    Dim MaxX, MaxY As Integer

-    With ThisWorkbook.Worksheets(RM_QTR_SHEET)

-        .Select

-        MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-        MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-    End With

-

-    With ThisWorkbook.Application

-        .ScreenUpdating = False

-        .WindowState = xlNormal

-        .Height = MaxY

-        .Width = MaxX

-    End With

-End Sub

-

-

-

-

-

-<<<<<<
-======================
-REP_QTR
->>>>>>
-Attribute VB_Name = "REP_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CQTR_QT As Integer = 0

-Const CQTR_ID As Integer = 1

-Const CQTR_PLN As Integer = 2

-Const CQTR_FCT As Integer = 3

-Const CQTR_BDG As Integer = 4

-Const CQTR_CNT As Integer = 5

-Const CQTR_BEDS As Integer = 6

-Const CQTR_HIR As Integer = 7

-Const CQTR_TER As Integer = 8

-Const CQTR_CRD As Integer = 9

-Const CQTR_CLXN_BDG As Integer = 10

-Const CQTR_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub update_history()

-    Dim objQTR() As tQTR

-    Dim i As Long

-    Dim r As Range

-    Dim cRep As tREPID

-

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    Range("D4") = cRep.LastName

-    Range("D5") = cRep.FirstName

-

-    Range("H4") = GetRegionName(cRep.Region)

-    Range("H5") = GetCityName(cRep.Region, cRep.City)

-

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetAll_QTR_Records_by_REP(objQTR, "%", cRep.rep_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CQTR_QT) = objQTR(i).entry_date

-        Next i

-    End If

-    Dim qcd() As tQTR_COMMON

-    i = Get_QTR_CommonList_by_REP(qcd, "%", cRep.rep_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(qcd)

-            r.Offset(i - 1, CQTR_QT) = qcd(i).qtr.entry_date

-            r.Offset(i - 1, CQTR_ID) = qcd(i).qtr.id

-            r.Offset(i - 1, CQTR_PLN) = qcd(i).qtr.sale_PLAN

-            r.Offset(i - 1, CQTR_FCT) = qcd(i).c_sale_ALL

-            r.Offset(i - 1, CQTR_BDG) = qcd(i).c_bdgt_LPU

-            r.Offset(i - 1, CQTR_CNT) = qcd(i).i_lcd

-            r.Offset(i - 1, CQTR_BEDS) = qcd(i).c_beds

-            r.Offset(i - 1, CQTR_HIR) = qcd(i).c_pat_HIR

-            r.Offset(i - 1, CQTR_TER) = qcd(i).c_pat_TER

-            r.Offset(i - 1, CQTR_CRD) = qcd(i).c_pat_CRD

-            If qcd(i).c_bdgt_LPU <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_BDG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_LPU

-            End If

-            If qcd(i).c_bdgt_NMG <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_NMG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CQTR_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRepQtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CQTR_ID + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    i = currRange.Column - Range(CINP_AREA).Column

-

-    QTR_ID = r

-

-    If QTR_ID = 0 Then

-        Worksheets(VAR_SHEET).Range("USER_ACTION") = 1

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        If i > CQTR_FCT Then

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-            Range("LAST_FOCUS") = currRange.address

-        Else

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 3

-            Range("LAST_FOCUS") = currRange.address

-        End If

-    End If

-    Cancel = True

-    btHomeDo_IT

-End Sub

-

-<<<<<<
-======================
-mRep_QTR
->>>>>>
-Attribute VB_Name = "mRep_QTR"

-Option Explicit

-

-Sub NoFunc()

-    MsgBox "Функция не доступна", vbOKOnly, PROGRAM_NAME

-End Sub

-

-Sub DO_Price_qtr(ent_date As String)

-    Dim qtr As tQTR

-    Dim res As Integer

-    Dim cRep As tREPID

-

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    qtr = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-

-    If qtr.id = 0 Then

-        qtr.entry_date = ent_date

-

-        With Worksheets(VAR_SHEET)

-            qtr.ClxnH20mg = .Range("ClxnH20mg")

-            qtr.ClxnH40mg = .Range("ClxnH40mg")

-            qtr.ClxnT40mg = .Range("ClxnT40mg")

-            qtr.ClxnC_ACS = .Range("ClxnC_ACS")

-            qtr.ClxnC_IM = .Range("ClxnC_IM")

-        End With

-    End If

-

-    Dim dlg_nq As dlg_nextQTR

-    Set dlg_nq = New dlg_nextQTR

-

-    With dlg_nq

-        .tb_qtr_name = qtr.entry_date

-        .tb_bdgt_avts = qtr.sale_PLAN

-        .tb_qtr_name = qtr.entry_date

-        .tb_ClxnH20mg = qtr.ClxnH20mg

-        .tb_ClxnH40mg = qtr.ClxnH40mg

-        .tb_ClxnT40mg = qtr.ClxnT40mg

-        .tb_ClxnC_ACS = qtr.ClxnC_ACS

-        .tb_ClxnC_IM = qtr.ClxnC_IM

-    End With

-

-    dlg_nq.Show

-End Sub

-

-Sub DO_Edit_qtr(ent_date As String)

-    If ent_date = "" Then

-        NoFunc

-    Else

-        Dim rep_id As Long

-        rep_id = Worksheets(REP_QTR_SHEET).Range("REP_ID")

-        With ThisWorkbook.Worksheets("LPU_LIST")

-            .Range("VIEW_ONLY") = True

-            .Range("ent_date") = ent_date

-            .Range("REP_ID") = rep_id

-            .Select

-        End With

-    End If

-End Sub

-

-Sub DO_Delete_qtr(ent_date As String)

-    If ent_date <> "" Then

-        MsgBox "Удалить данные за период [" & ent_date & "] нельзя ", vbOKOnly, PROGRAM_NAME

-    End If

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-

-Sub btHomeDo_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    idx = Worksheets(VAR_SHEET).Range("USER_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            NoFunc

-            ' Обновляем экран

-        Case 2

-            DO_Edit_qtr ent_date

-        Case 3

-            DO_Price_qtr ent_date

-        Case 4

-            NoFunc

-    End Select

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-Sub Delete_qtr()

-'    Dim ent_date As String

-'    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-'    DO_Delete_qtr ent_date

-End Sub

-

-Sub btREP_QTR_RET_IT()

-    Dim s As String

-    With Worksheets("REP_QTR")

-        .Range("LAST_FOCUS") = ""

-        s = .Range("ret_addr")

-        .Range("ret_addr") = ""

-    End With

-    If s <> "" Then

-        ThisWorkbook.Worksheets(s).Select

-    Else

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane[RM]"

-Public Const PROGRAM_VERSION As String = "Clexane[RM] ver 1.0"

-Public Const PROGRAM_FILENAME As String = "clexane-rm"

-Public Const PROGRAM_EXPORTNAME As String = "rm-export-"

-Public Const PROGRAM_IMPORTNAME As String = "mr-export-*"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20030329

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "P40"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-Public Const RM_QTR_SHEET As String = "RM_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-

-End Sub

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetWBName(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBName = Right(FullName, s_len - pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.name = VAR_SHEET Or sh.name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-<<<<<<
-======================
-Var
->>>>>>
-Attribute VB_Name = "Var"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-title
->>>>>>
-Attribute VB_Name = "title"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LPU_LIST
->>>>>>
-Attribute VB_Name = "LPU_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentLPU_ID() As Long

-    Dim r As Range

-

-    With Worksheets("LPU_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CLPU_ID)

-    End With

-

-    getCurrentLPU_ID = r

-End Function

-

-Public Sub LPU_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectLPU_NAME(lpu_id As Long, ent_date As String)

-    If Range("VIEW_ONLY") = True Then

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    Dim cLPU As tLPU

-    If lpu_id = 0 Then

-        cLPU.id = 0

-        cLPU.rep_id = 0

-        cLPU.address = ""

-        cLPU.name = ""

-    Else

-        cLPU = Get_LPU_Record(lpu_id)

-    End If

-    EditLPU cLPU, getEnt_date

-    Worksheet_Activate

-End Sub

-

-Sub SelectLPU_BDGT(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    vo = Range("VIEW_ONLY")

-    If lpu_id = 0 Then

-        SelectLPU_NAME lpu_id, ent_date

-    Else

-        With ThisWorkbook.Worksheets("LPU_BDGT")

-            .Range("VIEW_ONLY") = vo

-            .Range("ret_addr") = "LPU_LIST"

-            .Range("REP_ID") = r_id

-            .Range("ent_date") = ent_date

-            .Range("lpu_id") = lpu_id

-        End With

-    End If

-End Sub

-

-Sub SelectLPU_HIR(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_HIR")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Sub SelectLPU_TER(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_TER")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Sub SelectLPU_C_ACS(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_C_ACS")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateLPUList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-'    Dim r_sel As Range

-'    If Not chk_input_range(Target) Then

-'        Set r_sel = Range(CINP_AREA)

-'    Else

-'        Set r_sel = Target

-'    End If

-'

-'    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-'        Set r_sel = r_sel.Cells(1, 1)

-'    End If

-'

-'    If r_sel.count = 1 Then

-'        Range("LAST_FOCUS") = r_sel.address

-'        InpRowSelect r_sel

-'    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim lpu_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CINP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CINP_AREA).row, CLPU_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    lpu_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CINP_AREA).Column

-

-    If lpu_id = 0 Then

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    End If

-

-    If lpu_id = 0 Then

-        i = CLPU_NAME

-        Range("JUMP") = ""

-    End If

-    Select Case i

-        Case CLPU_NAME, CLPU_NAME1, CLPU_NAME2, CLPU_BEDS

-            SelectLPU_NAME lpu_id, ent_date

-            Range("JUMP") = ""

-

-        Case CLPU_NMG, CLPU_NFG, CLPU_PLAN, CLPU_FACT

-            SelectLPU_BDGT lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-

-        Case CLPU_HIR

-            SelectLPU_HIR lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_HIR"

-

-        Case CLPU_TER

-            SelectLPU_TER lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_TER"

-

-        Case CLPU_CAR

-            SelectLPU_C_ACS lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        Case Else

-            Range("JUMP") = ""

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateLPUList()

-    Dim lcd() As tLPU_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-    Dim objQTR As tQTR

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    ent_date = getEnt_date

-

-'     ent_date = "%" ' % - all records

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-    i = Get_LPU_CommonQTR(lcd, objQTR)

-

-'     стираем ФИО

-    Range("C3:C4").ClearContents

-

-    Range("C3") = cRep.LastName

-    Range("C4") = cRep.FirstName

-    Range("G3") = GetRegionName(cRep.Region)

-    Range("G4") = GetCityName(cRep.Region, cRep.City)

-    Range("G5") = objQTR.sale_PLAN

-

-

-

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(lcd)

-            r.Offset(i - 1, CLPU_NAME) = lcd(i).lpu.name

-            r.Offset(i - 1, CLPU_ID) = lcd(i).lpu.id

-            r.Offset(i - 1, CLPU_BEDS) = lcd(i).lpu.beds

-

-

-            r.Offset(i - 1, CLPU_NFG) = lcd(i).bdgt.bdgt_NFG

-            r.Offset(i - 1, CLPU_NMG) = lcd(i).bdgt.bdgt_NMG

-            r.Offset(i - 1, CLPU_PLAN) = lcd(i).bdgt.sale_PLAN

-

-            r.Offset(i - 1, CLPU_HIR) = lcd(i).pat_HIR

-            r.Offset(i - 1, CLPU_TER) = lcd(i).pat_TER

-            r.Offset(i - 1, CLPU_CAR) = lcd(i).pat_CRD

-            r.Offset(i - 1, CLPU_FACT) = lcd(i).sale_ALL

-            r.Offset(i - 1, CLPU_PAT_LPU) = lcd(i).pat_LPU

-            r.Offset(i - 1, CLPU_BDGT) = lcd(i).bdgt_LPU

-            If lcd(i).bdgt_LPU > 0 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = lcd(i).sale_ALL / lcd(i).bdgt_LPU

-            End If

-            If r.Offset(i - 1, CLPU_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{61578A1F-A40D-40D9-BDC5-9B19909352C7}{EBB173CA-630F-4686-8122-1980F1071257}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-dbACS
->>>>>>
-Attribute VB_Name = "dbACS"

-Option Explicit

-

-Public Type tACS

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    patients_with_geparins As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objACS.ID <> 0 then updatre else insert

-Sub Insert_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objACS.id <> 0 Then

-        dbUpdate_ACS_Record dbConnection, objACS

-    Else

-        dbInsert_ACS_Record dbConnection, objACS

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_ACS_RecordsByLPU_ID(ByRef all_ACS_() As tACS, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_ACS_RecordsByLPU_ID = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, all_ACS_, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_ACS_Record dbConnection, objACS

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub dbInsert_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_acs", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objACS

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("patients_with_geparins") = .patients_with_geparins

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objACS.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim Update_SQL As String

-    

-    With objACS

-        Update_SQL = "UPDATE lpu_acs SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "patients_with_geparins=" & .patients_with_geparins & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_ACS_RecordsbyLPU_ID(dbConnection As Object, all_ACS() As tACS, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_ACS_SQL As String

-    Dim getAll_ACS_SQL As String

-    Dim ACS_Count As Long

-    ACS_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_ACS_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        ACS_Count = dbRecordset("ACS_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_ACS_RecordsbyLPU_ID = ACS_Count

-    

-    If ACS_Count > 0 Then

-        'we have records

-        ReDim all_ACS(1 To ACS_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_ACS_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_ACS As tACS

-                 With tmp_ACS

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .patients_with_geparins = dbRecordset("patients_with_geparins")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 all_ACS(index) = tmp_ACS

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE ID=" & objACS.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_ACS_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_HIR
->>>>>>
-Attribute VB_Name = "LPU_CLSN_HIR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-

-        Dim objHir As tHIRURGIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objHir

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .operations_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L9")

-                .patients_ambulator_clexan_20mg = Range("L10")

-                .patients_ambulator_clexan_40mg = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L19")

-                .patients_stationar_clexan_20mg = Range("L20")

-                .patients_stationar_clexan_40mg = Range("L21")

-            End With

-            Insert_Hir_Record objHir

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objHir.id = Range("rec_id")

-                    If objHir.id <> 0 Then

-                        Delete_Hir_Record objHir

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objHir As tHIRURGIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    With objHir

-        Range("rec_id") = .id

-        Range("F6") = .operations_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L9") = .patients_ambulator_clexan

-        Range("L10") = .patients_ambulator_clexan_20mg

-        Range("I21") = .patients_stationar_nmg

-        Range("L19") = .patients_stationar_clexan

-        Range("L20") = .patients_stationar_clexan_20mg

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id)

-

-        formula = "=" & qtr.ClxnH20mg & "*($L$10+$L$20)+" & qtr.ClxnH40mg & "*($L$11+$L$21)"

-        Range("F11").formula = formula

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objHir() As tHIRURGIA

-        Dim i As Integer

-        i = GetAll_Hir_RecordsByLPU_ID(objHir, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.3

-        Else

-            SetupData objHir(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-mSapes
->>>>>>
-Attribute VB_Name = "mSapes"

-Option Explicit

-

-Const SHAPE_COLOR As Integer = 1

-Const SHAPE_NAME As Integer = 2

-

-

-Sub ShapeView(r_sh_finite_state As Range)

-    Dim chk As Range

-    Dim s As String

-    Dim c, idx As Integer

-    For Each chk In r_sh_finite_state

-        idx = 0

-        If chk = "+" Then

-            c = chk.Offset(0, idx + SHAPE_COLOR)

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While c <> 0

-                ShapeFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s)), c

-                idx = idx + 2

-                c = chk.Offset(0, idx + SHAPE_COLOR)

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        Else

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While s <> ""

-                ShapeUnFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s))

-                idx = idx + 2

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        End If

-    Next chk

-End Sub

-

-Sub ShapeFill(sh As ShapeRange, ByVal color As Integer)

-    sh.Fill.Visible = msoTrue

-    sh.Fill.Solid

-    sh.Fill.ForeColor.SchemeColor = color

-    sh.Fill.Transparency = 0#

-End Sub

-

-Sub ShapeUnFill(sh As ShapeRange)

-    sh.Fill.Visible = msoFalse

-    sh.Fill.Transparency = 0#

-End Sub

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Public Const INPUT_NO = 0

-Public Const INPUT_NUMBER = 1

-Public Const INPUT_PERCENT = 2

-Public Const INPUT_STRING = 3

-Public Const INPUT_CHECK = 4

-

-Public Const INP_IDX_TYPE = 1

-Public Const INP_IDX_NEXT = 2

-Public Const INP_IDX_MIN = 3

-Public Const INP_IDX_MAX = 4

-Public Const INP_IDX_DEP = 5

-Public Const INP_IDX_ALT = 7

-

-

-Public Type tInputSet

-    vType As Integer

-    vMin As Long

-    vMax As Long

-    rChk As String

-End Type

-

-Function is_input_cell(ByVal Target As Range, inputs As Range) As tInputSet

-    Dim t As Range

-    Dim iset As tInputSet

-    Dim test As Range

-    iset.vType = INPUT_NO

-    iset.vMin = 0

-    iset.vMax = 0

-    iset.rChk = ""

-    is_input_cell = iset

-

-' Закоментировать следующую сточку для работы

-'  Exit Function

-

-    Set test = Target.Cells(1, 1)

-    For Each t In inputs

-        If Range(t).Column = test.Column And Range(t).row = test.row Then

-            iset.vType = t.Offset(0, INP_IDX_TYPE).Value

-            Select Case iset.vType

-                Case INPUT_CHECK

-                    iset.rChk = t.Offset(0, INP_IDX_ALT)

-                Case INPUT_NUMBER, INPUT_PERCENT

-                    iset.vMin = t.Offset(0, INP_IDX_MIN).Value

-                    iset.vMax = t.Offset(0, INP_IDX_MAX).Value

-            End Select

-            is_input_cell = iset

-            Exit Function

-        End If

-    Next t

-End Function

-

-Function GetFocusAddress(ByVal r As Range, f_next As Range) As String

-    Dim chk, t As Range

-    

-    For Each chk In f_next

-        For Each t In r

-            If t.address = chk Then

-                GetFocusAddress = chk

-                Exit Function

-            End If

-            If Range(chk).Column = t.Column - 1 And Range(chk).row = t.row _

-            Or Range(chk).Column = t.Column And Range(chk).row = t.row - 1 _

-            Then

-                If Range(chk) <> "" Then

-                    If Range(chk) = 0 Then

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_ALT)).address

-                    Else

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_NEXT)).address

-                    End If

-                Else

-                    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-                End If

-                Exit Function

-            End If

-        Next t

-    Next chk

-    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-End Function

-

-Sub SetDependet(r As Range, inputs As Range)

-    Dim chk As Range

-    Dim s, serr As String

-    Dim idx As Integer

-    Dim iset As tInputSet

-    Dim err_found As Boolean

-    

-    If r.count > 1 Then

-        Exit Sub

-    End If

-    

-    err_found = False

-    For Each chk In inputs

-        idx = INP_IDX_DEP

-        

-        

-        iset.vType = chk.Offset(0, INP_IDX_TYPE).Value

-        Select Case iset.vType

-            Case INPUT_NUMBER, INPUT_PERCENT

-                iset.vMin = chk.Offset(0, INP_IDX_MIN).Value

-                iset.vMax = chk.Offset(0, INP_IDX_MAX).Value

-                

-                If Range(chk) > iset.vMax Then

-                    err_found = True

-                    Range(chk) = iset.vMax

-                    serr = "Выход за дозволенный диапазон [" & iset.vMin & ".." & iset.vMax & "]! Данные скорректированы."

-                End If

-                

-                If Range(chk) = "" Then

-                    s = chk.Offset(0, idx)

-                    Do While s <> ""

-                        Range(s) = ""

-                        idx = idx + 1

-                        s = chk.Offset(0, idx)

-                    Loop

-                End If

-        End Select

-    Next chk

-    If err_found Then

-        MsgBox serr, vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Function CheckInputData(inputs As Range) As Boolean

-    Dim r As Range

-    

-    CheckInputData = True

-    For Each r In inputs

-        If Range(r) = "" Then

-            CheckInputData = False

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100.", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Sub Check_Int_Number(Target As Range, Def_Val As Long)

-    Dim err As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    err = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                err = True

-            End If

-        End If

-    Next r

-    If err Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_TER
->>>>>>
-Attribute VB_Name = "LPU_CLSN_TER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim objTer As tTERAPIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objTer

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .patients_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L20")

-            End With

-            Insert_Ter_Record objTer

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objTer.id = Range("rec_id")

-                    If objTer.id <> 0 Then

-                        Delete_Ter_Record objTer

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objTer As tTERAPIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    With objTer

-        Range("rec_id") = .id

-        Range("F6") = .patients_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L11") = .patients_ambulator_clexan

-        Range("I21") = .patients_stationar_nmg

-        Range("L20") = .patients_stationar_clexan

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id)

-        formula = "=" & qtr.ClxnT40mg & "*($L$12+$L$20)"

-        Range("F11").formula = formula

-

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objTer() As tTERAPIA

-        Dim i As Integer

-        i = GetAll_Ter_RecordsByLPU_ID(objTer, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.25

-        Else

-            SetupData objTer(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{EB7A1A05-DDD1-4FB8-8061-EA4E6E0F2909}{1F1B7B18-81E4-4A41-9D49-138004069095}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-LPU_BDGT
->>>>>>
-Attribute VB_Name = "LPU_BDGT"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub SetDefFocus()

-    Range(Range("DEF_FOCUS")).Select

-End Sub

-

-Public Sub ClearData()

-    ClearSheetData

-End Sub

-

-Sub ClearSheetData()

-    If Range("F10") = 0 And Range("F13") = 0 Then

-        Range("F11:F18") = ""

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("F11:F13") = ""

-    End If

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim bdgt As tBUDGET

-        Dim test As Long

-        With bdgt

-            .lpu_id = Range("lpu_id")

-            .id = Range("rec_id")

-            .entry_date = Range("ent_date")

-            .bdgt_NMG = Round(Range("F11").Value, 0)

-            .bdgt_NFG = Round(Range("F12").Value, 0)

-            .sale_PLAN = Round(Range("F13").Value, 0)

-

-            test = .bdgt_NFG + .bdgt_NMG - .sale_PLAN

-        End With

-        If test <> 0 Then

-            If test < 0 Then

-                If vbYes = MsgBox("Ваш план превышает выделенный на гепарины бюджет. Сохранить данные?", _

-                        vbYesNo, PROGRAM_NAME) Then

-                    test = 1

-                End If

-            End If

-            If test > 0 Then

-                Insert_BDGT_Record bdgt

-            End If

-        Else

-            If bdgt.id <> 0 Then

-                If vbYes = MsgBox("Удалить данные из базы!", vbYesNo, PROGRAM_NAME) Then

-                    Delete_BDGT_Record bdgt

-                End If

-                ret_back Range("DEF_FOCUS").Worksheet

-                Exit Sub

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-    End If

-

-   ClearData

-   ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(cLPU As tLPU_COMMON)

-    Dim t_sum As Long

-    t_sum = 0

-' Setup budget data

-    Range("F11") = cLPU.bdgt.bdgt_NMG

-    Range("F12") = cLPU.bdgt.bdgt_NFG

-    Range("F13") = cLPU.bdgt.sale_PLAN

-

-    With cLPU

-        Range("F14") = .pat_ALL

-        Range("F15") = .pat_HIR

-        Range("F16") = .pat_TER

-        Range("F17") = .pat_CRD

-        Range("F18") = .sale_ALL

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    ws_activate

-End Sub

-

-

-Sub ws_activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Dim cLPU As tLPU_COMMON

-    Dim objQTR As tQTR

-    Dim objLPU As tLPU

-    Dim ent_date As String

-    Dim id As Long

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    id = Range("lpu_id").Value

-    ent_date = Range("ent_date")

-    

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-

-    objLPU = Get_LPU_Record(id)

-    Get_LPU_Common cLPU, objLPU, objQTR

-

-    If cLPU.lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = cLPU.lpu.beds

-        Range("lpu_name") = cLPU.lpu.name

-        Range("lpu_addr") = cLPU.lpu.address

-        Range("rec_id") = cLPU.bdgt.id

-

-        SetupData cLPU

-

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-'    MsgBox Target.address

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case INPUT_CHECK

-

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{C153FD2A-1AF3-4CA1-94C8-33DFC836F451}{21F1E6B0-03F8-4687-B1AE-A865D971B51F}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mSheets
->>>>>>
-Attribute VB_Name = "mSheets"

-Option Explicit

-

-Function am_load_now() As Boolean

-    am_load_now = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE")

-End Function

-

-Sub Wks_select(RetSheet As String)

-    Dim sheet As Worksheet

-    For Each sheet In ThisWorkbook.Worksheets

-        If sheet.name = RetSheet Then

-            ThisWorkbook.Worksheets(RetSheet).Select

-            Exit Sub

-        End If

-    Next sheet

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub ret_back(sh As Worksheet)

-    Dim RetSheet As String

-    RetSheet = sh.Range("ret_addr")

-    sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    sh.Range("ret_addr") = ""

-    sh.Range("rec_id") = ""

-    sh.Range("lpu_id") = ""

-    sh.Range("ent_date") = ""

-    sh.Range("lpu_name") = ""

-    sh.Range("lpu_addr") = ""

-    sh.Range("lpu_beds") = ""

-    Wks_select RetSheet

-End Sub

-

-Sub ClearSheetData(r_start As Range)

-    If r_start <> "" Then

-        r_start.Worksheet.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        r_start = ""

-    Else

-        ret_back r_start.Worksheet

-    End If

-End Sub

-

-Sub wks_sel_chng(iset As tInputSet, ByVal Target As Range, sh As Worksheet)

-    Dim DebugMode As Boolean

-    Dim in_range As Range

-    

-    DebugMode = Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-

-    If DebugMode Then

-        sh.Unprotect

-    Else

-        sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    End If

-

-    If iset.vType = INPUT_CHECK Then

-        Set in_range = Target.Worksheet.Range(iset.rChk)

-    Else

-        Set in_range = Target

-    End If

-    

-    Dim str As String

-    str = GetFocusAddress(in_range, sh.Range("h_inputs"))

-

-'    MsgBox Target.Address & "; " & str

-    If str <> Target.address Then

-        sh.Range(str).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-Dlg_lpu_card
->>>>>>
-Attribute VB_Name = "Dlg_lpu_card"

-Attribute VB_Base = "0{5764DEB2-CAF6-45EF-B0F4-5464E8CDF848}{B9786D4A-134B-4A37-BFCD-40AEC0764940}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbLPU_List_Change()

-    Dim src As Range

-    Dim idx_src As Integer

-    

-    Set src = Worksheets(VAR_SHEET).Range(Me.cbLPU_List.RowSource)

-    idx_src = Me.cbLPU_List.ListIndex + 1

-    Me.tb_lpu_name.Text = src.Cells(idx_src, 1)

-    Me.tb_lpu_address.Text = src.Cells(idx_src, 2)

-    Me.tbBedsCount.Text = src.Cells(idx_src, 3)

-End Sub

-

-

-Private Sub cbxLPU_List_Enable_Click()

-    

-    If Me.cbxLPU_List_Enable Then

-        

-        Me.tb_lpu_name.Text = ""

-        Me.tb_lpu_name.Enabled = False

-        

-        Me.tb_lpu_address.Text = ""

-        Me.tb_lpu_address.Enabled = False

-        

-        Me.tbBedsCount.Text = ""

-        Me.tbBedsCount.Enabled = False

-        

-        Me.cbLPU_List.Enabled = True

-        cbLPU_List_Change

-    Else

-        Me.tb_lpu_name.Enabled = True

-        Me.tb_lpu_name.Text = ""

-        

-        Me.tb_lpu_address.Enabled = True

-        Me.tb_lpu_address.Text = ""

-        

-        Me.tbBedsCount.Enabled = True

-        Me.tbBedsCount.Text = ""

-        

-        Me.cbLPU_List.Enabled = False

-    End If

-End Sub

-

-<<<<<<
-======================
-UserInfo
->>>>>>
-Attribute VB_Name = "UserInfo"

-Attribute VB_Base = "0{6DBD00A4-3B88-40D4-99CE-00C39D3623CA}{D43A9D10-FFF9-452F-BC09-849A16EBE561}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Tag = vbOK

-End Sub

-

-Private Sub cbCity_Change()

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_CITY") = Me.cbCity.ListIndex

-        .Calculate

-    End With

-End Sub

-

-Private Sub cbRegion_Change()

-    Dim LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        NewRangeOffsetCol = cbRegion.Value * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).address

-        NewSumRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).address

-        .Calculate

-        .Range("IDX_CITY") = 0

-        cbCity.RowSource = NewCbxRange

-

-    End With

-    cbCity.ListIndex = 0

-End Sub

-

-<<<<<<
-======================
-mREGMAN
->>>>>>
-Attribute VB_Name = "mREGMAN"

-Option Explicit

-

-Sub hwnew()

-    Dim rs As Range

-    Dim re As Object

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    HWReset

-    With Application

-        .DisplayAlerts = False

-        .Quit

-    End With

-End Sub

-

-Sub CheckUser()

-    If Range("HW_Number") = "" Then

-        StoreHWInfo

-    End If

-    If CheckHWInfo <> True Then

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    Else

-        SetupUser

-    End If

-End Sub

-

-

-Sub SetupUser()

-    Dim cREGMAN As tREGMAN

-    Dim idx As Integer

-    Dim dlg_ui As UserInfo

-    

-    Set dlg_ui = New UserInfo

-    

-    cREGMAN = Get_REGMAN_Record()

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_REGION") = cREGMAN.Region

-        .Range("IDX_CITY") = cREGMAN.City

-    End With

-        

-    With dlg_ui

-        .cbRegion = cREGMAN.Region

-        .cbCity = cREGMAN.City

-        .tbFName = cREGMAN.FirstName

-        .tbLName = cREGMAN.LastName

-    End With

-    

-    dlg_ui.Show

-    Worksheets(REGS_SHEET).Calculate

-    

-    If dlg_ui.Tag = vbOK Then

-        With cREGMAN

-            .Region = dlg_ui.cbRegion.Value

-            .City = dlg_ui.cbCity.Value

-            .FirstName = dlg_ui.tbFName.Value

-            .LastName = dlg_ui.tbLName.Value

-        End With

-        Set_REGMAN_Record cREGMAN

-    Else

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-Sub StoreHWInfo()

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim objHW() As Long

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    Set r = Range("HW_Number")

-    i = 1

-    For Each d In dc

-        If d.drivetype = 2 Then

-            r = d.SerialNumber

-            Set r = r.Offset(1, 0)

-            ReDim Preserve objHW(i)

-            objHW(i) = d.SerialNumber

-            i = i + 1

-        End If

-    Next

-    

-    UpdateHWRecords objHW

-End Sub

-

-Function CheckHWInfo()

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim objHW() As Long

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    

-    CheckHWInfo = False

-    

-    i = GetHWRecords(objHW)

-    If i = 0 And Range("HW_Number") <> 0 Then

-        Exit Function

-    End If

-    For Each d In dc

-        If d.drivetype = 2 Then

-            Set r = Range("HW_Number")

-            Do While r <> ""

-                If r = d.SerialNumber Then

-                    For i = 1 To UBound(objHW)

-                        If d.SerialNumber = objHW(i) Then

-                            CheckHWInfo = True

-                            Exit Function

-                        End If

-                    Next i

-                End If

-                Set r = r.Offset(1, 0)

-            Loop

-        End If

-    Next

-End Function

-<<<<<<
-======================
-dbBudget
->>>>>>
-Attribute VB_Name = "dbBudget"

-Option Explicit

-

-Public Type tBUDGET

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    bdgt_NMG As Long

-    bdgt_NFG As Long

-    sale_PLAN As Long

-End Type

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function GetAll_BDGT_RecordsByLPU_ID(ByRef allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_BDGT_RecordsByLPU_ID = dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection, allBDGT, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function Get_BDGT_Record(ByVal lpu_id As Long, ByVal ent_date As String) As tBUDGET

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    Get_BDGT_Record = dbGet_BDGT_Record(dbConnection, lpu_id, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objBDGT.ID <> 0 then updatre else insert

-Public Sub Insert_BDGT_Record(objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    If objBDGT.id <> 0 Then

-        dbUpdate_BDGT_Record dbConnection, objBDGT

-    Else

-        dbInsert_BDGT_Record dbConnection, objBDGT

-    End If

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Public Sub Delete_BDGT_Record(ByRef objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    dbDelete_BDGT_Record dbConnection, objBDGT

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_BDGT_Record(dbConnection As Object, ByVal lpu_id As Long, ent_date As String) As tBUDGET

-    

-    Dim sql As String

-    Dim objBDGT As tBUDGET

-    

-    With objBDGT

-        .id = 0

-        .lpu_id = lpu_id

-        .entry_date = ent_date

-        .bdgt_NMG = 0

-        .bdgt_NFG = 0

-        .sale_PLAN = 0

-    End With

-        

-    

-    sql = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        With objBDGT

-            .entry_date = dbRecordset("entry_date")

-            .id = dbRecordset("id")

-            .lpu_id = dbRecordset("lpu_id")

-            .bdgt_NFG = dbRecordset("bdgt_NFG")

-            .bdgt_NMG = dbRecordset("bdgt_NMG")

-            .sale_PLAN = dbRecordset("sale_PLAN")

-        End With

-    End If

-    

-    dbGet_BDGT_Record = objBDGT

-End Function

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection As Object, allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_BDGT_SQL As String

-    Dim getAll_BDGT_SQL As String

-    Dim BDGT_Count As Long

-    BDGT_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_BDGT_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        BDGT_Count = dbRecordset("BDGT_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_BDGT_RecordsbyLPU_ID = BDGT_Count

-    

-    If BDGT_Count > 0 Then

-        'we have records

-        ReDim allBDGT(1 To BDGT_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_BDGT_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpBDGT As tBUDGET

-                 With tmpBDGT

-                    .entry_date = dbRecordset("entry_date")

-                    .id = dbRecordset("id")

-                    .lpu_id = dbRecordset("lpu_id")

-                    .bdgt_NFG = dbRecordset("bdgt_NFG")

-                    .bdgt_NMG = dbRecordset("bdgt_NMG")

-                    .sale_PLAN = dbRecordset("sale_PLAN")

-                 End With

-                 

-                 allBDGT(index) = tmpBDGT

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbInsert_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "lpu_budget", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    dbRecordset("entry_date") = objBDGT.entry_date

-    dbRecordset("lpu_id") = objBDGT.lpu_id

-    dbRecordset("bdgt_NMG") = objBDGT.bdgt_NMG

-    dbRecordset("bdgt_NFG") = objBDGT.bdgt_NFG

-    dbRecordset("sale_PLAN") = objBDGT.sale_PLAN

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objBDGT.id = dbRecordset("id")

-  

-End Sub

-

-Public Sub dbUpdate_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu_budget SET " & _

-    "entry_date='" & objBDGT.entry_date & "'," & _

-    "lpu_id=" & objBDGT.lpu_id & "," & _

-    "bdgt_NMG=" & objBDGT.bdgt_NMG & "," & _

-    "bdgt_NFG=" & objBDGT.bdgt_NFG & "," & _

-    "sale_PLAN=" & objBDGT.sale_PLAN & _

-    " WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-Public Sub dbDelete_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_BDGT_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbDatabase
->>>>>>
-Attribute VB_Name = "dbDatabase"

-Option Explicit

-

-

-Sub dbOpenConnection(dbConnection As Object)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-<<<<<<
-======================
-dbLPU
->>>>>>
-Attribute VB_Name = "dbLPU"

-Option Explicit

-

-Public Type tLPU

-    id As Long

-    rep_id As Long

-    name As String

-    address As String

-    beds As Integer

-End Type

-

-Function Get_LPU_Record(ByVal lpu_id As Long) As tLPU

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_LPU_Record = dbGet_LPU_Record(dbConnection, lpu_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_LPU_byQTR(allLPU() As tLPU, ent_date As String, rep_id As Long) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_LPU_byQTR = dbGetAll_LPU_byQTR(dbConnection, allLPU, ent_date, rep_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_Record(dbConnection As Object, ByVal lpu_id As Long) As tLPU

-    

-    Dim sql As String

-    Dim objLPU As tLPU

-    

-    objLPU.id = lpu_id

-    objLPU.name = ""

-    objLPU.address = ""

-    

-    sql = "SELECT * FROM lpu WHERE id=" & lpu_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objLPU.name = dbRecordset("name")

-        objLPU.address = dbRecordset("address")

-        objLPU.rep_id = dbRecordset("rep_id")

-        objLPU.beds = dbRecordset("beds")

-    End If

-    

-    dbGet_LPU_Record = objLPU

-

-End Function

-

-Function dbGetAll_LPU_byQTR(dbConnection As Object, allLPU() As tLPU, ent_date As String, rep_id As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    Dim Where As String

-    Where = "WHERE lpu_budget.entry_date like '" & ent_date & "'" & " AND lpu.id=lpu_budget.lpu_id AND lpu.rep_id=" & rep_id

-

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu_budget, lpu " & Where

-    

-    getAll_LPU_SQL = "SELECT lpu.id as id, lpu.rep_id as rep_id, lpu.name as name, lpu.address as address, lpu.beds AS beds " & _

-    "FROM lpu, lpu_budget " & Where

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_LPU_byQTR = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-dbREP
->>>>>>
-Attribute VB_Name = "dbREP"

-'Option Explicit

-'

-'Public Type tREP

-'    FirstName As String

-'    LastName As String

-'    Region As Integer

-'    City As Integer

-'End Type

-'

-'Function GetREPRecord() As tREP

-'    Dim dbConnection As Object

-'

-'    dbOpenConnection dbConnection

-'    GetREPRecord = dbGetREPRecord(dbConnection)

-'    dbCloseConnection dbConnection

-'End Function

-'

-'Sub SetREPRecord(cUser As tREP)

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbSetREPRecord dbConnection, cUser

-'    dbCloseConnection dbConnection

-'End Sub

-'

-'Public Function dbGetREPRecord(dbConnection As Object) As tREP

-'

-'    Dim SQL As String

-'    Dim objREP As tREP

-'

-'    objREP.FirstName = ""

-'    objREP.LastName = ""

-'    objREP.Region = 0

-'    objREP.City = 0

-'    SQL = "SELECT firstname, lastname, region, city FROM " & _

-'          "rep"

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open SQL, dbConnection

-'    ', 3, 3

-'    If Not dbRecordset.BOF Then

-'

-'        objREP.FirstName = dbRecordset("firstname")

-'        objREP.LastName = dbRecordset("lastname")

-'        objREP.Region = dbRecordset("region")

-'        objREP.City = dbRecordset("city")

-'

-'    End If

-'

-'    dbGetREPRecord = objREP

-'

-'End Function

-'

-'Public Sub dbSetREPRecord(dbConnection As Object, ByRef objREP As tREP)

-'

-'    Dim DeleteSQL As String

-'    Dim InsertSQL As String

-'

-'    DeleteSQL = "DELETE FROM rep"

-'    InsertSQL = "INSERT INTO rep (firstname, lastname, region, city) VALUES (" & _

-'    "'" & objREP.FirstName & "', " & _

-'    "'" & objREP.LastName & "', " & _

-'    objREP.Region & ", " & _

-'    objREP.City & ")"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-'

-'End Sub

-'

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    CheckWorkBooksArround Wb

-End Sub

-

-

-Sub CheckWorkBooksArround(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If app.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKOnly, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-        Exit Sub

-    End If

-

-End Sub

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub GetState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-        ActiveWorkbook.DisplayDrawingObjects = xlDisplayShapes

-        

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars("Worksheet Menu Bar").Visible = False

-End Sub

-

-

-Public Sub RestoreState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars("Worksheet Menu Bar").Visible = True

-End Sub

-

-

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Export"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 620

-                        .OnAction = "cmExport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(flag As Boolean)

-    If flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars("Worksheet Menu Bar")

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmExport()

-    dbExport

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    Dim dlg As dlgAbout

-    Set dlg = New dlgAbout

-    

-    dlg.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlg.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlg.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlg.Show

-End Sub

-

-Sub cmMail2Support()

-    Dim err_description As String

-    Dim dlg_msg As dlg_Mail

-    Set dlg_msg = New dlg_Mail

-    With dlg_msg

-        .Show

-        If .Tag = vbOK Then

-            ThisWorkbook.Worksheets(VAR_SHEET).Range("ERR_MESSAGE") _

-                = .tbMessage.Text

-            ThisWorkbook.Save

-            ThisWorkbook.SendMail Recipients:="infra@i-rs.ru", Subject:=PROGRAM_NAME & " ver.:" & PROGRAM_VERSION

-            MsgBox "Сообщение об ошибке отправлено. Перезагрузите программу.", vbOKOnly, PROGRAM_NAME

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-    End With

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-'        helppath = "hh.exe " & .Path & "\Telfast.chm"

-'        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub set_work_mode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-End Sub

-

-Sub cmSetStandaloneMode()

-    set_work_mode

-    ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    Dim dlg As dlgGetPwd

-    rp = common_pwd

-    

-    Set dlg = New dlgGetPwd

-    dlg.edPwd = ""

-    dlg.Show

-    

-    If dlg.edPwd = rp Then

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-        xlRestoreView

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    Dim dlg_prn As dlgPrint

-    

-    Set dlg_prn = New dlgPrint

-    

-    With dlg_prn

-        .cbMainReport = True

-        .cbMainBudget = False

-        .cbSrcData = False

-        .cbAllSheets = False

-    

-        .Show

-    

-        If .Tag = vbCancel Then

-            Exit Sub

-        End If

-    End With

-    

-    Dim PrnIdx As Integer

-    

-    With dlg_prn

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("REP_QTR", "budget", "Final")

-    Case 1111

-        plist = Array("REP_QTR", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("REP_QTR")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Clexane bar"

-Public Const common_pwd As String = "password"

-

-

-Sub SetEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    With Application

-        .Caption = PROGRAM_NAME

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .GetState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = False

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    If cWindow.Type = xlWorkbook Then

-                        cWindow.DisplayHeadings = True

-                    End If

-                Next

-            End If

-        Next

-        .Worksheets(REP_QTR_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu (True)

-        End If

-        With mobjAppState

-            .RestoreState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Option Explicit

-

-Sub UpdateHWRecords(objHW() As Long)

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    dbUpdateHWRecords dbConnection, objHW

-    dbCloseConnection dbConnection

-End Sub

-

-Function GetHWRecords(objHW() As Long) As Integer

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    GetHWRecords = dbGetHWRecords(dbConnection, objHW)

-    dbCloseConnection dbConnection

-End Function

-

-Sub HWReset()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbInsertHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    

-    Dim dbRecordset As Object

-    Dim i As Long

-    

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "hw", dbConnection, 2, 2

-    

-    For i = 1 To UBound(objHW)

-        dbRecordset.addnew

-        dbRecordset("num") = objHW(i)

-        dbRecordset.Update

-    Next i

-    

-End Sub

-

-Sub dbUpdateHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    dbDeleteHWRecord dbConnection

-    dbInsertHWRecords dbConnection, objHW

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-dbHir
->>>>>>
-Attribute VB_Name = "dbHir"

-Option Explicit

-

-Public Type tHIRURGIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    operations_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_ambulator_clexan_40mg As Integer

-    patients_ambulator_clexan_20mg As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-    patients_stationar_clexan_40mg As Integer

-    patients_stationar_clexan_20mg As Integer

-End Type

-

-' if objHir.ID <> 0 then updatre else insert

-Sub Insert_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objHir.id <> 0 Then

-        dbUpdate_Hir_Record dbConnection, objHir

-    Else

-        dbInsert_Hir_Record dbConnection, objHir

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Hir_RecordsByLPU_ID(ByRef allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Hir_RecordsByLPU_ID = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, allHir, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Hir_Record dbConnection, objHir

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objHir.ID <> 0 then updatre else insert

-

-Sub dbInsert_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_hir", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objHir

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("operations_per_quarter") = .operations_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_ambulator_clexan_20mg") = .patients_ambulator_clexan_20mg

-        dbRecordset("patients_ambulator_clexan_40mg") = .patients_ambulator_clexan_40mg

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-        dbRecordset("patients_stationar_clexan_20mg") = .patients_stationar_clexan_20mg

-        dbRecordset("patients_stationar_clexan_40mg") = .patients_stationar_clexan_40mg

-        

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objHir.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim UpdateSQL As String

-    

-    With objHir

-        UpdateSQL = "UPDATE lpu_hir SET " & _

-            "entry_date='" & objHir.entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "operations_per_quarter=" & .operations_per_quarter & "," & _

-            "risk_percent=" & .risk_percent & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_ambulator_clexan_20mg=" & .patients_ambulator_clexan_20mg & "," & _

-            "patients_ambulator_clexan_40mg=" & .patients_ambulator_clexan_40mg & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & "," & _

-            "patients_stationar_clexan_20mg=" & .patients_stationar_clexan_20mg & "," & _

-            "patients_stationar_clexan_40mg=" & .patients_stationar_clexan_40mg & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_Hir_RecordsbyLPU_ID(dbConnection As Object, allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Hir_SQL As String

-    Dim getAll_Hir_SQL As String

-    Dim Hir_Count As Long

-    Hir_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Hir_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Hir_Count = dbRecordset("HIR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Hir_RecordsbyLPU_ID = Hir_Count

-    

-    If Hir_Count > 0 Then

-        'we have records

-        ReDim allHir(1 To Hir_Count)

-        Dim index As Integer

-        index = 1

-        dbRecordset.Open getAll_Hir_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpHir As tHIRURGIA

-                 With tmpHir

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .operations_per_quarter = dbRecordset("operations_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_ambulator_clexan_20mg = dbRecordset("patients_ambulator_clexan_20mg")

-                    .patients_ambulator_clexan_40mg = dbRecordset("patients_ambulator_clexan_40mg")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                    .patients_stationar_clexan_20mg = dbRecordset("patients_stationar_clexan_20mg")

-                    .patients_stationar_clexan_40mg = dbRecordset("patients_stationar_clexan_40mg")

-                 End With

-                 

-                 allHir(index) = tmpHir

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE ID=" & objHir.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Hir_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbTer
->>>>>>
-Attribute VB_Name = "dbTer"

-Option Explicit

-

-Public Type tTERAPIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objTer.ID <> 0 then updatre else insert

-Sub Insert_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objTer.id <> 0 Then

-        dbUpdate_Ter_Record dbConnection, objTer

-    Else

-        dbInsert_Ter_Record dbConnection, objTer

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Ter_RecordsByLPU_ID(ByRef allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Ter_RecordsByLPU_ID = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, allTer, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Ter_Record dbConnection, objTer

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objTer.ID <> 0 then updatre else insert

-

-Sub dbInsert_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_ter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objTer

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objTer.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim Update_SQL As String

-    

-    With objTer

-        Update_SQL = "UPDATE lpu_ter SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "risk_percent=" & .risk_percent & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_Ter_RecordsbyLPU_ID(dbConnection As Object, allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Ter_SQL As String

-    Dim getAll_Ter_SQL As String

-    Dim Ter_Count As Long

-    Ter_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Ter_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Ter_Count = dbRecordset("TER_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Ter_RecordsbyLPU_ID = Ter_Count

-    

-    If Ter_Count > 0 Then

-        'we have records

-        ReDim allTer(1 To Ter_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_Ter_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpTer As tTERAPIA

-                 With tmpTer

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 allTer(index) = tmpTer

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE ID=" & objTer.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Ter_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-mLPU_LIST
->>>>>>
-Attribute VB_Name = "mLPU_LIST"

-Option Explicit

-

-Public Const CINP_AREA As String = "B12"

-Public Const CLPU_NAME As Integer = 0

-Public Const CLPU_NAME1 As Integer = 1

-Public Const CLPU_NAME2 As Integer = 2

-Public Const CLPU_ID As Integer = 3

-Public Const CLPU_BEDS As Integer = 4

-Public Const CLPU_NFG As Integer = 5

-Public Const CLPU_NMG As Integer = 6

-Public Const CLPU_HIR As Integer = 7

-Public Const CLPU_TER As Integer = 8

-Public Const CLPU_CAR As Integer = 9

-Public Const CLPU_FACT As Integer = 10

-Public Const CLPU_PLAN As Integer = 11

-Public Const CLPU_PAT_LPU As Integer = 16

-Public Const CLPU_BDGT As Integer = 17

-Public Const CLPU_PAT_ALL As Integer = 16

-

-

-

-Sub EditLPU(cLPU As tLPU, ent_date As String)

-    NoFunc

-End Sub

-

-Sub Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-        End If

-    Next i

-

-End Sub

-

-Sub Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btLPU_DEL_IT()

-    Dim cLPU As tLPU

-    Dim ent_date As String

-    Dim delete_all As Integer

-    Dim dlg_del As dlg_LPU_delete

-

-    With Worksheets("LPU_LIST")

-        ent_date = .Range("ent_date")

-        cLPU.id = .getCurrentLPU_ID()

-    End With

-

-    If cLPU.id = 0 Then

-        MsgBox "Укажите удаляемый объект", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    cLPU = Get_LPU_Record(cLPU.id)

-

-    Set dlg_del = New dlg_LPU_delete

-    With dlg_del

-        .chbDeleteQTR.Value = True

-        .chbDeleteAll.Value = False

-        .lComment = ent_date & ": Удаление ЛПУ '" _

-        & cLPU.name & "', расположенного по адресу:" _

-        & cLPU.address & " не разрешено."

-        .Show

-    End With

-End Sub

-

-Sub btLPU_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        

-        Wks_select .Range("ret_addr")

-    End With

-

-End Sub

-

-

-Sub btLPU_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim lpu_id As Long

-

-    i = Worksheets(VAR_SHEET).Range("QTR_ACTION").Value

-    With Worksheets("LPU_LIST")

-        ent_date = .getEnt_date()

-

-

-        lpu_id = .getCurrentLPU_ID

-        If lpu_id = 0 And i <> 6 Then

-            i = 1

-        End If

-        Select Case i

-            Case 1

-                .SelectLPU_NAME lpu_id, ent_date

-                .Range("JUMP") = ""

-            Case 2

-                .SelectLPU_BDGT lpu_id, ent_date

-                .Range("JUMP") = "LPU_BDGT"

-            Case 3

-                .SelectLPU_HIR lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_HIR"

-

-            Case 4

-                .SelectLPU_TER lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_TER"

-

-            Case 5

-                .SelectLPU_C_ACS lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        End Select

-    End With

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-dbQTR
->>>>>>
-Attribute VB_Name = "dbQTR"

-Option Explicit

-

-Public Type tQTR

-    id As Long

-    entry_date As String

-    rep_id As Long

-    sale_PLAN As Long

-    ClxnH20mg As Long

-    ClxnH40mg As Long

-    ClxnT40mg As Long

-    ClxnC_IM As Long

-    ClxnC_ACS As Long

-End Type

-

-Function Get_QTR_Record(ByVal QTR_ID As Long) As tQTR

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_QTR_Record = dbGet_QTR_Record(dbConnection, QTR_ID)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_Record(dbConnection As Object, ByVal QTR_ID As Long) As tQTR

-    

-    Dim sql As String

-    Dim objQTR As tQTR

-    

-    With objQTR

-        .ClxnC_ACS = 0

-        .ClxnC_IM = 0

-        .ClxnH20mg = 0

-        .ClxnH40mg = 0

-        .ClxnT40mg = 0

-        .entry_date = ""

-        .id = QTR_ID

-    End With

-    

-    sql = "SELECT * FROM quarter WHERE id=" & QTR_ID

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objQTR.entry_date = dbRecordset("entry_date")

-        objQTR.rep_id = dbRecordset("rep_id")

-        objQTR.sale_PLAN = dbRecordset("sale_plan")

-        objQTR.ClxnH20mg = dbRecordset("ClxnH20mg")

-        objQTR.ClxnH40mg = dbRecordset("ClxnH40mg")

-        objQTR.ClxnT40mg = dbRecordset("ClxnT40mg")

-        objQTR.ClxnC_IM = dbRecordset("ClxnC_IM")

-        objQTR.ClxnC_ACS = dbRecordset("ClxnC_ACS")

-        objQTR.id = dbRecordset("id")

-    End If

-    

-    dbGet_QTR_Record = objQTR

-

-End Function

-

-

-Function Get_QTR_Record_by_REP(ent_date As String, rep_id As Long) As tQTR

-    Dim dbConnection As Object

-    Dim allQTR() As tQTR

-    Dim i As Long

-

-    dbOpenConnection dbConnection

-

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id)

-    If i <> 0 Then

-        Get_QTR_Record_by_REP = allQTR(1)

-    End If

-

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTR_Records_by_REP(ByRef all_QTR() As tQTR, ent_date As String, rep_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-

-    GetAll_QTR_Records_by_REP = dbGetAll_QTR_Records_By_REP(dbConnection, all_QTR, ent_date, rep_id)

-

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGetAll_QTR_Records_By_REP(dbConnection As Object, all_QTR() As tQTR, ent_date As String, rep_id As Long) As Integer

-

-    Dim getCount_QTR_SQL As String

-    Dim getAll_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter " & _

-    "WHERE entry_date like '" & ent_date & "' AND rep_id=" & rep_id

-    getAll_QTR_SQL = "SELECT * FROM quarter " & _

-    "WHERE entry_date like '" & ent_date & "' AND rep_id=" & rep_id & " ORDER BY entry_date"

-

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-

-    dbRecordset.Close

-

-    dbGetAll_QTR_Records_By_REP = QTR_Count

-

-    If QTR_Count > 0 Then

-        'we have records

-        ReDim all_QTR(1 To QTR_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTR_SQL, dbConnection

-

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTR As tQTR

-                 With tmp_QTR

-                    .entry_date = dbRecordset("entry_date")

-                    .rep_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .ClxnH20mg = dbRecordset("ClxnH20mg")

-                    .ClxnH40mg = dbRecordset("ClxnH40mg")

-                    .ClxnT40mg = dbRecordset("ClxnT40mg")

-                    .ClxnC_IM = dbRecordset("ClxnC_IM")

-                    .ClxnC_ACS = dbRecordset("ClxnC_ACS")

-                    .id = dbRecordset("id")

-                 End With

-

-                 all_QTR(index) = tmp_QTR

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-cdbQTR
->>>>>>
-Attribute VB_Name = "cdbQTR"

-Option Explicit

-

-Public Type tQTR_COMMON

-    qtr As tQTR

-    i_lcd As Long           ' число ЛПУ в СПИСКЕ

-    lcd() As tLPU_COMMON    ' список ЛПУ

-    c_beds As Long          ' сумма коек

-    c_bdgt_NFG As Long      ' общий бюджет на НФГ

-    c_bdgt_NMG As Long      ' общий бюджет на НМГ

-    c_bdgt_LPU As Long      ' общий бюджет на гепарины

-    c_sale_PLAN As Long     ' план продаж репа

-    c_sale_ALL As Long      ' продажи

-    c_sale_HIR As Long      ' в хирургии

-    c_sale_TER  As Long     ' в терапии

-    c_sale_CRD  As Long     ' в кардиологии

-    c_pat_HIR   As Long     ' пациенты

-    c_pat_TER   As Long     '

-    c_pat_CRD   As Long     '

-    c_pat_ALL   As Long     '

-    c_pat_LPU   As Long     ' Всего операций

-End Type

-

-Function Get_QTR_CommonList_by_REP(ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_QTR_CommonList_by_REP = dbGet_QTR_CommonList_by_REP(dbConnection, qcd, ent_date, rep_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_CommonList_by_REP(dbConnection As Object, ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim allQTR() As tQTR

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id)

-    dbGet_QTR_CommonList_by_REP = i

-    If i > 0 Then

-        ReDim qcd(i)

-        For i = 1 To UBound(allQTR)

-            With qcd(i)

-                .qtr = allQTR(i)

-                .c_beds = 0

-                .c_bdgt_NFG = 0

-                .c_bdgt_NMG = 0

-                .c_bdgt_LPU = 0

-                .c_sale_PLAN = 0

-                .c_pat_HIR = 0

-                .c_pat_TER = 0

-                .c_pat_CRD = 0

-                .c_pat_ALL = 0

-                .c_sale_HIR = 0

-                .c_sale_TER = 0

-                .c_sale_CRD = 0

-                .c_sale_ALL = 0

-                .c_pat_LPU = 0

-                

-                j = dbGet_LPU_CommonQTR(dbConnection, .lcd, .qtr)

-                .i_lcd = j

-                If j > 0 Then

-                    For j = 1 To UBound(.lcd)

-                        .c_beds = .c_beds + .lcd(j).lpu.beds

-                        .c_bdgt_NFG = .c_bdgt_NFG + .lcd(j).bdgt.bdgt_NFG

-                        .c_bdgt_NMG = .c_bdgt_NMG + .lcd(j).bdgt.bdgt_NMG

-                        .c_bdgt_LPU = .c_bdgt_LPU + .lcd(j).bdgt_LPU

-                        .c_sale_PLAN = .c_sale_PLAN + .lcd(j).bdgt.sale_PLAN

-                        .c_pat_HIR = .c_pat_HIR + .lcd(j).pat_HIR

-                        .c_pat_TER = .c_pat_TER + .lcd(j).pat_TER

-                        .c_pat_CRD = .c_pat_CRD + .lcd(j).pat_CRD

-                        .c_pat_ALL = .c_pat_ALL + .lcd(j).pat_ALL

-                        .c_sale_HIR = .c_sale_HIR + .lcd(j).sale_HIR

-                        .c_sale_TER = .c_sale_TER + .lcd(j).sale_TER

-                        .c_sale_CRD = .c_sale_CRD + .lcd(j).sale_CRD

-                        .c_sale_ALL = .c_sale_ALL + .lcd(j).sale_ALL

-                        .c_pat_LPU = .c_pat_LPU + .lcd(j).pat_LPU

-                    Next j

-                    

-                End If

-            End With

-        Next i

-    End If

-End Function

-

-Function GetLastQtr() As String

-    Dim s As String

-    Dim r As Range

-    Set r = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Do While r.Cells(1, 1) <> ""

-        s = r.Cells(1, 1)

-        Set r = r.Cells.Offset(1, 0)

-    Loop

-    GetLastQtr = s

-End Function

-

-Function GetNextQTR(ent_date As String) As String

-    Dim rd As Range

-    Dim idx As Integer

-    Dim b As Variant

-    Dim dlg As dlg_newQTR

-    Set dlg = New dlg_newQTR

-    

-    If ent_date = "" Then

-        Dim ir As Variant

-        idx = 0

-        dlg.Show

-        b = dlg.Tag

-            

-        If IsNumeric(b) Then

-            GetNextQTR = dlg.cbQTR

-        Else

-            GetNextQTR = ""

-        End If

-    Else

-        Set rd = Worksheets(VAR_SHEET).Range("Date_Lst")

-        idx = WorksheetFunction.Match(ent_date, rd, 0)

-        GetNextQTR = WorksheetFunction.index(rd, idx + 1, 1)

-    End If

-End Function

-<<<<<<
-======================
-mRestView
->>>>>>
-Attribute VB_Name = "mRestView"

-Option Explicit

-

-Sub xlRestoreView()

-Attribute xlRestoreView.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute xlRestoreView.VB_ProcData.VB_Invoke_Func = " \n14"

-    With Application

-        .CommandBars("Standard").Visible = True

-        .CommandBars("Formatting").Visible = True

-        .DisplayFormulaBar = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .DisplayStatusBar = True

-    End With

-End Sub

-<<<<<<
-======================
-dlg_newQTR
->>>>>>
-Attribute VB_Name = "dlg_newQTR"

-Attribute VB_Base = "0{31BE411B-9A39-4A9B-93B3-C48ACAE40B79}{0B852A5A-39E9-473F-9770-DE07CFE39BD4}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mDec2TS
->>>>>>
-Attribute VB_Name = "mDec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-CHRT_LPU_BBL
->>>>>>
-Attribute VB_Name = "CHRT_LPU_BBL"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PAT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PAT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-<<<<<<
-======================
-CHRT_PAT_LPU
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_nextQTR
->>>>>>
-Attribute VB_Name = "dlg_nextQTR"

-Attribute VB_Base = "0{D6C6CCC9-854A-4057-8497-6C22D855BE98}{FDC1AE45-9B6A-4E36-AAAC-B49F2C9BC02A}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-cdbLPU
->>>>>>
-Attribute VB_Name = "cdbLPU"

-Option Explicit

-

-Public Type tLPU_COMMON

-    lpu As tLPU

-    bdgt As tBUDGET

-    i_hir As Long

-    hir() As tHIRURGIA

-    i_ter As Long

-    ter() As tTERAPIA

-    i_ACS As Long

-    ACS() As tACS

-    bdgt_LPU As Long

-    sale_HIR As Long

-    sale_TER As Long

-    sale_CRD As Long

-    sale_ALL As Long

-    pat_HIR As Long

-    pat_TER As Long

-    pat_CRD As Long

-    pat_ALL As Long     ' Сумма всех пациентов на клексане

-    pat_LPU As Long     ' Число потенциальных пациентов для продаж клексана

-End Type

-

-Function Get_LPU_CommonQTR(ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    Get_LPU_CommonQTR = dbGet_LPU_CommonQTR(dbConnection, lcd, objQTR)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_CommonQTR(dbConnection As Object, ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    i = dbGetAll_LPU_byQTR(dbConnection, allLPU, objQTR.entry_date, objQTR.rep_id)

-    dbGet_LPU_CommonQTR = i

-    If i > 0 Then

-        ReDim lcd(i)

-        For i = 1 To UBound(allLPU)

-            dbGet_LPU_Common dbConnection, lcd(i), allLPU(i), objQTR

-        Next i

-    End If

-End Function

-

-Sub Get_LPU_Common(ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    dbGet_LPU_Common dbConnection, lcd, cLPU, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbGet_LPU_Common(dbConnection As Object, ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-

-    lcd.lpu = cLPU

-    lcd.bdgt = dbGet_BDGT_Record(dbConnection, cLPU.id, objQTR.entry_date)

-    lcd.i_hir = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, lcd.hir, cLPU.id, objQTR.entry_date)

-    lcd.i_ter = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, lcd.ter, cLPU.id, objQTR.entry_date)

-    lcd.i_ACS = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, lcd.ACS, cLPU.id, objQTR.entry_date)

-    With lcd

-        .bdgt_LPU = .bdgt.bdgt_NFG + .bdgt.bdgt_NMG

-        .pat_LPU = 0

-        If .i_hir > 0 Then

-            .pat_HIR = .hir(1).patients_ambulator_clexan + .hir(1).patients_stationar_clexan

-            .sale_HIR = objQTR.ClxnH20mg * (.hir(1).patients_ambulator_clexan_20mg + .hir(1).patients_stationar_clexan_20mg)

-            .sale_HIR = .sale_HIR + objQTR.ClxnH40mg * (.hir(1).patients_ambulator_clexan_40mg + .hir(1).patients_stationar_clexan_40mg)

-            .pat_LPU = .pat_LPU + .hir(1).operations_per_quarter

-        End If

-        If .i_ter > 0 Then

-            .pat_TER = .ter(1).patients_ambulator_clexan + .ter(1).patients_stationar_clexan

-            .sale_TER = .pat_TER * objQTR.ClxnT40mg

-            .pat_LPU = .pat_LPU + .ter(1).patients_per_quarter

-        End If

-        If .i_ACS > 0 Then

-            .pat_CRD = .ACS(1).patients_stationar_clexan

-            .sale_CRD = .pat_CRD * objQTR.ClxnC_ACS

-            .pat_LPU = .pat_LPU + .ACS(1).patients_per_quarter

-        End If

-        .pat_ALL = .pat_HIR + .pat_TER + .pat_CRD

-        .sale_ALL = .sale_HIR + .sale_TER + .sale_CRD

-    End With

-End Sub

-

-<<<<<<
-======================
-CHRT_PIE
->>>>>>
-Attribute VB_Name = "CHRT_PIE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PLN_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PLN_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_BDGT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_BDGT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_LPU_delete
->>>>>>
-Attribute VB_Name = "dlg_LPU_delete"

-Attribute VB_Base = "0{4E5D8609-88BF-46DB-AB10-7145E0443E10}{F7BD7335-6A91-4F24-985A-8DA608EB2F99}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlg_Mail
->>>>>>
-Attribute VB_Name = "dlg_Mail"

-Attribute VB_Base = "0{DB3353AA-A70C-4D14-962B-2BA0A3F0D97E}{499AB7ED-5BBB-4B89-87DB-F4B59D96D9A5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dbREP_id
->>>>>>
-Attribute VB_Name = "dbREP_id"

-Public Type tREPID

-    rep_id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function GetAll_REPID_Records_by_QTR(ByRef all_REPID() As tREPID, ent_date As String) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_REPID_Records_by_QTR = dbGetAll_REPID_Records_by_QTR(dbConnection, all_REPID, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-Function Get_REPID_Record(id As Long) As tREPID

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REPID_Record = dbGet_REPID_Record(dbConnection, id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_REPID_Records(ByRef all_REPID() As tREPID) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_REPID_Records = dbGetAll_REPID_Records(dbConnection, all_REPID)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function dbGet_REPID_Record(dbConnection As Object, id As Long) As tREPID

-    

-    Dim sql As String

-    Dim objREPID As tREPID

-    

-    objREPID.FirstName = ""

-    objREPID.LastName = ""

-    objREPID.Region = 0

-    objREPID.City = 0

-    sql = "SELECT rep_id, firstname, lastname, region, city FROM " & _

-          "rep WHERE rep_id=" & id

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREPID.rep_id = dbRecordset("rep_id")

-        objREPID.FirstName = dbRecordset("firstname")

-        objREPID.LastName = dbRecordset("lastname")

-        objREPID.Region = dbRecordset("region")

-        objREPID.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REPID_Record = objREPID

-        

-End Function

-

-Function dbGetAll_REPID_Records_by_QTR(dbConnection As Object, ByRef all_REPID() As tREPID, ent_date As String) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    Dim Where As String

-    

-    REPID_Count = 0

-    Where = " WHERE lpu_budget.entry_date like '" & ent_date & "' " & _

-        "AND rep.rep_id=lpu.rep_id AND lpu.id=lpu_budget.lpu_id"

-    

-    

-    getAll_REPID_SQL = "SELECT distinct rep.* FROM rep, lpu, lpu_budget" & Where

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM (" & getAll_REPID_SQL & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records_by_QTR = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Function dbGetAll_REPID_Records(dbConnection As Object, ByRef all_REPID() As tREPID) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    REPID_Count = 0

-    

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM rep"

-    getAll_REPID_SQL = "SELECT * FROM rep"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-cdbExport
->>>>>>
-Attribute VB_Name = "cdbExport"

-Option Explicit

-

-Function GetDBSN() As String

-    Dim n As Long

-    Randomize Timer

-    n = Int((100000000 - 1000000 + 1) * Rnd + 1000000)

-    GetDBSN = Dec2ThirtySix(n)

-End Function

-

-Sub dbExport()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim old_file As String

-    

-    On Error GoTo ErrHandler

-    

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    old_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & "*.*"

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & GetDBSN() & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.DeleteFile old_file, True

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Данные экспортированы в файл:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для передачи", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-Exit Sub

-

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-<<<<<<
-======================
-mRegs
->>>>>>
-Attribute VB_Name = "mRegs"

-Option Explicit

-

-Function GetRegionName(idx As Integer) As String

-    GetRegionName = Worksheets(REGS_SHEET).Range("LST_REGIONS").Cells(idx + 1, 1).Text

-End Function

-

-Function GetCityName(idx_reg As Integer, idx_city As Integer) As String

-    GetCityName = Worksheets(REGS_SHEET).Range("CITY_TABLES").Offset(idx_city + 1, idx_reg * 2).Text

-End Function

-

-Sub testReg()

-    Dim r As Integer

-    Dim c As Integer

-    Dim s As String

-    

-    r = 3

-    c = 3

-    s = GetRegionName(r)

-    s = s & ", " & GetCityName(r, c)

-    MsgBox s

-End Sub

-

-<<<<<<
-======================
-RM_QTR
->>>>>>
-Attribute VB_Name = "RM_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CRGN_QT As Integer = 0

-Const CRGN_PLN As Integer = 2

-Const CRGN_FCT As Integer = 3

-Const CRGN_BDG As Integer = 4

-Const CRGN_LPU As Integer = 5

-Const CRGN_REP As Integer = 6

-Const CRGN_HIR As Integer = 7

-Const CRGN_TER As Integer = 8

-Const CRGN_CRD As Integer = 9

-Const CRGN_CLXN_BDG As Integer = 10

-Const CRGN_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub update_history()

-    Dim objRGN() As tREGION

-    Dim i As Long

-    Dim r As Range

-    Dim cRMan As tREGMAN

-

-    cRMan = Get_REGMAN_Record

-    

-    Range("D4") = cRMan.LastName

-    Range("D5") = cRMan.FirstName

-

-    Range("H4") = GetRegionName(cRMan.Region)

-    

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetRGN_COMM_DATA(objRGN)

-    

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objRGN)

-            r.Offset(i - 1, CRGN_QT) = objRGN(i).ent_date

-            r.Offset(i - 1, CRGN_FCT) = objRGN(i).total_SALE

-            r.Offset(i - 1, CRGN_PLN) = objRGN(i).sale_PLAN

-            r.Offset(i - 1, CRGN_BDG) = objRGN(i).total_BDGT

-            r.Offset(i - 1, CRGN_LPU) = objRGN(i).total_LPU

-            r.Offset(i - 1, CRGN_REP) = objRGN(i).total_REP

-            r.Offset(i - 1, CRGN_HIR) = objRGN(i).total_HIR

-            r.Offset(i - 1, CRGN_TER) = objRGN(i).total_TER

-            r.Offset(i - 1, CRGN_CRD) = objRGN(i).total_ACS

-            If objRGN(i).total_BDGT <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_BDG) = objRGN(i).total_SALE / objRGN(i).total_BDGT

-            End If

-            If objRGN(i).total_BDGT_NMG <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_NMG) = objRGN(i).total_SALE / objRGN(i).total_BDGT_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRGN_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRM_QtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR_RM

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR_RM

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR_RM

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = RM_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CRGN_QT + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    If r = "" Then

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = currRange.address

-        With Worksheets("REP_LIST")

-            .Range("ret_addr") = "RM_QTR"

-            .Range("ent_date") = r

-            .Range("VIEW_ONLY") = True

-        End With

-    End If

-    Cancel = True

-    btRM_QTR_Do_IT

-End Sub

-

-<<<<<<
-======================
-dbREG_MAN
->>>>>>
-Attribute VB_Name = "dbREG_MAN"

-Option Explicit

-

-Public Type tREGMAN

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function Get_REGMAN_Record() As tREGMAN

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REGMAN_Record = dbGet_REGMAN_Record(dbConnection)

-    dbCloseConnection dbConnection

-End Function

-

-Sub Set_REGMAN_Record(cREGMAN As tREGMAN)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbSet_REGMAN_Record dbConnection, cREGMAN

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_REGMAN_Record(dbConnection As Object) As tREGMAN

-    

-    Dim sql As String

-    Dim objREGMAN As tREGMAN

-    

-    objREGMAN.FirstName = ""

-    objREGMAN.LastName = ""

-    objREGMAN.Region = 0

-    objREGMAN.City = 0

-    sql = "SELECT firstname, lastname, region, city FROM " & _

-          "reg_man"

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREGMAN.FirstName = dbRecordset("firstname")

-        objREGMAN.LastName = dbRecordset("lastname")

-        objREGMAN.Region = dbRecordset("region")

-        objREGMAN.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REGMAN_Record = objREGMAN

-        

-End Function

-

-Public Sub dbSet_REGMAN_Record(dbConnection As Object, ByRef objREGMAN As tREGMAN)

-  

-    Dim DeleteSQL As String

-    Dim InsertSQL As String

-    

-    DeleteSQL = "DELETE FROM reg_man"

-    InsertSQL = "INSERT INTO reg_man (firstname, lastname, region, city) VALUES (" & _

-    "'" & objREGMAN.FirstName & "', " & _

-    "'" & objREGMAN.LastName & "', " & _

-    objREGMAN.Region & ", " & _

-    objREGMAN.City & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    dbRecordset.Open InsertSQL, dbConnection

-       

-End Sub

-

-

-

-<<<<<<
-======================
-dbDatabaseMerge
->>>>>>
-Attribute VB_Name = "dbDatabaseMerge"

-Option Explicit

-

-Public Type tDBFIELD

-    name As String

-End Type

-

-Public Type tDBTABLE

-    name As String

-    field() As tDBFIELD

-End Type

-

-

-Function dbGetConnection(dbAccessFileFullPath As String) As Object

-    Dim dbConnection As Object

-    Dim dbAccessFilePasswd As String

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFileFullPath & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    Set dbGetConnection = dbConnection

-End Function

-

-Sub dbCloseOpenedConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteOpenedSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-Function dbMergeREP(from_dbConnection As Object, to_dbConnection As Object) As Long

-

-    Dim getRecordset As Object

-    Dim getREPData_SQL As String

-    Dim REP_fn As String

-    Dim REP_ln As String

-    Dim REP_region As String

-    Dim REP_city As String

-

-

-    getREPData_SQL = "SELECT * FROM rep"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getREPData_SQL, from_dbConnection

-        

-        If Not getRecordset.BOF Then

-            REP_fn = getRecordset("firstname")

-            REP_ln = getRecordset("lastname")

-            REP_city = getRecordset("city")

-            REP_region = getRecordset("region")

-        Else

-            MsgBox "There is no information about rep! This database cannot be merged!!!"

-            dbMergeREP = -1

-            Exit Function

-        End If

-    

-    Dim insertRecordset As Object

-    Set insertRecordset = CreateObject("ADODB.Recordset")

-        

-    insertRecordset.Open "rep", to_dbConnection, 2, 2

-    insertRecordset.addnew

-        

-    insertRecordset("firstname") = REP_fn

-    insertRecordset("lastname") = REP_ln

-    insertRecordset("region") = REP_region

-    insertRecordset("city") = REP_city

-    insertRecordset.Update

-    insertRecordset.MoveLast

-    'new ID

-    

-    dbMergeREP = insertRecordset("rep_id")

-    

-End Function

-

-Sub dbMergeLPU(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getLPU_SQL As String

-    Dim getRecordset As Object

-    Dim idx As Long

-    idx = 1

-    

-    getLPU_SQL = "SELECT * FROM lpu"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getLPU_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            ReDim Preserve objLPU(1 To idx)

-            objLPU(idx).old_lpu_id = getRecordset("id")

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "lpu", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("name") = getRecordset("name")

-            insRS("address") = getRecordset("address")

-            insRS("beds") = getRecordset("beds")

-            insRS.Update

-            insRS.MoveLast

-            'new ID

-            

-            objLPU(idx).new_lpu_id = insRS("id")

-                        

-            idx = idx + 1

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about LPU! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-

-Sub dbMergeLPURelated(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object)

-

-    ' 6 tables to change

-    Dim tables(1 To 5) As tDBTABLE

-    

-    'lpu budget

-    tables(1).name = "lpu_budget"

-    ReDim tables(1).field(1 To 4)

-    

-    tables(1).field(1).name = "entry_date"

-    tables(1).field(2).name = "bdgt_NMG"

-    tables(1).field(3).name = "bdgt_NFG"

-    tables(1).field(4).name = "sale_PLAN"

-    

-    'lpu hir

-    tables(2).name = "lpu_hir"

-    ReDim tables(2).field(1 To 13)

-    

-    tables(2).field(1).name = "entry_date"

-    tables(2).field(2).name = "operations_per_quarter"

-    tables(2).field(3).name = "risk_percent"

-    tables(2).field(4).name = "patients_with_risk_ON"

-    tables(2).field(5).name = "patients_ambulator"

-    tables(2).field(6).name = "patients_ambulator_nmg"

-    tables(2).field(7).name = "patients_ambulator_clexan"

-    tables(2).field(8).name = "patients_ambulator_clexan_40mg"

-    tables(2).field(9).name = "patients_ambulator_clexan_20mg"

-    tables(2).field(10).name = "patients_stationar_nmg"

-    tables(2).field(11).name = "patients_stationar_clexan"

-    tables(2).field(12).name = "patients_stationar_clexan_40mg"

-    tables(2).field(13).name = "patients_stationar_clexan_20mg"

-    

-    

-    'lpu acs

-    tables(3).name = "lpu_acs"

-    ReDim tables(3).field(1 To 5)

-    

-    tables(3).field(1).name = "entry_date"

-    tables(3).field(2).name = "patients_with_geparins"

-    tables(3).field(3).name = "patients_per_quarter"

-    tables(3).field(4).name = "patients_stationar_nmg"

-    tables(3).field(5).name = "patients_stationar_clexan"

-    

-    'lpu acs

-    tables(4).name = "lpu_im"

-    ReDim tables(4).field(1 To 5)

-    

-    tables(4).field(1).name = "entry_date"

-    tables(4).field(2).name = "patients_with_geparins"

-    tables(4).field(3).name = "patients_per_quarter"

-    tables(4).field(4).name = "patients_stationar_nmg"

-    tables(4).field(5).name = "patients_stationar_clexan"

-    

-    

-    'lpu acs

-    tables(5).name = "lpu_ter"

-    ReDim tables(5).field(1 To 9)

-    

-    tables(5).field(1).name = "entry_date"

-    tables(5).field(2).name = "patients_per_quarter"

-    tables(5).field(3).name = "risk_percent"

-    tables(5).field(4).name = "patients_with_risk_ON"

-    tables(5).field(5).name = "patients_ambulator"

-    tables(5).field(6).name = "patients_ambulator_nmg"

-    tables(5).field(7).name = "patients_ambulator_clexan"

-    tables(5).field(8).name = "patients_stationar_nmg"

-    tables(5).field(9).name = "patients_stationar_clexan"

-    

-    

-    

-    Dim tbl_idx As Integer

-    

-    For tbl_idx = 1 To UBound(tables)

-        

-        Dim getSQL As String

-        Dim getRS As Object

-        

-        

-        

-        Set getRS = CreateObject("ADODB.Recordset")

-        

-        getSQL = "SELECT * FROM " & tables(tbl_idx).name

-        getRS.Open getSQL, from_db

-        

-        If Not getRS.BOF Then

-            Do While Not getRS.EOF

-                Dim insRS As Object

-                Set insRS = CreateObject("ADODB.Recordset")

-                

-                insRS.Open tables(tbl_idx).name, to_db, 2, 2

-                insRS.addnew

-                Dim fld_idx As Integer

-    

-                    For fld_idx = 1 To UBound(tables(tbl_idx).field)

-                        insRS(tables(tbl_idx).field(fld_idx).name) = getRS(tables(tbl_idx).field(fld_idx).name)

-                        insRS("lpu_id") = findNewLPU_IDByOld(objLPU, getRS("lpu_id"))

-                    Next fld_idx

-                    

-                insRS.Update

-                insRS.MoveLast

-                getRS.MoveNext

-            Loop

-        End If

-        

-        

-    Next tbl_idx

-

-End Sub

-

-Function findNewLPU_IDByOld(objLPU() As tLPUCONVERTION, old_id As Long)

-

-Dim i As Integer

-For i = 1 To UBound(objLPU)

-    If objLPU(i).old_lpu_id = old_id Then

-        findNewLPU_IDByOld = objLPU(i).new_lpu_id

-        Exit Function

-    End If

-Next i

-

-findNewLPU_IDByOld = -1

-End Function

-

-

-

-

-

-Sub dbMergeQTR(from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getQTR_SQL As String

-    Dim getRecordset As Object

-    

-    getQTR_SQL = "SELECT * FROM quarter"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getQTR_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "quarter", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("entry_date") = getRecordset("entry_date")

-            insRS("sale_plan") = getRecordset("sale_plan")

-            insRS("ClxnH20mg") = getRecordset("ClxnH20mg")

-            insRS("ClxnH40mg") = getRecordset("ClxnH40mg")

-            insRS("ClxnT40mg") = getRecordset("ClxnT40mg")

-            insRS("ClxnC_IM") = getRecordset("ClxnC_IM")

-            insRS("ClxnC_ACS") = getRecordset("ClxnC_ACS")

-            

-            

-            insRS.Update

-            

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about quarter budget! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-dbMerge
->>>>>>
-Attribute VB_Name = "dbMerge"

-Option Explicit

-

-Public Type tLPUCONVERTION

-    old_lpu_id As Long

-    new_lpu_id As Long

-End Type

-

-

-

-Sub Merge_Clear_All_Data(access_file_full_path As String)

-    

-    Dim db As Object

-    Dim tables_to_clear() As String

-    On Error GoTo ErrHandler

-    

-    ReDim tables_to_clear(1 To 8)

-    tables_to_clear(1) = "rep"

-    tables_to_clear(2) = "lpu"

-    tables_to_clear(3) = "lpu_budget"

-    tables_to_clear(4) = "lpu_hir"

-    tables_to_clear(5) = "lpu_ter"

-    tables_to_clear(6) = "lpu_acs"

-    tables_to_clear(7) = "lpu_im"

-    tables_to_clear(8) = "quarter"

-    

-    Set db = dbGetConnection(access_file_full_path)

-

-    Dim i As Integer

-    

-    For i = 1 To UBound(tables_to_clear)

-        

-        If tables_to_clear(i) <> "" Then

-            Dim Clear_SQL As String

-            Clear_SQL = "DELETE FROM " & tables_to_clear(i)

-            dbExecuteOpenedSQL db, Clear_SQL

-        Else

-            'do nothing or show message

-        End If

-    Next i

-    

-    dbCloseOpenedConnection db

-    Set db = Nothing

-    

-'    Dim Engine As Object

-'    Set Engine = CreateObject("JRO.JetEngine")

-'    Engine.CompactDatabase "Password=password;Data Source=" & access_file_full_path, _

-'    "Password=password;Data Source=c:\tmp\1.mdb"

-    

-Exit Sub

-

-ErrHandler:

-    MsgBox "something wrong: " & err.Description

-    Resume Next

-    

-End Sub

-

-Function MergeREP(from_file As String, to_file As String) As Long

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    Dim new_rep_id As Long

-

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    MergeREP = dbMergeREP(db1, db2)

-    'MsgBox "new rep ID is " & new_rep_id

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Function

-

-Sub MergeQTR(from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeQTR db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-

-Sub MergeLPU(objLPU() As tLPUCONVERTION, from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeLPU objLPU, db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-Sub MergeLPURelated(objLPU() As tLPUCONVERTION, from_file As String, to_file As String)

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    dbMergeLPURelated objLPU, db1, db2

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-

-End Sub

-

-Sub MergeGlobal(rm_files() As String, fm_file As String)

-

-    Dim i As Integer

-    'clear output file content

-    Merge_Clear_All_Data fm_file

-    

-    For i = 1 To UBound(rm_files)

-        

-        Dim rm_file As String

-        'setup input and output files

-        rm_file = rm_files(i)

-        

-        Dim new_rm_id As Long

-        ' insert MR data and get new rm_id

-        new_rm_id = MergeRM(rm_file, fm_file)

-        

-        '''''

-        ''' Foeach rep_id in getAllREPFromFile

-        

-        Dim new_rep_id As Long

-        ' insert REP data and get new rep_id

-        new_rep_id = MergeREP(rep_file, rm_file, new_rm_id)

-        

-        Dim objLPU() As tLPUCONVERTION

-        'insert all LPU using new generated rep_id

-        'and populate objLPU old->new relation object

-        

-        MergeLPU objLPU, rep_file, rm_file, new_rep_id

-        'insert quarter data using new rep_id

-        MergeQTR rep_file, rm_file, new_rep_id

-        

-        

-        ' and.... insert all another data (5 tables excl version and hw)

-        'using objLPU old->new relation object

-        MergeLPURelated objLPU, rep_file, rm_file

-    

-    

-    Next i

-    

-End Sub

-

-Function GetDBList(MyPath As String, ByRef dblist() As String) As Integer

-    Dim i As Integer

-    Dim MyName, MyMask

-    MyMask = MyPath & PROGRAM_IMPORTNAME & PROGRAM_DATAEXT

-    i = 0

-    MyName = Dir(MyMask)      ' Retrieve the first entry.

-    Do While MyName <> ""    ' Start the loop.

-        ' Ignore the current directory and the encompassing directory.

-        If MyName <> "." And MyName <> ".." Then

-            ' Use bitwise comparison to make sure MyName is a directory.

-            i = i + 1

-            ReDim Preserve dblist(i)

-            dblist(i) = MyPath & MyName

-        End If

-        MyName = Dir    ' Get next entry.

-    Loop

-    GetDBList = i

-End Function

-

-Sub test_import()

-    Dim MyPath As String

-    Dim flist() As String

-    Dim i As Integer

-    MyPath = "g:\"

-    i = GetDBList(MyPath, flist)

-    If i > 0 Then

-        MergeGlobal flist, GetWBPath(ThisWorkbook.FullName) & "clexane-rm.mdb"

-    End If

-End Sub

-<<<<<<
-======================
-dbxyz_test
->>>>>>
-Attribute VB_Name = "dbxyz_test"

-Option Explicit

-

-Sub mrg_main()

-    Dim rep_files(1 To 2) As String

-    Dim rm_file As String

-    

-    'setup input and output files

-    rep_files(1) = "e:\work\aventis\clexane-mr1.mdb"

-    rep_files(2) = "e:\work\aventis\clexane-mr2.mdb"

-    

-    'setup output file

-    rm_file = "e:\work\aventis\clexane-rm.mdb"

-    

-    MergeGlobal rep_files, rm_file

-End Sub

-

-Sub ttt()

-    Dim rcd() As tREPID_COMMON

-    Dim i As Long

-    i = Get_REP_CommonList_by_QTR(rcd, "2003-III")

-End Sub

-

-Sub getallreps()

-    Dim i As Integer

-    Dim j As Integer

-    Dim k As Integer

-    Dim s As String

-    

-    Dim allREPID() As tREPID

-    Dim allQTRREP() As tQTR

-    Dim allLPU() As tLPU

-    

-    i = GetAll_REPID_Records(allREPID)

-    

-    If i > 0 Then

-        For i = 1 To UBound(allREPID)

-            j = GetAll_QTR_Records_by_REP(allQTRREP, "%", allREPID(i).rep_id)

-            If j > 0 Then

-                For j = 1 To UBound(allREPID)

-                    k = GetAll_LPU_byQTR(allLPU, allQTRREP(j).entry_date, allREPID(i).rep_id)

-                    If k > 0 Then

-                        For k = 1 To UBound(allLPU)

-                            MsgBox allLPU(k).name

-                        Next k

-                    End If

-                Next j

-            End If

-        Next i

-    End If

-End Sub

-

-<<<<<<
-======================
-dbQTR_RM
->>>>>>
-Attribute VB_Name = "dbQTR_RM"

-Option Explicit

-

-Public Type tQTRRM

-    id As Long

-    entry_date As String

-    rm_id As Long

-    sale_PLAN As Long

-End Type

-

-

-Sub Insert_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objQTRRM.id <> 0 Then

-        dbUpdate_QTRRM_Record dbConnection, objQTRRM

-    Else

-        dbInsert_QTRRM_Record dbConnection, objQTRRM

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-Function Get_QTRRM_Record(ent_date As String) As tQTRRM

-    Dim dbConnection As Object

-    Dim allQTRRM() As tQTRRM

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    i = dbGetAll_QTRRM_Records(dbConnection, allQTRRM, ent_date)

-    If i <> 0 Then

-        Get_QTRRM_Record = allQTRRM(1)

-    End If

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTRRM_Records(ByRef all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_QTRRM_Records = dbGetAll_QTRRM_Records(dbConnection, all_QTRRM, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_QTRRM_Record dbConnection, objQTRRM

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objQTRRM.ID <> 0 then updatre else insert

-Sub dbInsert_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "quarter_rm", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objQTRRM

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("sale_plan") = .sale_PLAN

-        dbRecordset("rm_id") = .rm_id

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objQTRRM.id = dbRecordset("id")

-

-End Sub

-

-Sub dbUpdate_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim Update_SQL As String

-    

-    With objQTRRM

-        Update_SQL = "UPDATE quarter_rm SET " & _

-            "entry_date='" & .entry_date & "'" & "," & _

-            "rm_id=" & .rm_id & "," & _

-            "sale_plan=" & .sale_PLAN & "," & _

-            " WHERE id=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if ent_date = % then all_records

-Function dbGetAll_QTRRM_Records(dbConnection As Object, all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    

-    Dim getCount_QTRRM_SQL As String

-    Dim getAll_QTRRM_SQL As String

-    Dim QTRRM_Count As Long

-    QTRRM_Count = 0

-    

-    getCount_QTRRM_SQL = "SELECT COUNT(*) AS QTRRM_TOTAL FROM quarter_rm WHERE entry_date like '" & ent_date & "'"

-    getAll_QTRRM_SQL = "SELECT * FROM quarter_rm WHERE entry_date like '" & ent_date & "' ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTRRM_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTRRM_Count = dbRecordset("QTRRM_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_QTRRM_Records = QTRRM_Count

-    

-    If QTRRM_Count > 0 Then

-        'we have records

-        ReDim all_QTRRM(1 To QTRRM_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTRRM_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTRRM As tQTRRM

-                 With tmp_QTRRM

-                    .entry_date = dbRecordset("entry_date")

-                    .rm_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .id = dbRecordset("id")

-                 End With

-                 

-                 all_QTRRM(index) = tmp_QTRRM

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM quarter_rm " & _

-    "WHERE id=" & objQTRRM.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-    

-    'delete related budget entries

-    MsgBox "remember delete related"

-'    dbDelete_BDGT_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Hir_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Ter_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_ACS_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-       

-End Sub

-

-

-<<<<<<
-======================
-REP_LIST
->>>>>>
-Attribute VB_Name = "REP_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentREP_ID() As Long

-    Dim r As Range

-

-    With Worksheets("REP_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CREP_ID)

-    End With

-

-    getCurrentREP_ID = r

-End Function

-

-Public Sub REP_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Rep_Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Rep_Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Rep_Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Rep_Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectREP_LPU(rep_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim r_id As Long

-    

-    Range("JUMP") = "LPU_LIST"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-        .Range("ent_date") = ent_date

-    End With

-End Sub

-

-Public Sub SelectREP_QTR(rep_id As Long)

-    Dim vo As Boolean

-    Dim r_id As Long

-    

-    Range("JUMP") = "REP_QTR"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("REP_QTR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateREPList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim rep_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CREP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CREP_AREA).row, CREP_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    rep_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CREP_AREA).Column

-    

-    If i < 4 Then

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 1

-    Else

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 2

-    End If

-    

-    If rep_id = 0 Then

-        Range("LAST_FOCUS") = Range(CREP_AREA).address

-    End If

-

-    If rep_id = 0 Then

-        i = CREP_NAME

-        Range("JUMP") = ""

-    Else

-        btREP_LIST_DO_IT

-    End If

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateREPList()

-    Dim rcd() As tREPID_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-

-    ent_date = getEnt_date

-

-    i = Get_REP_CommonList_by_QTR(rcd, ent_date)

-

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(rcd)

-            r.Offset(i - 1, CREP_NAME) = rcd(i).rep.FirstName & " " & rcd(i).rep.LastName

-            r.Offset(i - 1, CREP_ID) = rcd(i).rep.rep_id

-            r.Offset(i - 1, CREP_BEDS) = rcd(i).qtrs(1).c_beds

-

-            r.Offset(i - 1, CREP_NFG) = rcd(i).qtrs(1).c_bdgt_NFG

-            r.Offset(i - 1, CREP_NMG) = rcd(i).qtrs(1).c_bdgt_NMG

-

-            r.Offset(i - 1, CREP_PLAN) = rcd(i).qtrs(1).qtr.sale_PLAN

-

-            r.Offset(i - 1, CREP_HIR) = rcd(i).qtrs(1).c_pat_HIR

-            r.Offset(i - 1, CREP_TER) = rcd(i).qtrs(1).c_pat_TER

-            r.Offset(i - 1, CREP_CAR) = rcd(i).qtrs(1).c_pat_CRD

-            r.Offset(i - 1, CREP_FACT) = rcd(i).qtrs(1).c_sale_ALL

-            r.Offset(i - 1, CREP_PAT_LPU) = rcd(i).qtrs(1).c_pat_LPU

-            r.Offset(i - 1, CREP_BDGT) = rcd(i).qtrs(1).c_bdgt_LPU

-            If rcd(i).qtrs(1).c_bdgt_LPU > 0 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = rcd(i).qtrs(1).c_sale_ALL / rcd(i).qtrs(1).c_bdgt_LPU

-            End If

-            If r.Offset(i - 1, CREP_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-

-

-<<<<<<
-======================
-mREP_LIST
->>>>>>
-Attribute VB_Name = "mREP_LIST"

-Option Explicit

-

-Public Const CREP_AREA As String = "B12"

-Public Const CREP_NAME As Integer = 0

-Public Const CREP_NAME1 As Integer = 1

-Public Const CREP_NAME2 As Integer = 2

-Public Const CREP_ID As Integer = 3

-Public Const CREP_BEDS As Integer = 4

-Public Const CREP_NFG As Integer = 5

-Public Const CREP_NMG As Integer = 6

-Public Const CREP_HIR As Integer = 7

-Public Const CREP_TER As Integer = 8

-Public Const CREP_CAR As Integer = 9

-Public Const CREP_FACT As Integer = 10

-Public Const CREP_PLAN As Integer = 11

-Public Const CREP_PAT_LPU As Integer = 16

-Public Const CREP_BDGT As Integer = 17

-Public Const CREP_PAT_ALL As Integer = 16

-

-

-

-Sub EditREP(cRep As tREPID, ent_date As String)

-    NoFunc

-End Sub

-

-Sub Rep_Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-        End If

-    Next i

-

-End Sub

-

-Sub Rep_Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btREP_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = "RM_QTR"

-    End With

-    ThisWorkbook.Worksheets("RM_QTR").Activate

-End Sub

-

-

-Sub btREP_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim rep_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("REP_LST_DETALS")

-    With Worksheets("REP_LIST")

-        rep_id = .getCurrentREP_ID

-        

-        Select Case i

-            Case 1:

-                .SelectREP_QTR rep_id

-            Case 2:

-                ent_date = .getEnt_date()

-                .SelectREP_LPU rep_id, ent_date

-        End Select

-    End With

-    

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-

-

-

-<<<<<<
-======================
-cdbREP
->>>>>>
-Attribute VB_Name = "cdbREP"

-Option Explicit

-

-Public Type tREPID_COMMON

-    rep As tREPID

-    i_qtrs As Integer

-    qtrs() As tQTR_COMMON

-End Type

-

-Function Get_REP_CommonList_by_QTR(ByRef rcd() As tREPID_COMMON, ent_date As String) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_REP_CommonList_by_QTR = dbGet_REP_CommonList_by_QTR(dbConnection, rcd, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_REP_CommonList_by_QTR(dbConnection As Object, ByRef rcd() As tREPID_COMMON, ent_date As String) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim k As Long

-    Dim allREPID() As tREPID

-    

-    i = dbGetAll_REPID_Records_by_QTR(dbConnection, allREPID, ent_date)

-    dbGet_REP_CommonList_by_QTR = i

-    If i > 0 Then

-        ReDim rcd(i)

-        For i = 1 To UBound(allREPID)

-            rcd(i).rep = allREPID(i)

-            rcd(i).i_qtrs = Get_QTR_CommonList_by_REP(rcd(i).qtrs, ent_date, allREPID(i).rep_id)

-        Next i

-    End If

-End Function

-

-

-

-<<<<<<
-======================
-CHRT_PAT_LPU_A
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU_A"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-cdbRegion
->>>>>>
-Attribute VB_Name = "cdbRegion"

-Option Explicit

-

-Type tREGION

-    ent_date As String

-    total_SALE As Long ' общий объем продаж

-    total_BDGT As Long ' бюджет всех ЛПУ

-    total_BDGT_NMG As Long ' бюджет всех ЛПУ на НМГ

-    total_LPU As Long ' число ЛПУ

-    total_REP   As Long ' число репов

-    total_BEDS As Long ' общее число коек

-    total_HIR As Long '  общее число пациентов на клексане в хирургии

-    total_TER As Long '  общее число пациентов на клексане в терапии

-    total_ACS As Long '  общее число пациентов на клексане в кардиологии

-    sale_PLAN As Long '  план продаж Авентиса

-End Type

-

-Function GetRGN_COMM_DATA(ByRef reg_data() As tREGION) As Integer

-    Dim q_date() As String

-    Dim q_count As Integer, i As Integer

-    

-    q_count = getAllQTRNames(q_date)

-    If q_count > 0 Then

-        ReDim reg_data(q_count)

-        For i = 1 To q_count

-            Dim current_rep_count As Integer

-            current_rep_count = getREGION_by_QTR(q_date(i), reg_data(i))

-        Next i

-    End If

-    

-    GetRGN_COMM_DATA = q_count

-End Function

-

-Function getAllQTRNames(ByRef qtr_lst() As String) As Integer

-    

-    Dim sql As String

-    Dim i As Integer

-    Dim db As Object, rs As Object

-    

-    

-    sql = "SELECT DISTINCT entry_date FROM lpu_budget"

-    i = 0

-    

-    dbOpenConnection db

-    Set rs = CreateObject("ADODB.Recordset")

-    

-    rs.Open sql, db

-        

-        If Not rs.BOF Then

-            Do While Not rs.EOF

-                i = i + 1

-                ReDim Preserve qtr_lst(i)

-                qtr_lst(i) = rs("entry_date")

-                rs.MoveNext

-            Loop

-        Else

-            getAllQTRNames = 0

-            Exit Function

-        End If

-    getAllQTRNames = i

-    dbCloseConnection db

-End Function

-

-Function getREGION_by_QTR(ent_date As String, treg As tREGION) As Integer

-    Dim rep_count As Integer

-    rep_count = 0

-    

-    Dim reps() As tREPID_COMMON

-    rep_count = Get_REP_CommonList_by_QTR(reps, ent_date)

-    

-    treg.ent_date = ent_date

-    treg.total_BDGT = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.total_BDGT_NMG = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.sale_PLAN = 0 ' quarter.sale_plan

-    treg.total_SALE = 0 'summ of

-    ' hir = (amb40+st40)*pr40 + (amb20+st20)*pr20

-    'ter (amb_clx+stat_clx)*price

-    ' acs xxx

-    'price per rep

-    treg.total_HIR = 0 'patiens clxn

-    treg.total_TER = 0 'patiens clxn

-    treg.total_ACS = 0 'patiens clxn

-    treg.total_LPU = 0 'lpu

-    treg.total_BEDS = 0 'lpu.beds

-    treg.total_REP = 0 '

-    

-    If rep_count > 0 Then

-        Dim i As Integer

-        

-        For i = 1 To UBound(reps)

-            ' current rep is reps(i)

-            With reps(i)

-                treg.total_BDGT = treg.total_BDGT + .qtrs(1).c_bdgt_NFG + .qtrs(1).c_bdgt_NMG

-                treg.total_BDGT_NMG = treg.total_BDGT_NMG + .qtrs(1).c_bdgt_NMG

-                treg.sale_PLAN = treg.sale_PLAN + .qtrs(1).c_sale_PLAN

-                treg.total_SALE = treg.total_SALE + .qtrs(1).c_sale_ALL

-                treg.total_HIR = treg.total_HIR + .qtrs(1).c_pat_HIR

-                treg.total_TER = treg.total_TER + .qtrs(1).c_pat_TER

-                treg.total_ACS = treg.total_ACS + .qtrs(1).c_pat_CRD

-                treg.total_LPU = treg.total_LPU + .qtrs(1).i_lcd

-                treg.total_BEDS = treg.total_BEDS + .qtrs(1).c_beds

-                treg.total_REP = treg.total_REP + 1

-            End With

-            

-        Next i

-        

-    End If

-    

-    getREGION_by_QTR = treg.total_REP

-End Function

-

-<<<<<<
-======================
-mRM_QTR
->>>>>>
-Attribute VB_Name = "mRM_QTR"

-Option Explicit

-

-Sub btRM_QTR_Do_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    Dim i As Integer

-    Dim def_dir As String

-    Dim flist() As String

-    

-    idx = Worksheets(VAR_SHEET).Range("RM_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            def_dir = GetWBPath(ThisWorkbook.FullName)

-            If GetImportDirectory(def_dir, flist) Then

-                Dim db_list() As String

-                i = GetDBList(flist(0), db_list)

-                If i > 0 Then

-                    MergeGlobal db_list, GetWBPath(ThisWorkbook.FullName) & "clexane-rm.mdb"

-                End If

-            End If

-            Worksheets(RM_QTR_SHEET).update_history

-        Case 2

-            Worksheets("REP_LIST").Select

-        Case 3

-            cmExport

-    End Select

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-End Sub

-

-<<<<<<
-======================
-mImport
->>>>>>
-Attribute VB_Name = "mImport"

-    Option Explicit

-

-Const OFN_ALLOWMULTISELECT As Long = 512

-Const OFN_EXPLORER As Long = 524288

-Const OFN_HIDEREADONLY As Long = 4

-Const OFN_NONETWORKBUTTON As Long = 131072

-Const OFN_READONLY As Long = 1

-       

-Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _

-    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

-

-Private Type OPENFILENAME

-    lStructSize As Long

-    hWndOwner As Long

-    hInstance As Long

-    lpstrFilter As String

-    lpstrCustomFilter As String

-    nMaxCustFilter As Long

-    nFilterIndex As Long

-    lpstrFile As String

-    nMaxFile As Long

-    lpstrFileTitle As String

-    nMaxFileTitle As Long

-    lpstrInitialDir As String

-    lpstrTitle As String

-    flags As Long

-    nFileOffset As Integer

-    nFileExtension As Integer

-    lpstrDefExt As String

-    lCustData As Long

-    lpfnHook As Long

-    lpTemplateName As String

-End Type

-

-Function GetImportDirectory(DB_dir As String, flist() As String) As Boolean

-    Dim OpenFile As OPENFILENAME

-    Dim lReturn As Long

-    Dim sFilter As String

-    

-    OpenFile.lStructSize = Len(OpenFile)

-    '         OpenFile.hwndOwner = Form1.hWnd

-    '         OpenFile.hInstance = App.hInstance

-    sFilter = "Clexane Data Files" & Chr(0) & "mr*.mdb" & Chr(0)

-    OpenFile.lpstrFilter = sFilter

-    OpenFile.nFilterIndex = 1

-    OpenFile.lpstrFile = String(257, 0)

-    OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1

-    OpenFile.lpstrFileTitle = OpenFile.lpstrFile

-    OpenFile.nMaxFileTitle = OpenFile.nMaxFile

-    OpenFile.lpstrInitialDir = DB_dir

-    OpenFile.lpstrTitle = "Импорт данных"

-    OpenFile.flags = OFN_HIDEREADONLY + OFN_ALLOWMULTISELECT + OFN_EXPLORER

-    lReturn = GetOpenFileName(OpenFile)

-    If lReturn = 0 Then

-        GetImportDirectory = False

-    Else

-        GetImportDirectory = True

- 

-        flist = Split(OpenFile.lpstrFile, Chr(0), Compare:=vbBinaryCompare)

-        Dim i As Integer

-        i = 0

-        Do While flist(i) <> ""

-            i = i + 1

-        Loop

-        If i = 1 Then

-            flist(1) = flist(0)

-            flist(0) = GetWBPath(flist(1))

-            flist(1) = GetWBName(flist(1))

-        Else

-            flist(0) = flist(0) & "\"

-        End If

-    End If

-End Function

-<<<<<<
-======================
-mImport2
->>>>>>
-Attribute VB_Name = "mImport2"

-Option Explicit

-

-Sub FOpen()

-    Dim flist As String

-    Dim fileToOpen, s

-    flist = ""

-    fileToOpen = Application _

-        .GetOpenFileName("Data Files (*.mdb), mr*.mdb", title:="Импорт данных", MultiSelect:=True)

-    If fileToOpen <> False Then

-        For Each s In fileToOpen

-            flist = flist & s & "; "

-        Next s

-        MsgBox "Open " & flist

-    End If

-End Sub

-

-Sub t2()

-    Dim d As dlgImprtDB

-    Set d = New dlgImprtDB

-    d.Show

-End Sub

-

-<<<<<<
-======================
-dlgImprtDB
->>>>>>
-Attribute VB_Name = "dlgImprtDB"

-Attribute VB_Base = "0{D75A4C48-C417-4050-8B59-6ADE57EB3F46}{A7D47189-76ED-4894-92BF-5E93B11D524E}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Private Sub btSelAll_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = True

-    Next i

-End Sub

-

-Private Sub btUnselect_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = False

-    Next i

-End Sub

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Unprotect "password"

-    ThisWorkbook.Save

-End Sub

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Protect password:="password"

-    Worksheets("Calc").Protect password:="password", userInterfaceonly:=True

-    Worksheets("Calc").Select

-    Worksheets("Calc").Range("A7").Select

-End Sub

-<<<<<<
-======================
-Calc
->>>>>>
-Attribute VB_Name = "Calc"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Sub SelectAll()

-    Dim Sh As Shape

-    For Each Sh In Shapes

-        If InStr(1, Sh.Name, "Check") Then

-            Sh.Select

-            Selection.Value = xlOn

-        End If

-    Next Sh

-    Range("A7").Select

-End Sub

-

-Sub ClearAll()

-    Dim Sh As Shape

-    For Each Sh In Shapes

-        If InStr(1, Sh.Name, "Check") Then

-            Sh.Select

-            Selection.Value = xlOff

-        End If

-    Next Sh

-    Range("A7").Select

-    Worksheets("Data").Range("K2") = 1

-    Worksheets("Calc").Range("E58") = 1

-End Sub

-

-<<<<<<
-======================
-Data
->>>>>>
-Attribute VB_Name = "Data"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'Telfast_marketing'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    Set MyAppEvents.app = Application

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    If Application.Workbooks.Count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEL сейчас будут закрыты!", vbOKCancel, "$" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close Savechanges:=False

-            Exit Sub

-        End If

-    End If

-    cmSetStandaloneMode

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    Dim res

-    res = MsgBox( _

-        prompt:="Вы желаете завершить программу? Не правда ли?", _

-        Buttons:=vbQuestion + vbYesNo, _

-        Title:=PROGRAM_NAME _

-    )

-    If res <> vbYes Then

-        Cancel = True

-        Exit Sub

-    End If

-    

-    

-    Dim NewFileName, DefFileName, WBPath As String

-    NewFileName = MakeNewFileName( _

-                        Worksheets("home").Range("USER_NAME_F"), _

-                        Worksheets("home").Range("USER_NAME_S"), _

-                        Worksheets("data").Range("CITY_TABLES") _

-                        .Offset( _

-                            Worksheets("data").Range("IDX_CITY"), _

-                            (Worksheets("data").Range("IDX_REGION") - 1) * 2 _

-                        ) _

-                    )

-    DefFileName = MakeNewFileName( _

-                        DEF_USER_NAME_F, _

-                        DEF_USER_NAME_S, _

-                        Worksheets("data").Range("CITY_TABLES") _

-                        .Offset(DEF_IDX_CITY, (DEF_IDX_REGION - 1) * 2) _

-                    )

-    WBPath = GetWBPath(ThisWorkbook.FullName)

-    

-    If ThisWorkbook.Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-        If ThisWorkbook.Saved = False Then

-            If NewFileName <> DefFileName Then

-                dlgFname.Caption = PROGRAM_NAME

-                dlgFname.lbFName = NewFileName

-                dlgFname.lbFPath = WBPath

-                dlgFname.Show

-                NewFileName = WBPath & NewFileName

-                ThisWorkbook.SaveAs FileName:=NewFileName

-            Else

-                ThisWorkbook.Save

-            End If

-        End If

-    End If

-    Application.Caption = Empty

-    Application.CommandBars("Worksheet Menu Bar").Reset

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-        Dim MaxX, MaxY As Integer

-        With ThisWorkbook.Worksheets(HOME_SHEET)

-            MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-            MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-        End With

-

-        With ThisWorkbook.Application

-            .ScreenUpdating = False

-            .WindowState = xlNormal

-            .Height = MaxY

-            .Width = MaxX

-        End With

-End Sub

-

-

-

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INP_NO As Integer = 0

-Const INP_DAT As Integer = 1

-Const INP_TXT As Integer = 2

-Const INP_NUM As Integer = 3

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Select Case is_InputRange(Target)

-    Case INP_NUM

-        Check_Number Target, 1

-    Case INP_TXT

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE")

-

-    If is_InputRange(Target) <> INP_NO Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-Function is_InputRange(r As Range) As Integer

-    Dim test As Boolean

-    

-    is_InputRange = INP_NO

-    

-    If r.Column = Range("USER_NAME_F").Column Then

-        test = r.Row = Range("USER_NAME_S").Row _

-                        Or r.Row = Range("USER_NAME_F").Row

-        If test Then

-            is_InputRange = INP_TXT

-        End If

-    Else

-        If r.Column = Range("USER_PLAN").Column Then

-            test = r.Row = Range("USER_PLAN").Row _

-                            Or r.Row = Range("USER_FACT").Row _

-                            Or r.Row = Range("USER_BUDGET").Row _

-                            Or r.Row = Range("USER_SVNORM").Row

-            

-            Dim idx As Integer

-            idx = Worksheets(DATA_SHEET).Range("IDX_PERSONE")

-            

-            If test Then

-                is_InputRange = INP_NUM

-            Else

-                If r.Row = Range("USER_STAF").Row Then

-                    If idx = 1 Then

-                        is_InputRange = INP_NUM

-                    End If

-                End If

-            End If

-        End If

-    End If

-End Function

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INP_DOC As String = "C9"

-Const INP_APT As String = "C11"

-Const INP_ADV As String = "C13"

-Const INP_ACT As String = "C15"

-Const INP_VIP As String = "C17"

-Const INP_SUM As String = "C19"

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("C9").Select

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    

-    If is_InputRange(Target) Then

-        GoalSeekNow Range(INP_SUM), Target

-    Else

-        If Target.Row = Range(INP_SUM).Row And Target.Column = Range(INP_SUM).Column Then

-            Dim Addr As String

-            

-            Addr = INP_DOC & "," & INP_APT & "," & INP_ADV & "," & INP_ACT & "," & INP_VIP

-            RangeNormalize Range(Addr), Target

-            

-        End If

-    End If

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If is_InputRange(Target) Then

-        Check_Percent Target, 0.2

-    End If

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE")

-    

-    If is_InputRange(Target) Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-Function is_InputRange(r As Range) As Boolean

-    is_InputRange = r.Column = Range(INP_DOC).Column _

-                And ( _

-                    r.Row = Range(INP_DOC).Row _

-                    Or r.Row = Range(INP_APT).Row _

-                    Or r.Row = Range(INP_ADV).Row _

-                    Or r.Row = Range(INP_ACT).Row _

-                    Or r.Row = Range(INP_VIP).Row _

-                )

-End Function

-

-

-<<<<<<
-======================
-mHome
->>>>>>
-Attribute VB_Name = "mHome"

-Option Explicit

-

-Sub cboxPersone_Change()

-    With ThisWorkbook.Worksheets(HOME_SHEET)

-        Dim r As Range

-        Range("A1").Select

-        If .Shapes("cboxPersone").ControlFormat.ListIndex = 2 Then

-            .Unprotect

-            .Range("G15") = 1

-            If Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") Then

-                .Protect

-            End If

-        End If

-    End With

-End Sub

-

-Sub cboxArea_Change()

-    Dim GroupIdx, LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    With ThisWorkbook.Worksheets(DATA_SHEET)

-        GroupIdx = .Range("IDX_REGION")

-        .Range("IDX_CITY") = 1

-        NewRangeOffsetCol = (GroupIdx - 1) * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .Name & "!" & .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).Address

-        NewSumRange = .Name & "!" & .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).Address

-    End With

-    With ThisWorkbook.Worksheets(HOME_SHEET)

-        .Shapes("cboxCity").ControlFormat.ListFillRange = NewCbxRange

-        .Unprotect

-        .Range("G10").Formula = "=sum(" & NewSumRange & ")"

-        If Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") Then

-            .Protect

-        End If

-    End With

-End Sub

-

-Sub cboxCity_Change()

-    

-End Sub

-

-<<<<<<
-======================
-mCommands
->>>>>>
-Attribute VB_Name = "mCommands"

-Option Explicit

-

-Sub btHome_Click()

-    Worksheets(HOME_SHEET).Select

-    Worksheets(DATA_SHEET).Range("CUR_STATE") = 0

-End Sub

-

-Sub bt2Budget_Click()

-    Sheets("budget").Select

-End Sub

-

-

-Sub btBdgtPrev_Click()

-    btHome_Click

-End Sub

-

-Sub btBdgtNext_Click()

-    If check_budget(Range("BDGT_TOTAL")) Then

-        Sheets("Final").Select

-    End If

-End Sub

-

-Sub btDoc_Click()

-    If check_budget(Range("BDGT_TOTAL")) Then

-        Sheets("Doc").Select

-    End If

-End Sub

-

-Sub btDocVisit_Click()

-    Sheets("Doc.Visit").Select

-End Sub

-

-Sub btDocConf_Click()

-    Sheets("Doc.Conf").Select

-End Sub

-

-Sub btApt_Click()

-    If check_budget(Range("BDGT_TOTAL")) Then

-        Sheets("Apt").Select

-    End If

-End Sub

-

-Sub btAptVisit_Click()

-    Sheets("Apt.Visit").Select

-End Sub

-

-

-Sub btAptConf_Click()

-    Sheets("Apt.Conf").Select

-End Sub

-

-Sub btAdv_Click()

-    If check_budget(Range("BDGT_TOTAL")) Then

-        Sheets("Adv").Select

-    End If

-End Sub

-

-Sub btAdvPrev_Click()

-    If check_Adv Then

-        bt2Budget_Click

-    End If

-End Sub

-

-Sub btAct_Click()

-    If check_budget(Range("BDGT_TOTAL")) Then

-        Sheets("Act").Select

-    End If

-End Sub

-

-Sub btCost_Click()

-    If check_budget(Range("BDGT_TOTAL")) Then

-        Sheets("Cost").Select

-    End If

-End Sub

-

-Sub btCostPrev_Click()

-    If check_budget(Range("Cost!C17")) Then

-        Sheets("budget").Select

-    End If

-End Sub

-

-<<<<<<
-======================
-Sheet40
->>>>>>
-Attribute VB_Name = "Sheet40"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("C9").Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If is_InputRange(Target) Then

-        Check_Percent Target, 0.7

-    End If

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = True

-    If is_InputRange(Target) Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-

-Function is_InputRange(r As Range) As Boolean

-    is_InputRange = r.Column = Range("C9").Column _

-                    And r.Row = Range("C9").Row

-End Function

-

-

-<<<<<<
-======================
-Tools
->>>>>>
-Attribute VB_Name = "Tools"

-Option Explicit

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub test()

-    Dim str As String

-    str = GetWBPath(ThisWorkbook.FullName)

-End Sub

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-Attribute SetDesignFlagOn.VB_ProcData.VB_Invoke_Func = "E\n14"

-    Dim Sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each Sh In Worksheets

-        Sh.Unprotect

-        Sh.Visible = xlSheetVisible

-    Next Sh

-    Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-Attribute SetDesignFlagOff.VB_ProcData.VB_Invoke_Func = " \n14"

-    Application.ScreenUpdating = False

-    Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim Sh As Worksheet

-    For Each Sh In Worksheets

-        If Sh.Name <> "data" Then

-            Sh.Protect

-        Else

-            Sh.Visible = xlSheetVeryHidden

-        End If

-    Next Sh

-    Application.ScreenUpdating = True

-End Sub

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma training"

-Public Const PROGRAM_VERSION As String = "version 1.0"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-

-'Public Const ESTIMATION_DATE As Long = 20030329

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "N35"

-Public Const CITY_TABLES As String = "N30"

-

-

-Public Const DATA_SHEET As String = "data"

-

-' Костанты листа Home

-Public Const DEF_USER_NAME_F As String = "Иван"

-Public Const DEF_USER_NAME_S As String = "Тургенев"

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-Public Const HOME_SHEET As String = "Home"

-Public Const USER_NAME_F As String = "USER_NAME_F"

-Public Const USER_NAME_S As String = "USER_NAME_S"

-Public Const USER_PLAN As String = "USER_PLAN"

-Public Const USER_BUDGET As String = "USER_BUDGET"

-Public Const USER_FACT As String = "USER_FACT"

-

-' Костанты листа Adv

-Public Const ADV_SHEET As String = "Adv"

-Public Const ADV_SUM_CAP As String = "K9"

-Public Const ADV_SUM_DOC As String = "C17"

-Public Const ADV_SUM_APT As String = "E17"

-Public Const ADV_SUM_CAST As String = "G17"

-Public Const ADV_SUM_DIST As String = "I17"

-

-

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{86C0099E-D971-435A-9BDD-7CCC071221F4}{B8D80B60-74EE-4C27-8096-D633BF258DBA}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{F27A11EC-D74B-47FE-AFE4-0699ED6724FD}{C40F68B8-2231-4C63-A120-5ADA5A70DE13}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-Sheet52
->>>>>>
-Attribute VB_Name = "Sheet52"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INPUTDATE_LT As String = "B11"

-Const INPUTDATE_RB As String = "B25"

-Const INPUTTEXT_LT As String = "C11"

-Const INPUTTEXT_RB As String = "C25"

-Const INPUTNUMB_LT As String = "F11"

-Const INPUTNUMB_RB As String = "I25"

-

-Const INP_NO As Integer = 0

-Const INP_DAT As Integer = 1

-Const INP_TXT As Integer = 2

-Const INP_NUM As Integer = 3

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("B11").Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Select Case is_InputRange(Target)

-    Case INP_NUM

-        Check_Number Target, 100

-    Case INP_TXT, INP_DAT

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = True

-    If is_InputRange(Target) <> 0 Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-Function is_InputRange(r As Range) As Integer

-    If is_InputArea(r, Range(INPUTDATE_LT), Range(INPUTDATE_RB)) Then

-        is_InputRange = INP_DAT

-    Else

-        If is_InputArea(r, Range(INPUTTEXT_LT), Range(INPUTTEXT_RB)) Then

-            is_InputRange = INP_TXT

-        Else

-            If is_InputArea(r, Range(INPUTNUMB_LT), Range(INPUTNUMB_RB)) Then

-                    is_InputRange = INP_NUM

-            Else

-                is_InputRange = INP_NO

-            End If

-        End If

-    End If

-End Function

-

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Function check_Adv() As Boolean

-    Dim b As Boolean

-    b = Abs(Range(ADV_SUM_CAP) - 1) < 0.0001 _

-        And Abs(Range(ADV_SUM_DOC) - 1) < 0.0001 _

-        And Abs(Range(ADV_SUM_APT) - 1) < 0.0001 _

-        And Abs(Range(ADV_SUM_CAST) - 1) < 0.0001 _

-        And Abs(Range(ADV_SUM_DIST) - 1) < 0.0001 _

-        Or Range("D13") = 0

-    If Not b Then

-        MsgBox "Не правильно составлен бюджет. Итоговые суммы должны быть = 100%"

-    End If

-    check_Adv = b

-End Function

-

-Function check_budget(r As Range) As Boolean

-    Dim f As Double

-    Dim b As Boolean

-    f = r

-    b = Abs(f - 1#) < 0.0001

-    If Not b Then

-        MsgBox "Не правильно составлен бюджет. Итоговые суммы должны быть = 100%"

-    End If

-    check_budget = b

-End Function

-

-Sub RangeNormalize(Src As Range, Dst As Range)

-    Dim f As Double

-    Dim c As Range

-    f = Dst

-    If f <> 0 Then

-        Src.Worksheet.Unprotect

-        For Each c In Src

-            c = c / f

-        Next c

-        If Not Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") Then

-            Src.Worksheet.Protect

-        End If

-    Else

-        MsgBox "Введите хотя бы одно число!"

-    End If

-End Sub

-

-Sub GoalSeekNow(Goal As Range, Target As Range)

-    Dim diff As Double

-    

-    diff = Goal - 1

-    If Abs(diff) > 0.0001 Then

-        If (diff > 0 And diff < Target) Or (diff < 0 And 1 - Target > Abs(diff)) Then

-            Goal.GoalSeek Goal:=1, ChangingCell:=Range(Target.Address)

-        Else

-            MsgBox "Автоподбор значения не возможен. Выберите другой параметр!"

-        End If

-    End If

-

-End Sub

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100."

-    End If

-End Sub

-

-Sub Check_Number(Target As Range, Def_Val As Double)

-    Dim test As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                test = True

-            End If

-        End If

-    Next r

-    

-    If test Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!"

-    End If

-    

-End Sub

-

-Function is_InputArea(r As Range, LT As Range, RB As Range) As Boolean

-    is_InputArea = r.Column >= LT.Column _

-                And r.Row >= LT.Row _

-                And r.Column <= RB.Column _

-                And r.Row <= RB.Row

-End Function

-

-<<<<<<
-======================
-Sheet70
->>>>>>
-Attribute VB_Name = "Sheet70"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INP_NUM_1_LT As String = "E14"

-Const INP_NUM_1_RB As String = "J14"

-Const INP_NUM_2_LT As String = "E16"

-Const INP_NUM_2_RB As String = "J16"

-Const INP_NUM_3_LT As String = "E18"

-Const INP_NUM_3_RB As String = "J18"

-Const INP_NUM_4_LT As String = "E20"

-Const INP_NUM_4_RB As String = "J20"

-Const INP_NUM_5_LT As String = "E22"

-Const INP_NUM_5_RB As String = "J22"

-

-Const INP_DAT_1_LT As String = "B14"

-Const INP_DAT_1_RB As String = "C14"

-Const INP_DAT_2_LT As String = "B16"

-Const INP_DAT_2_RB As String = "C16"

-Const INP_DAT_3_LT As String = "B18"

-Const INP_DAT_3_RB As String = "C18"

-Const INP_DAT_4_LT As String = "B20"

-Const INP_DAT_4_RB As String = "C20"

-Const INP_DAT_5_LT As String = "B22"

-Const INP_DAT_5_RB As String = "C22"

-

-Const INP_NO As Integer = 0

-Const INP_DAT As Integer = 1

-Const INP_TXT As Integer = 2

-Const INP_NUM As Integer = 3

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("B14").Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Select Case is_InputRange(Target)

-    Case INP_NUM

-        Check_Number Target, 100

-    Case INP_TXT, INP_DAT

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE")

-    

-    If is_InputRange(Target) <> INP_NO Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-

-Function is_InputRange(r As Range) As Integer

-    Dim test As Boolean

-    

-    test = is_InputArea(r, Range(INP_NUM_1_LT), Range(INP_NUM_1_RB)) _

-        Or is_InputArea(r, Range(INP_NUM_2_LT), Range(INP_NUM_2_RB)) _

-        Or is_InputArea(r, Range(INP_NUM_3_LT), Range(INP_NUM_3_RB)) _

-        Or is_InputArea(r, Range(INP_NUM_4_LT), Range(INP_NUM_4_RB)) _

-        Or is_InputArea(r, Range(INP_NUM_5_LT), Range(INP_NUM_5_RB))

-    If test Then

-       is_InputRange = INP_NUM

-    Else

-        test = is_InputArea(r, Range(INP_DAT_1_LT), Range(INP_DAT_1_RB)) _

-            Or is_InputArea(r, Range(INP_DAT_2_LT), Range(INP_DAT_2_RB)) _

-            Or is_InputArea(r, Range(INP_DAT_3_LT), Range(INP_DAT_3_RB)) _

-            Or is_InputArea(r, Range(INP_DAT_4_LT), Range(INP_DAT_4_RB)) _

-            Or is_InputArea(r, Range(INP_DAT_5_LT), Range(INP_DAT_5_RB))

-        If test Then

-            is_InputRange = INP_DAT

-        Else

-            is_InputRange = INP_NO

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-Sheet30
->>>>>>
-Attribute VB_Name = "Sheet30"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet41
->>>>>>
-Attribute VB_Name = "Sheet41"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const MEMBERSHIP As String = "D7"

-Const MILEAGE As String = "D9"

-Const INPUTAREA_LT As String = "C17"

-Const INPUTAREA_RB As String = "E24"

-

-Const ChangeCheckFlag As Boolean = False

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("C17").Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Select Case is_InputRange(Target)

-        Case 1

-            Check_Number Target, 1

-        Case 2

-            Check_Number Target, 15

-        Case 3

-            Check_Number Target, 50

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = True

-    If is_InputRange(Target) <> 0 Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-Function is_InputRange(r As Range) As Integer

-    If r.Column = Range(MEMBERSHIP).Column And r.Row = Range(MEMBERSHIP).Row Then

-        is_InputRange = 1

-    Else

-        If r.Column = Range(MILEAGE).Column And r.Row = Range(MILEAGE).Row Then

-            is_InputRange = 2

-        Else

-            If r.Column >= Range(INPUTAREA_LT).Column _

-                And r.Row >= Range(INPUTAREA_LT).Row _

-                And r.Column <= Range(INPUTAREA_RB).Column _

-                And r.Row <= Range(INPUTAREA_RB).Row Then

-                    is_InputRange = 3

-            Else

-                is_InputRange = 0

-            End If

-        End If

-    End If

-End Function

-

-

-<<<<<<
-======================
-Sheet42
->>>>>>
-Attribute VB_Name = "Sheet42"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INPUTDATE_LT As String = "B11"

-Const INPUTDATE_RB As String = "B25"

-Const INPUTTEXT_LT As String = "C11"

-Const INPUTTEXT_RB As String = "C25"

-Const INPUTNUMB_LT As String = "F11"

-Const INPUTNUMB_RB As String = "I25"

-

-Const INP_NO As Integer = 0

-Const INP_DAT As Integer = 1

-Const INP_TXT As Integer = 2

-Const INP_NUM As Integer = 3

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range(INPUTDATE_LT).Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Select Case is_InputRange(Target)

-    Case INP_NUM

-        Check_Number Target, 100

-    Case INP_TXT, INP_DAT

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = True

-    If is_InputRange(Target) <> 0 Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-Function is_InputRange(r As Range) As Integer

-    If is_InputArea(r, Range(INPUTDATE_LT), Range(INPUTDATE_RB)) Then

-        is_InputRange = INP_DAT

-    Else

-        If is_InputArea(r, Range(INPUTTEXT_LT), Range(INPUTTEXT_RB)) Then

-            is_InputRange = INP_TXT

-        Else

-            If is_InputArea(r, Range(INPUTNUMB_LT), Range(INPUTNUMB_RB)) Then

-                    is_InputRange = INP_NUM

-            Else

-                is_InputRange = INP_NO

-            End If

-        End If

-    End If

-End Function

-

-

-<<<<<<
-======================
-Sheet60
->>>>>>
-Attribute VB_Name = "Sheet60"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INP_DOC_LT As String = "C10"

-Const INP_DOC_RB As String = "C16"

-Const INP_APT_LT As String = "E10"

-Const INP_APT_RB As String = "E16"

-Const INP_CAST_LT As String = "G10"

-Const INP_CAST_RB As String = "G16"

-Const INP_DIST_LT As String = "I10"

-Const INP_DIST_RB As String = "I16"

-Const CAP_DOC As String = "C9"

-Const CAP_APT As String = "E9"

-Const CAP_CAST As String = "G9"

-Const CAP_DIST As String = "I9"

-

-

-Const INP_NO As Integer = 0

-Const INP_CAP As Integer = 1

-Const INP_DOC As Integer = 2

-Const INP_APT As Integer = 3

-Const INP_CAST As Integer = 4

-Const INP_DIST As Integer = 5

-

-Const INP_SUM_CAP As Integer = 11

-Const INP_SUM_DOC As Integer = 12

-Const INP_SUM_APT As Integer = 13

-Const INP_SUM_CAST As Integer = 14

-Const INP_SUM_DIST As Integer = 15

-

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("C9").Select

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim Inp As Integer

-    Dim Addr As String

-    Inp = is_InputRange(Target)

-    Select Case is_InputRange(Target)

-        Case INP_NO

-            Cancel = False

-        

-        Case INP_CAP

-            GoalSeekNow Range(ADV_SUM_CAP), Target

-        

-        Case INP_DOC

-            GoalSeekNow Range(ADV_SUM_DOC), Target

-        

-        Case INP_APT

-            GoalSeekNow Range(ADV_SUM_APT), Target

-        

-        Case INP_CAST

-            GoalSeekNow Range(ADV_SUM_CAST), Target

-        

-        Case INP_DIST

-            GoalSeekNow Range(ADV_SUM_DIST), Target

-        

-        Case INP_SUM_CAP

-            Addr = CAP_DOC & "," & CAP_APT & "," & CAP_CAST & "," & CAP_DIST

-            RangeNormalize Range(Addr), Target

-        

-        Case INP_SUM_DOC

-            Addr = INP_DOC_LT & ":" & INP_DOC_RB

-            RangeNormalize Range(Addr), Target

-        

-        Case INP_SUM_APT

-            Addr = INP_APT_LT & ":" & INP_APT_RB

-            RangeNormalize Range(Addr), Target

-        

-        Case INP_SUM_CAST

-            Addr = INP_CAST_LT & ":" & INP_CAST_RB

-            RangeNormalize Range(Addr), Target

-        

-        Case INP_SUM_DIST

-            Addr = INP_DIST_LT & ":" & INP_DIST_RB

-            RangeNormalize Range(Addr), Target

-    End Select

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Select Case is_InputRange(Target)

-    Case INP_CAP

-        Check_Percent Target, 0.25

-    Case INP_DOC, INP_APT, INP_CAST, INP_DIST

-        Check_Percent Target, 0.15

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE")

-    

-    If is_InputRange(Target) > 0 Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-

-Function is_InputRange(r As Range) As Integer

-    is_InputRange = INP_NO

-    If r.Row = Range(CAP_DOC).Row Then

-        If r.Column = Range(CAP_DOC).Column _

-                Or r.Column = Range(CAP_APT).Column _

-                Or r.Column = Range(CAP_CAST).Column _

-                Or r.Column = Range(CAP_DIST).Column Then

-            is_InputRange = INP_CAP

-        End If

-        If r.Column = Range(ADV_SUM_CAP).Column Then

-            is_InputRange = INP_SUM_CAP

-        End If

-    Else

-        If is_InputArea(r, Range(INP_DOC_LT), Range(INP_DOC_RB)) Then

-            is_InputRange = INP_DOC

-        Else

-            If is_InputArea(r, Range(INP_APT_LT), Range(INP_APT_RB)) Then

-                is_InputRange = INP_APT

-            Else

-                If is_InputArea(r, Range(INP_CAST_LT), Range(INP_CAST_RB)) Then

-                    is_InputRange = INP_CAST

-                Else

-                    If is_InputArea(r, Range(INP_DIST_LT), Range(INP_DIST_RB)) Then

-                        is_InputRange = INP_DIST

-                    Else

-                        If r.Row = Range(ADV_SUM_DOC).Row Then

-                            If r.Column = Range(ADV_SUM_DOC).Column Then

-                                is_InputRange = INP_SUM_DOC

-                            End If

-                            If r.Column = Range(ADV_SUM_APT).Column Then

-                                is_InputRange = INP_SUM_APT

-                            End If

-                            If r.Column = Range(ADV_SUM_APT).Column Then

-                                is_InputRange = INP_SUM_APT

-                            End If

-                            If r.Column = Range(ADV_SUM_CAST).Column Then

-                                is_InputRange = INP_SUM_CAST

-                            End If

-                            If r.Column = Range(ADV_SUM_DIST).Column Then

-                                is_InputRange = INP_SUM_DIST

-                            End If

-                        End If

-                    End If

-                End If

-            End If

-        End If

-    End If

-End Function

-

-

-<<<<<<
-======================
-Sheet50
->>>>>>
-Attribute VB_Name = "Sheet50"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("C9").Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If is_InputRange(Target) Then

-        Check_Percent Target, 0.7

-    End If

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = True

-    If is_InputRange(Target) Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-

-Function is_InputRange(r As Range) As Boolean

-    is_InputRange = r.Column = Range("C9").Column _

-                    And r.Row = Range("C9").Row

-End Function

-

-

-<<<<<<
-======================
-Sheet51
->>>>>>
-Attribute VB_Name = "Sheet51"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INPUTAREA_LT As String = "C17"

-Const INPUTAREA_RB As String = "E20"

-

-Const ChangeCheckFlag As Boolean = False

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("C17").Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If is_InputRange(Target) <> 0 Then

-        Check_Number Target, 50

-    End If

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = True

-    If is_InputRange(Target) <> 0 Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-Function is_InputRange(r As Range) As Integer

-    If is_InputArea(r, Range(INPUTAREA_LT), Range(INPUTAREA_RB)) Then

-        is_InputRange = 3

-    Else

-        is_InputRange = 0

-    End If

-End Function

-

-

-<<<<<<
-======================
-Sheet80
->>>>>>
-Attribute VB_Name = "Sheet80"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INP_DOC As String = "C9"

-Const INP_APT As String = "C11"

-Const INP_CUST As String = "C13"

-Const INP_DIST As String = "C15"

-Const INP_SUM As String = "C17"

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("C9").Select

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    

-    If is_InputRange(Target) Then

-        GoalSeekNow Range(INP_SUM), Target

-    Else

-        If Target.Row = Range(INP_SUM).Row And Target.Column = Range(INP_SUM).Column Then

-            Dim Addr As String

-            

-            Addr = INP_DOC & "," & INP_APT & "," & INP_CUST & "," & INP_DIST

-            RangeNormalize Range(Addr), Target

-            

-        End If

-    End If

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If is_InputRange(Target) Then

-        Check_Percent Target, 0.25

-    End If

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE")

-    

-    If is_InputRange(Target) Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-Function is_InputRange(r As Range) As Boolean

-    is_InputRange = r.Column = Range(INP_DOC).Column _

-                And ( _

-                    r.Row = Range(INP_DOC).Row _

-                    Or r.Row = Range(INP_APT).Row _

-                    Or r.Row = Range(INP_CUST).Row _

-                    Or r.Row = Range(INP_DIST).Row _

-                )

-End Function

-

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Print"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 4

-                        .OnAction = "cmPrint"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-'                With .Controls

-'                    With .Add(msoControlButton)

-'                        .Caption = "&Contents"

-'                        .Style = msoButtonIconAndCaption

-'                        .FaceId = 49

-'                        .OnAction = "cmHelpContents"

-'                    End With

-'                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(Flag As Boolean)

-    If Flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars("Worksheet Menu Bar")

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    dlgAbout.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlgAbout.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlgAbout.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlgAbout.Show

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-        helppath = "hh.exe " & .Path & "\Telfast.chm"

-        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub cmSetStandaloneMode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-    ThisWorkbook.Worksheets("home").Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    rp = common_pwd

-    dlgGetPwd.edPwd = ""

-    dlgGetPwd.Show

-    If dlgGetPwd.edPwd = rp Then

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-    Else

-        cmSetStandaloneMode

-    End If

-    ThisWorkbook.Worksheets("home").Select

-End Sub

-

-

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If Application.Workbooks.Count > 1 Then

-        wbname = Wb.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKCancel, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            Wb.Close Savechanges:=False

-        End If

-        Exit Sub

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub GetState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.Count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.Name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars("Worksheet Menu Bar").Visible = False

-End Sub

-

-

-Public Sub RestoreState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars("Worksheet Menu Bar").Visible = True

-End Sub

-

-

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        cmHelpContents

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Telfast bar"

-Public Const common_pwd As Long = 31415926

-

-

-Sub SetEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    With Application

-        .Caption = PROGRAM_NAME

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .GetState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(HOME_SHEET).Select

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                     cWindow.DisplayHeadings = True

-                Next

-            End If

-        Next

-        .Worksheets(HOME_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu (True)

-        End If

-        With mobjAppState

-            .RestoreState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{C49C37AF-FB78-4D39-BE95-F98ECF8A9575}{0C81C15B-882C-4E57-B743-863D7DCE2CE5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    

-    dlgPrint.cbMainReport = True

-    dlgPrint.cbMainBudget = False

-    dlgPrint.cbSrcData = False

-    dlgPrint.cbAllSheets = False

-    

-    dlgPrint.Show

-    

-    If dlgPrint.Tag = vbCancel Then

-        Exit Sub

-    End If

-    

-    Dim PrnIdx As Integer

-    

-    With dlgPrint

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("home", "budget", "Final")

-    Case 1111

-        plist = Array("home", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("home")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-dlgFname
->>>>>>
-Attribute VB_Name = "dlgFname"

-Attribute VB_Base = "0{05AF5AE8-7423-4FD0-B32C-74A4E8EE39E2}{DDEF6ED6-73A3-4D13-AD90-B90001E9E37F}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btOK_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Sub Macro1()

-Attribute Macro1.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute Macro1.VB_ProcData.VB_Invoke_Func = " \n14"

-'

-' Macro1 Macro

-' Macro recorded 25.09.2003 by nick

-'

-

-'

-    Charts.Add

-    ActiveChart.ChartType = xlBubble

-    ActiveChart.SetSourceData Source:=Sheets("file1").Range("H2:J11"), PlotBy:= _

-        xlColumns

-    ActiveChart.Location Where:=xlLocationAsObject, Name:="file1"

-    With ActiveChart

-        .HasTitle = True

-        .ChartTitle.Characters.Text = "Матрица"

-        .Axes(xlCategory, xlPrimary).HasTitle = True

-        .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Доля клексана"

-        .Axes(xlValue, xlPrimary).HasTitle = True

-        .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Количество больных"

-    End With

-    With ActiveChart.Axes(xlCategory)

-        .HasMajorGridlines = True

-        .HasMinorGridlines = False

-    End With

-    With ActiveChart.Axes(xlValue)

-        .HasMajorGridlines = True

-        .HasMinorGridlines = False

-    End With

-    ActiveChart.HasLegend = False

-    ActiveChart.ApplyDataLabels Type:=xlDataLabelsShowValue, LegendKey:=False

-    ActiveChart.SeriesCollection(1).Select

-    ActiveChart.SeriesCollection(1).DataLabels.Select

-    ActiveChart.SeriesCollection(1).Select

-    ActiveChart.SeriesCollection(1).DataLabels.Select

-    ActiveChart.SeriesCollection(1).Points(9).DataLabel.Select

-    Selection.Characters.Text = "8379 №1"

-    Selection.AutoScaleFont = False

-    With Selection.Characters(Start:=1, Length:=7).Font

-        .Name = "Arial"

-        .FontStyle = "Обычный"

-        .Size = 10

-        .Strikethrough = False

-        .Superscript = False

-        .Subscript = False

-        .OutlineFont = False

-        .Shadow = False

-        .Underline = xlUnderlineStyleNone

-        .ColorIndex = xlAutomatic

-    End With

-    ActiveChart.Axes(xlValue).MajorGridlines.Select

-End Sub

-Sub Macro2()

-Attribute Macro2.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute Macro2.VB_ProcData.VB_Invoke_Func = " \n14"

-'

-' Macro2 Macro

-' Macro recorded 25.09.2003 by nick

-'

-

-'

-    Application.CutCopyMode = False

-    With ActiveChart.ChartGroups(1)

-        .VaryByCategories = True

-        .ShowNegativeBubbles = False

-        .SizeRepresents = xlSizeIsArea

-        .BubbleScale = 100

-    End With

-End Sub

-Sub Macro3()

-Attribute Macro3.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute Macro3.VB_ProcData.VB_Invoke_Func = " \n14"

-'

-' Macro3 Macro

-' Macro recorded 25.09.2003 by nick

-'

-

-'

-    ActiveChart.SeriesCollection(1).DataLabels.Select

-    ActiveChart.SeriesCollection(1).Points(6).DataLabel.Select

-    ActiveChart.Axes(xlValue).MajorGridlines.Select

-    ActiveChart.SeriesCollection(1).DataLabels.Select

-    ActiveChart.SeriesCollection(1).Points(6).DataLabel.Select

-    Selection.Characters.Text = "9847 №2"

-    Selection.AutoScaleFont = False

-    With Selection.Characters(Start:=1, Length:=7).Font

-        .Name = "Arial"

-        .FontStyle = "Обычный"

-        .Size = 12

-        .Strikethrough = False

-        .Superscript = False

-        .Subscript = False

-        .OutlineFont = False

-        .Shadow = False

-        .Underline = xlUnderlineStyleNone

-        .ColorIndex = xlAutomatic

-    End With

-    ActiveChart.PlotArea.Select

-End Sub

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'ClexaneRM'
-Quirk - duff tag length======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    ThisWorkbook.Worksheets(RM_QTR_SHEET).ClearRMName

-    

-    Application.EnableEvents = True

-    Set MyAppEvents.app = Application

-    

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    

-    MyAppEvents.CheckWorkBooksArround ThisWorkbook

-    

-    cmSetStandaloneMode

-    

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-    

-    Application.ScreenUpdating = True

-    

-    If CheckUser Then

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).update_history

-        Application.Calculate

-    End If

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    

-    Dim RestMode As Boolean

-    RestMode = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE")

-    

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-'        If RestMode Then

-            ThisWorkbook.Saved = True

-'        Else

-'            ThisWorkbook.Save

-'        End If

-    End If

-    Application.Caption = Empty

-    Application.CommandBars(STDBAR_NAME).Reset

-    If RestMode Then

-        xlRestoreView

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    End If

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-    Dim MaxX, MaxY As Integer

-    With ThisWorkbook.Worksheets(TITLE_SHEET)

-        MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-        MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-    End With

-

-    With ThisWorkbook.Application

-        .ScreenUpdating = False

-        .WindowState = xlNormal

-        .Height = MaxY

-        .Width = MaxX

-    End With

-End Sub

-

-

-

-

-

-<<<<<<
-======================
-REP_QTR
->>>>>>
-Attribute VB_Name = "REP_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CQTR_QT As Integer = 0

-Const CQTR_ID As Integer = 1

-Const CQTR_PLN As Integer = 2

-Const CQTR_FCT As Integer = 3

-Const CQTR_BDG As Integer = 4

-Const CQTR_CNT As Integer = 5

-Const CQTR_BEDS As Integer = 6

-Const CQTR_HIR As Integer = 7

-Const CQTR_TER As Integer = 8

-Const CQTR_CRD As Integer = 9

-Const CQTR_CLXN_BDG As Integer = 10

-Const CQTR_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub update_history()

-    Dim objQTR() As tQTR

-    Dim i As Long

-    Dim r As Range

-    Dim cRep As tREPID

-

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    Range("D4") = cRep.LastName

-    Range("D5") = cRep.FirstName

-

-    Range("H4") = GetRegionName(cRep.Region)

-    Range("H5") = GetCityName(cRep.Region, cRep.City)

-

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetAll_QTR_Records_by_REP(objQTR, "%", cRep.rep_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CQTR_QT) = objQTR(i).entry_date

-        Next i

-    End If

-    Dim qcd() As tQTR_COMMON

-    i = Get_QTR_CommonList_by_REP(qcd, "%", cRep.rep_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(qcd)

-            r.Offset(i - 1, CQTR_QT) = qcd(i).qtr.entry_date

-            r.Offset(i - 1, CQTR_ID) = qcd(i).qtr.id

-            r.Offset(i - 1, CQTR_PLN) = qcd(i).qtr.sale_PLAN

-            r.Offset(i - 1, CQTR_FCT) = qcd(i).c_sale_ALL

-            r.Offset(i - 1, CQTR_BDG) = qcd(i).c_bdgt_LPU

-            r.Offset(i - 1, CQTR_CNT) = qcd(i).i_lcd

-            r.Offset(i - 1, CQTR_BEDS) = qcd(i).c_beds

-            r.Offset(i - 1, CQTR_HIR) = qcd(i).c_pat_HIR

-            r.Offset(i - 1, CQTR_TER) = qcd(i).c_pat_TER

-            r.Offset(i - 1, CQTR_CRD) = qcd(i).c_pat_CRD

-            If qcd(i).c_bdgt_LPU <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_BDG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_LPU

-            End If

-            If qcd(i).c_bdgt_NMG <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_NMG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CQTR_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRepQtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect UserInterfaceOnly:=True

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CQTR_ID + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    i = currRange.Column - Range(CINP_AREA).Column

-

-    QTR_ID = r

-

-    If QTR_ID = 0 Then

-        Worksheets(VAR_SHEET).Range("USER_ACTION") = 1

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        If i > CQTR_FCT Then

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-            Range("LAST_FOCUS") = currRange.address

-        Else

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 3

-            Range("LAST_FOCUS") = currRange.address

-        End If

-    End If

-    Cancel = True

-    btHomeDo_IT

-End Sub

-

-<<<<<<
-======================
-mRep_QTR
->>>>>>
-Attribute VB_Name = "mRep_QTR"

-Option Explicit

-

-Sub NoFunc()

-    MsgBox "Функция не доступна", vbOKOnly, PROGRAM_NAME

-End Sub

-

-Sub DO_Price_qtr(ent_date As String)

-    Dim qtr As tQTR

-    Dim res As Integer

-    Dim cRep As tREPID

-

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    qtr = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-

-    If qtr.id = 0 Then

-        qtr.entry_date = ent_date

-

-        With Worksheets(VAR_SHEET)

-            qtr.ClxnH20mg = .Range("ClxnH20mg")

-            qtr.ClxnH40mg = .Range("ClxnH40mg")

-            qtr.ClxnT40mg = .Range("ClxnT40mg")

-            qtr.ClxnC_ACS = .Range("ClxnC_ACS")

-            qtr.ClxnC_IM = .Range("ClxnC_IM")

-        End With

-    End If

-

-    Dim dlg_nq As dlg_nextQTR

-    Set dlg_nq = New dlg_nextQTR

-

-    With dlg_nq

-        .tb_qtr_name = qtr.entry_date

-        .tb_bdgt_avts = qtr.sale_PLAN

-        .tb_qtr_name = qtr.entry_date

-        .tb_ClxnH20mg = qtr.ClxnH20mg

-        .tb_ClxnH40mg = qtr.ClxnH40mg

-        .tb_ClxnT40mg = qtr.ClxnT40mg

-        .tb_ClxnC_ACS = qtr.ClxnC_ACS

-        .tb_ClxnC_IM = qtr.ClxnC_IM

-    End With

-

-    dlg_nq.Show

-End Sub

-

-Sub DO_Edit_qtr(ent_date As String)

-    If ent_date = "" Then

-        NoFunc

-    Else

-        Dim rep_id As Long

-        rep_id = Worksheets(REP_QTR_SHEET).Range("REP_ID")

-        With ThisWorkbook.Worksheets("LPU_LIST")

-            .Range("VIEW_ONLY") = True

-            .Range("ent_date") = ent_date

-            .Range("REP_ID") = rep_id

-            .Select

-        End With

-    End If

-End Sub

-

-Sub DO_Delete_qtr(ent_date As String)

-    If ent_date <> "" Then

-        MsgBox "Удалить данные за период [" & ent_date & "] нельзя ", vbOKOnly, PROGRAM_NAME

-    End If

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-

-Sub btHomeDo_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    idx = Worksheets(VAR_SHEET).Range("USER_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            NoFunc

-            ' Обновляем экран

-        Case 2

-            DO_Edit_qtr ent_date

-        Case 3

-            DO_Price_qtr ent_date

-        Case 4

-            NoFunc

-    End Select

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-Sub Delete_qtr()

-'    Dim ent_date As String

-'    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-'    DO_Delete_qtr ent_date

-End Sub

-

-Sub btREP_QTR_RET_IT()

-    Dim s As String

-    With Worksheets("REP_QTR")

-        .Range("LAST_FOCUS") = ""

-        s = .Range("ret_addr")

-        .Range("ret_addr") = ""

-    End With

-    If s <> "" Then

-        ThisWorkbook.Worksheets(s).Select

-    Else

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane[RM]"

-Public Const PROGRAM_VERSION As String = "version 1.3"

-Public Const PROGRAM_FILENAME As String = "clexane-rm"

-Public Const PROGRAM_BACKUPNAME As String = "rm-backup-"

-Public Const PROGRAM_EXPORTNAME As String = "rm-ex-"

-Public Const PROGRAM_IMPORTNAME As String = "mr-ex-*"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20030329

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "O40"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-Public Const RM_QTR_SHEET As String = "RM_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-

-End Sub

-

-Function Double2Str(ByVal d As Double, ByVal precision As Integer, Optional Delim As String = ".") As String

-    Dim s As String

-    If Not precision > 0 Then

-        s = Round(d)

-    Else

-        Dim i As Integer

-        i = Fix(d)

-        s = i & Delim

-        d = Abs(d - i)

-        Do

-            precision = precision - 1

-            d = d * 10

-            If precision > 0 Then

-                i = Fix(d)

-            Else

-                i = Round(d)

-            End If

-            If i < 1 Then

-                s = s & "0"

-            Else

-                s = s & i

-                d = d - i

-            End If

-        Loop While precision > 0

-    End If

-    Double2Str = s

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetWBName(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBName = Right(FullName, s_len - pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.name = VAR_SHEET Or sh.name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-<<<<<<
-======================
-Var
->>>>>>
-Attribute VB_Name = "Var"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-title
->>>>>>
-Attribute VB_Name = "title"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LPU_LIST
->>>>>>
-Attribute VB_Name = "LPU_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentLPU_ID() As Long

-    Dim r As Range

-

-    With Worksheets("LPU_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CLPU_ID)

-    End With

-

-    getCurrentLPU_ID = r

-End Function

-

-Public Sub LPU_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectLPU_NAME(lpu_id As Long, ent_date As String)

-    If Range("VIEW_ONLY") = True Then

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    Dim cLPU As tLPU

-    If lpu_id = 0 Then

-        cLPU.id = 0

-        cLPU.rep_id = 0

-        cLPU.address = ""

-        cLPU.name = ""

-    Else

-        cLPU = Get_LPU_Record(lpu_id)

-    End If

-    EditLPU cLPU, getEnt_date

-    Worksheet_Activate

-End Sub

-

-Sub SelectLPU_BDGT(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    vo = Range("VIEW_ONLY")

-    If lpu_id = 0 Then

-        SelectLPU_NAME lpu_id, ent_date

-    Else

-        With ThisWorkbook.Worksheets("LPU_BDGT")

-            .Range("VIEW_ONLY") = vo

-            .Range("ret_addr") = "LPU_LIST"

-            .Range("REP_ID") = r_id

-            .Range("ent_date") = ent_date

-            .Range("lpu_id") = lpu_id

-        End With

-    End If

-End Sub

-

-Sub SelectLPU_HIR(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_HIR")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Sub SelectLPU_TER(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_TER")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Sub SelectLPU_C_ACS(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_C_ACS")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect UserInterfaceOnly:=True

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateLPUList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim lpu_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CINP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CINP_AREA).row, CLPU_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    lpu_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CINP_AREA).Column

-

-    If lpu_id = 0 Then

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    End If

-

-    If lpu_id = 0 Then

-        i = CLPU_NAME

-        Range("JUMP") = ""

-    End If

-    Select Case i

-        Case CLPU_NAME, CLPU_NAME1, CLPU_NAME2, CLPU_BEDS

-            SelectLPU_NAME lpu_id, ent_date

-            Range("JUMP") = ""

-

-        Case CLPU_NMG, CLPU_NFG, CLPU_PLAN, CLPU_FACT

-            SelectLPU_BDGT lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-

-        Case CLPU_HIR

-            SelectLPU_HIR lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_HIR"

-

-        Case CLPU_TER

-            SelectLPU_TER lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_TER"

-

-        Case CLPU_CAR

-            SelectLPU_C_ACS lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        Case Else

-            Range("JUMP") = ""

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateLPUList()

-    Dim lcd() As tLPU_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-    Dim objQTR As tQTR

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    ent_date = getEnt_date

-

-'     ent_date = "%" ' % - all records

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-    i = Get_LPU_CommonQTR(lcd, objQTR)

-

-'     стираем ФИО

-    Range("C3:C4").ClearContents

-

-    Range("C3") = cRep.LastName

-    Range("C4") = cRep.FirstName

-    Range("G3") = GetRegionName(cRep.Region)

-    Range("G4") = GetCityName(cRep.Region, cRep.City)

-    Range("G5") = objQTR.sale_PLAN

-

-

-

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(lcd)

-            r.Offset(i - 1, CLPU_NAME) = lcd(i).lpu.name

-            r.Offset(i - 1, CLPU_ID) = lcd(i).lpu.id

-            r.Offset(i - 1, CLPU_BEDS) = lcd(i).lpu.beds

-

-

-            r.Offset(i - 1, CLPU_NFG) = lcd(i).bdgt.bdgt_NFG

-            r.Offset(i - 1, CLPU_NMG) = lcd(i).bdgt.bdgt_NMG

-            r.Offset(i - 1, CLPU_PLAN) = lcd(i).bdgt.sale_PLAN

-

-            r.Offset(i - 1, CLPU_HIR) = lcd(i).pat_HIR

-            r.Offset(i - 1, CLPU_TER) = lcd(i).pat_TER

-            r.Offset(i - 1, CLPU_CAR) = lcd(i).pat_CRD

-            r.Offset(i - 1, CLPU_FACT) = lcd(i).sale_ALL

-            r.Offset(i - 1, CLPU_PAT_LPU) = lcd(i).pat_LPU

-            r.Offset(i - 1, CLPU_BDGT) = lcd(i).bdgt_LPU

-            If lcd(i).bdgt_LPU > 0 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = lcd(i).sale_ALL / lcd(i).bdgt_LPU

-            End If

-            If r.Offset(i - 1, CLPU_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{F2A5159C-AEB6-4066-B85F-339184DAFECD}{712D78F6-CCB6-499E-9674-B992A7482317}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-dbACS
->>>>>>
-Attribute VB_Name = "dbACS"

-Option Explicit

-

-Public Type tACS

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    patients_with_geparins As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objACS.ID <> 0 then updatre else insert

-Sub Insert_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objACS.id <> 0 Then

-        dbUpdate_ACS_Record dbConnection, objACS

-    Else

-        dbInsert_ACS_Record dbConnection, objACS

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_ACS_RecordsByLPU_ID(ByRef all_ACS_() As tACS, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_ACS_RecordsByLPU_ID = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, all_ACS_, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_ACS_Record dbConnection, objACS

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub dbInsert_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_acs", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objACS

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("patients_with_geparins") = .patients_with_geparins

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objACS.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim Update_SQL As String

-    

-    With objACS

-        Update_SQL = "UPDATE lpu_acs SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "patients_with_geparins=" & .patients_with_geparins & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_ACS_RecordsbyLPU_ID(dbConnection As Object, all_ACS() As tACS, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_ACS_SQL As String

-    Dim getAll_ACS_SQL As String

-    Dim ACS_Count As Long

-    ACS_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_ACS_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        ACS_Count = dbRecordset("ACS_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_ACS_RecordsbyLPU_ID = ACS_Count

-    

-    If ACS_Count > 0 Then

-        'we have records

-        ReDim all_ACS(1 To ACS_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_ACS_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_ACS As tACS

-                 With tmp_ACS

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .patients_with_geparins = dbRecordset("patients_with_geparins")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 all_ACS(index) = tmp_ACS

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE ID=" & objACS.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_ACS_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_HIR
->>>>>>
-Attribute VB_Name = "LPU_CLSN_HIR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-

-        Dim objHir As tHIRURGIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objHir

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .operations_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L9")

-                .patients_ambulator_clexan_20mg = Range("L10")

-                .patients_ambulator_clexan_40mg = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L19")

-                .patients_stationar_clexan_20mg = Range("L20")

-                .patients_stationar_clexan_40mg = Range("L21")

-            End With

-            Insert_Hir_Record objHir

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objHir.id = Range("rec_id")

-                    If objHir.id <> 0 Then

-                        Delete_Hir_Record objHir

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objHir As tHIRURGIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    With objHir

-        Range("rec_id") = .id

-        Range("F6") = .operations_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L9") = .patients_ambulator_clexan

-        Range("L10") = .patients_ambulator_clexan_20mg

-        Range("I21") = .patients_stationar_nmg

-        Range("L19") = .patients_stationar_clexan

-        Range("L20") = .patients_stationar_clexan_20mg

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id)

-

-        formula = "=" & qtr.ClxnH20mg & "*($L$10+$L$20)+" & qtr.ClxnH40mg & "*($L$11+$L$21)"

-        Range("F11").formula = formula

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objHir() As tHIRURGIA

-        Dim i As Integer

-        i = GetAll_Hir_RecordsByLPU_ID(objHir, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.3

-        Else

-            SetupData objHir(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-mSapes
->>>>>>
-Attribute VB_Name = "mSapes"

-Option Explicit

-

-Const SHAPE_COLOR As Integer = 1

-Const SHAPE_NAME As Integer = 2

-

-

-Sub ShapeView(r_sh_finite_state As Range)

-    Dim chk As Range

-    Dim s As String

-    Dim c, idx As Integer

-    For Each chk In r_sh_finite_state

-        idx = 0

-        If chk = "+" Then

-            c = chk.Offset(0, idx + SHAPE_COLOR)

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While c <> 0

-                ShapeFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s)), c

-                idx = idx + 2

-                c = chk.Offset(0, idx + SHAPE_COLOR)

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        Else

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While s <> ""

-                ShapeUnFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s))

-                idx = idx + 2

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        End If

-    Next chk

-End Sub

-

-Sub ShapeFill(sh As ShapeRange, ByVal color As Integer)

-    sh.Fill.Visible = msoTrue

-    sh.Fill.Solid

-    sh.Fill.ForeColor.SchemeColor = color

-    sh.Fill.Transparency = 0#

-End Sub

-

-Sub ShapeUnFill(sh As ShapeRange)

-    sh.Fill.Visible = msoFalse

-    sh.Fill.Transparency = 0#

-End Sub

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Public Const INPUT_NO = 0

-Public Const INPUT_NUMBER = 1

-Public Const INPUT_PERCENT = 2

-Public Const INPUT_STRING = 3

-Public Const INPUT_CHECK = 4

-

-Public Const INP_IDX_TYPE = 1

-Public Const INP_IDX_NEXT = 2

-Public Const INP_IDX_MIN = 3

-Public Const INP_IDX_MAX = 4

-Public Const INP_IDX_DEP = 5

-Public Const INP_IDX_ALT = 7

-

-

-Public Type tInputSet

-    vType As Integer

-    vMin As Long

-    vMax As Long

-    rChk As String

-End Type

-

-Function is_input_cell(ByVal Target As Range, inputs As Range) As tInputSet

-    Dim t As Range

-    Dim iset As tInputSet

-    Dim test As Range

-    iset.vType = INPUT_NO

-    iset.vMin = 0

-    iset.vMax = 0

-    iset.rChk = ""

-    is_input_cell = iset

-

-' Закоментировать следующую сточку для работы

-'  Exit Function

-

-    Set test = Target.Cells(1, 1)

-    For Each t In inputs

-        If Range(t).Column = test.Column And Range(t).row = test.row Then

-            iset.vType = t.Offset(0, INP_IDX_TYPE).Value

-            Select Case iset.vType

-                Case INPUT_CHECK

-                    iset.rChk = t.Offset(0, INP_IDX_ALT)

-                Case INPUT_NUMBER, INPUT_PERCENT

-                    iset.vMin = t.Offset(0, INP_IDX_MIN).Value

-                    iset.vMax = t.Offset(0, INP_IDX_MAX).Value

-            End Select

-            is_input_cell = iset

-            Exit Function

-        End If

-    Next t

-End Function

-

-Function GetFocusAddress(ByVal r As Range, f_next As Range) As String

-    Dim chk, t As Range

-    

-    For Each chk In f_next

-        For Each t In r

-            If t.address = chk Then

-                GetFocusAddress = chk

-                Exit Function

-            End If

-            If Range(chk).Column = t.Column - 1 And Range(chk).row = t.row _

-            Or Range(chk).Column = t.Column And Range(chk).row = t.row - 1 _

-            Then

-                If Range(chk) <> "" Then

-                    If Range(chk) = 0 Then

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_ALT)).address

-                    Else

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_NEXT)).address

-                    End If

-                Else

-                    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-                End If

-                Exit Function

-            End If

-        Next t

-    Next chk

-    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-End Function

-

-Sub SetDependet(r As Range, inputs As Range)

-    Dim chk As Range

-    Dim s, serr As String

-    Dim idx As Integer

-    Dim iset As tInputSet

-    Dim err_found As Boolean

-    

-    If r.count > 1 Then

-        Exit Sub

-    End If

-    

-    err_found = False

-    For Each chk In inputs

-        idx = INP_IDX_DEP

-        

-        

-        iset.vType = chk.Offset(0, INP_IDX_TYPE).Value

-        Select Case iset.vType

-            Case INPUT_NUMBER, INPUT_PERCENT

-                iset.vMin = chk.Offset(0, INP_IDX_MIN).Value

-                iset.vMax = chk.Offset(0, INP_IDX_MAX).Value

-                

-                If Range(chk) > iset.vMax Then

-                    err_found = True

-                    Range(chk) = iset.vMax

-                    serr = "Выход за дозволенный диапазон [" & iset.vMin & ".." & iset.vMax & "]! Данные скорректированы."

-                End If

-                

-                If Range(chk) = "" Then

-                    s = chk.Offset(0, idx)

-                    Do While s <> ""

-                        Range(s) = ""

-                        idx = idx + 1

-                        s = chk.Offset(0, idx)

-                    Loop

-                End If

-        End Select

-    Next chk

-    If err_found Then

-        MsgBox serr, vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Function CheckInputData(inputs As Range) As Boolean

-    Dim r As Range

-    

-    CheckInputData = True

-    For Each r In inputs

-        If Range(r) = "" Then

-            CheckInputData = False

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100.", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Sub Check_Int_Number(Target As Range, Def_Val As Long)

-    Dim err As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    err = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                err = True

-            End If

-        End If

-    Next r

-    If err Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_TER
->>>>>>
-Attribute VB_Name = "LPU_CLSN_TER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim objTer As tTERAPIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objTer

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .patients_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L20")

-            End With

-            Insert_Ter_Record objTer

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objTer.id = Range("rec_id")

-                    If objTer.id <> 0 Then

-                        Delete_Ter_Record objTer

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objTer As tTERAPIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    With objTer

-        Range("rec_id") = .id

-        Range("F6") = .patients_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L11") = .patients_ambulator_clexan

-        Range("I21") = .patients_stationar_nmg

-        Range("L20") = .patients_stationar_clexan

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id)

-        formula = "=" & qtr.ClxnT40mg & "*($L$12+$L$20)"

-        Range("F11").formula = formula

-

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objTer() As tTERAPIA

-        Dim i As Integer

-        i = GetAll_Ter_RecordsByLPU_ID(objTer, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.25

-        Else

-            SetupData objTer(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{5D2CB2D2-3E5E-4B6E-9E0C-2EEBA5E10E17}{C891C133-B6B4-43D3-B411-B4A821905C23}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-LPU_BDGT
->>>>>>
-Attribute VB_Name = "LPU_BDGT"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub SetDefFocus()

-    Range(Range("DEF_FOCUS")).Select

-End Sub

-

-Public Sub ClearData()

-    ClearSheetData

-End Sub

-

-Sub ClearSheetData()

-    If Range("F10") = 0 And Range("F13") = 0 Then

-        Range("F11:F18") = ""

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("F11:F13") = ""

-    End If

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim bdgt As tBUDGET

-        Dim test As Boolean

-        Dim sum As Long

-        With bdgt

-            .lpu_id = Range("lpu_id")

-            .id = Range("rec_id")

-            .entry_date = Range("ent_date")

-            .bdgt_NMG = Round(Range("F11").Value, 0)

-            .bdgt_NFG = Round(Range("F12").Value, 0)

-            .sale_PLAN = Round(Range("F13").Value, 0)

-

-            sum = .bdgt_NFG + .bdgt_NMG - .sale_PLAN

-            test = .bdgt_NFG <> 0 Or .bdgt_NMG <> 0 Or .sale_PLAN <> 0

-        End With

-        If test Then

-            If sum < 0 Then

-                MsgBox _

-                    "Ваш план превышает выделенный на гепарины бюджет. Сохранить данные?", _

-                    vbOKOnly, PROGRAM_NAME

-            End If

-            If test Then

-                Insert_BDGT_Record bdgt

-            End If

-        Else

-            If bdgt.id <> 0 Then

-                If vbYes = MsgBox("Удалить данные из базы!", vbYesNo, PROGRAM_NAME) Then

-                    Delete_BDGT_Record bdgt

-                End If

-                ret_back Range("DEF_FOCUS").Worksheet

-                Exit Sub

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-    End If

-

-   ClearData

-   ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(cLPU As tLPU_COMMON)

-    Dim t_sum As Long

-    t_sum = 0

-' Setup budget data

-    Range("F11") = cLPU.bdgt.bdgt_NMG

-    Range("F12") = cLPU.bdgt.bdgt_NFG

-    Range("F13") = cLPU.bdgt.sale_PLAN

-

-    With cLPU

-        Range("F14") = .pat_ALL

-        Range("F15") = .pat_HIR

-        Range("F16") = .pat_TER

-        Range("F17") = .pat_CRD

-        Range("F18") = .sale_ALL

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-    ws_activate

-End Sub

-

-

-Sub ws_activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Dim cLPU As tLPU_COMMON

-    Dim objQTR As tQTR

-    Dim objLPU As tLPU

-    Dim ent_date As String

-    Dim id As Long

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    id = Range("lpu_id").Value

-    ent_date = Range("ent_date")

-    

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-

-    objLPU = Get_LPU_Record(id)

-    Get_LPU_Common cLPU, objLPU, objQTR

-

-    If cLPU.lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = cLPU.lpu.beds

-        Range("lpu_name") = cLPU.lpu.name

-        Range("lpu_addr") = cLPU.lpu.address

-        Range("rec_id") = cLPU.bdgt.id

-

-        SetupData cLPU

-

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-'    MsgBox Target.address

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case INPUT_CHECK

-

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{BB60E38F-A4AB-4AB4-91D0-40AA798D9F5C}{BE9A54D9-F093-4755-9E17-0B47BB5E2546}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mSheets
->>>>>>
-Attribute VB_Name = "mSheets"

-Option Explicit

-

-Function am_load_now() As Boolean

-    am_load_now = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE")

-End Function

-

-Sub Wks_select(RetSheet As String)

-    Dim sheet As Worksheet

-    For Each sheet In ThisWorkbook.Worksheets

-        If sheet.name = RetSheet Then

-            ThisWorkbook.Worksheets(RetSheet).Select

-            Exit Sub

-        End If

-    Next sheet

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub ret_back(sh As Worksheet)

-    Dim RetSheet As String

-    RetSheet = sh.Range("ret_addr")

-    sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    sh.Range("ret_addr") = ""

-    sh.Range("rec_id") = ""

-    sh.Range("lpu_id") = ""

-    sh.Range("ent_date") = ""

-    sh.Range("lpu_name") = ""

-    sh.Range("lpu_addr") = ""

-    sh.Range("lpu_beds") = ""

-    Wks_select RetSheet

-End Sub

-

-Sub ClearSheetData(r_start As Range)

-    If r_start <> "" Then

-        r_start.Worksheet.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        r_start = ""

-    Else

-        ret_back r_start.Worksheet

-    End If

-End Sub

-

-Sub wks_sel_chng(iset As tInputSet, ByVal Target As Range, sh As Worksheet)

-    Dim DebugMode As Boolean

-    Dim in_range As Range

-    

-    DebugMode = Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-

-    If DebugMode Then

-        sh.Unprotect

-    Else

-        sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    End If

-

-    If iset.vType = INPUT_CHECK Then

-        Set in_range = Target.Worksheet.Range(iset.rChk)

-    Else

-        Set in_range = Target

-    End If

-    

-    Dim str As String

-    str = GetFocusAddress(in_range, sh.Range("h_inputs"))

-

-'    MsgBox Target.Address & "; " & str

-    If str <> Target.address Then

-        sh.Range(str).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-Dlg_lpu_card
->>>>>>
-Attribute VB_Name = "Dlg_lpu_card"

-Attribute VB_Base = "0{2C69E842-8DA9-4240-A0A8-F6B0141DC246}{75AAB28C-ADCF-4D1B-9D5A-AF89E80A810C}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbLPU_List_Change()

-    Dim src As Range

-    Dim idx_src As Integer

-    

-    Set src = Worksheets(VAR_SHEET).Range(Me.cbLPU_List.RowSource)

-    idx_src = Me.cbLPU_List.ListIndex + 1

-    Me.tb_lpu_name.Text = src.Cells(idx_src, 1)

-    Me.tb_lpu_address.Text = src.Cells(idx_src, 2)

-    Me.tbBedsCount.Text = src.Cells(idx_src, 3)

-End Sub

-

-

-Private Sub cbxLPU_List_Enable_Click()

-    

-    If Me.cbxLPU_List_Enable Then

-        

-        Me.tb_lpu_name.Text = ""

-        Me.tb_lpu_name.Enabled = False

-        

-        Me.tb_lpu_address.Text = ""

-        Me.tb_lpu_address.Enabled = False

-        

-        Me.tbBedsCount.Text = ""

-        Me.tbBedsCount.Enabled = False

-        

-        Me.cbLPU_List.Enabled = True

-        cbLPU_List_Change

-    Else

-        Me.tb_lpu_name.Enabled = True

-        Me.tb_lpu_name.Text = ""

-        

-        Me.tb_lpu_address.Enabled = True

-        Me.tb_lpu_address.Text = ""

-        

-        Me.tbBedsCount.Enabled = True

-        Me.tbBedsCount.Text = ""

-        

-        Me.cbLPU_List.Enabled = False

-    End If

-End Sub

-

-<<<<<<
-======================
-UserInfo
->>>>>>
-Attribute VB_Name = "UserInfo"

-Attribute VB_Base = "0{BA873669-5C2D-400A-8A8B-572ACD8CCE4C}{D11400A0-9912-4240-A78C-44C33731216A}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Tag = vbOK

-End Sub

-

-Private Sub cbCity_Change()

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_CITY") = Me.cbCity.ListIndex

-        .Calculate

-    End With

-End Sub

-

-Private Sub cbRegion_Change()

-    Dim LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        NewRangeOffsetCol = cbRegion.Value * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).address

-        NewSumRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).address

-        .Calculate

-        .Range("IDX_CITY") = 0

-        cbCity.RowSource = NewCbxRange

-

-    End With

-    cbCity.ListIndex = 0

-End Sub

-

-<<<<<<
-======================
-mREGMAN
->>>>>>
-Attribute VB_Name = "mREGMAN"

-Option Explicit

-

-Sub hwnew()

-    Dim rs As Range

-    Dim re As Object

-    

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    HWReset

-    ReSet_REGMAN_Record

-    With Worksheets("RM_QTR")

-        .ClearRMName

-        .Range("REP_QTR_INPUT_DATA").ClearContents ' Это не ошибка, названия совпадают

-'        .Range("A1").Select

-    End With

-    Worksheets(TITLE_SHEET).Select

-    With Application

-        .DisplayAlerts = False

-        .ThisWorkbook.Save

-        .Quit

-    End With

-End Sub

-

-Function CheckUser() As Boolean

-    Dim objHW() As Long

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    

-    GetHWInfo objHW()

-    i = GetHWRecords(objHW_DB)

-    

-    If i = 0 Then ' First time

-        StoreHWInfo objHW()

-    End If

-    If CheckHWInfo(objHW()) <> True Then

-        CheckUser = False

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    Else

-        CheckUser = SetupUser

-    End If

-End Function

-

-Function SetupUser() As Boolean

-    Dim cREGMAN As tREGMAN

-    Dim idx As Integer

-    Dim dlg_ui As UserInfo

-    

-    Set dlg_ui = New UserInfo

-    

-    cREGMAN = Get_REGMAN_Record()

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_REGION") = cREGMAN.Region

-        .Range("IDX_CITY") = cREGMAN.City

-    End With

-        

-    With dlg_ui

-        .cbRegion = cREGMAN.Region

-        .cbCity = cREGMAN.City

-        .tbFName = cREGMAN.FirstName

-        .tbLName = cREGMAN.LastName

-    End With

-    

-    Worksheets(REGS_SHEET).Calculate

-    

-    Dim test_Ok As Boolean

-    test_Ok = False

-    

-    On Error GoTo l1

-    

-    Do

-        dlg_ui.Show

-        If dlg_ui.Tag = vbOK Then

-            test_Ok = dlg_ui.tbFName.Value <> "" And dlg_ui.tbLName <> ""

-            If test_Ok Then

-                Exit Do

-            Else

-                MsgBox "Введите имя и фамилию", vbOKOnly, PROGRAM_NAME

-            End If

-        Else

-            Exit Do

-        End If

-    Loop Until False

-l1:

-    If test_Ok Then

-        With cREGMAN

-            .Region = dlg_ui.cbRegion.Value

-            .City = dlg_ui.cbCity.Value

-            .FirstName = dlg_ui.tbFName.Value

-            .LastName = dlg_ui.tbLName.Value

-        End With

-        Set_REGMAN_Record cREGMAN

-    Else

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .ThisWorkbook.Saved = True

-            .Quit

-        End With

-    End If

-    SetupUser = test_Ok

-End Function

-

-Sub GetHWInfo(objHW() As Long)

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    i = 1

-    For Each d In dc

-        If d.drivetype = 2 Then ' 2 - HardDisk

-            ReDim Preserve objHW(i)

-            objHW(i) = d.SerialNumber

-            i = i + 1

-        End If

-    Next

-    SortHW objHW

-End Sub

-

-Sub StoreHWInfo(objHW() As Long)

-    UpdateHWRecords objHW

-End Sub

-

-Sub SortHW(objHW() As Long)

-    Dim r As Range

-    Dim rs As Range

-    Dim re As Object

-    Dim i As Integer

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    For i = 1 To UBound(objHW)

-        r = objHW(i)

-        Set r = r.Offset(1, 0)

-    Next i

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).Sort _

-            Key1:=.Range("HW_Number"), _

-            Order1:=xlDescending, _

-            Header:=xlGuess, _

-            OrderCustom:=1, _

-            MatchCase:=False, _

-            Orientation:=xlTopToBottom

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    i = 1

-    Do While r <> ""

-        objHW(i) = r

-        Set r = r.Offset(1, 0)

-        i = i + 1

-    Loop

-End Sub

-

-Function CheckHWInfo(objHW() As Long)

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    CheckHWInfo = False

-        

-    i = GetHWRecords(objHW_DB)

-    If i > 0 Then

-        SortHW objHW_DB

-    End If

-    If UBound(objHW) = UBound(objHW_DB) Then

-        For i = 1 To UBound(objHW)

-            If objHW(i) <> objHW_DB(i) Then

-                Exit Function

-            End If

-        Next i

-        CheckHWInfo = True

-    End If

-End Function

-

-

-<<<<<<
-======================
-dbBudget
->>>>>>
-Attribute VB_Name = "dbBudget"

-Option Explicit

-

-Public Type tBUDGET

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    bdgt_NMG As Long

-    bdgt_NFG As Long

-    sale_PLAN As Long

-End Type

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function GetAll_BDGT_RecordsByLPU_ID(ByRef allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_BDGT_RecordsByLPU_ID = dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection, allBDGT, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function Get_BDGT_Record(ByVal lpu_id As Long, ByVal ent_date As String) As tBUDGET

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    Get_BDGT_Record = dbGet_BDGT_Record(dbConnection, lpu_id, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objBDGT.ID <> 0 then updatre else insert

-Public Sub Insert_BDGT_Record(objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    If objBDGT.id <> 0 Then

-        dbUpdate_BDGT_Record dbConnection, objBDGT

-    Else

-        dbInsert_BDGT_Record dbConnection, objBDGT

-    End If

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Public Sub Delete_BDGT_Record(ByRef objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    dbDelete_BDGT_Record dbConnection, objBDGT

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_BDGT_Record(dbConnection As Object, ByVal lpu_id As Long, ent_date As String) As tBUDGET

-    

-    Dim sql As String

-    Dim objBDGT As tBUDGET

-    

-    With objBDGT

-        .id = 0

-        .lpu_id = lpu_id

-        .entry_date = ent_date

-        .bdgt_NMG = 0

-        .bdgt_NFG = 0

-        .sale_PLAN = 0

-    End With

-        

-    

-    sql = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        With objBDGT

-            .entry_date = dbRecordset("entry_date")

-            .id = dbRecordset("id")

-            .lpu_id = dbRecordset("lpu_id")

-            .bdgt_NFG = dbRecordset("bdgt_NFG")

-            .bdgt_NMG = dbRecordset("bdgt_NMG")

-            .sale_PLAN = dbRecordset("sale_PLAN")

-        End With

-    End If

-    

-    dbGet_BDGT_Record = objBDGT

-End Function

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection As Object, allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_BDGT_SQL As String

-    Dim getAll_BDGT_SQL As String

-    Dim BDGT_Count As Long

-    BDGT_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_BDGT_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        BDGT_Count = dbRecordset("BDGT_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_BDGT_RecordsbyLPU_ID = BDGT_Count

-    

-    If BDGT_Count > 0 Then

-        'we have records

-        ReDim allBDGT(1 To BDGT_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_BDGT_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpBDGT As tBUDGET

-                 With tmpBDGT

-                    .entry_date = dbRecordset("entry_date")

-                    .id = dbRecordset("id")

-                    .lpu_id = dbRecordset("lpu_id")

-                    .bdgt_NFG = dbRecordset("bdgt_NFG")

-                    .bdgt_NMG = dbRecordset("bdgt_NMG")

-                    .sale_PLAN = dbRecordset("sale_PLAN")

-                 End With

-                 

-                 allBDGT(index) = tmpBDGT

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbInsert_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "lpu_budget", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    dbRecordset("entry_date") = objBDGT.entry_date

-    dbRecordset("lpu_id") = objBDGT.lpu_id

-    dbRecordset("bdgt_NMG") = objBDGT.bdgt_NMG

-    dbRecordset("bdgt_NFG") = objBDGT.bdgt_NFG

-    dbRecordset("sale_PLAN") = objBDGT.sale_PLAN

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objBDGT.id = dbRecordset("id")

-  

-End Sub

-

-Public Sub dbUpdate_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu_budget SET " & _

-    "entry_date='" & objBDGT.entry_date & "'," & _

-    "lpu_id=" & objBDGT.lpu_id & "," & _

-    "bdgt_NMG=" & objBDGT.bdgt_NMG & "," & _

-    "bdgt_NFG=" & objBDGT.bdgt_NFG & "," & _

-    "sale_PLAN=" & objBDGT.sale_PLAN & _

-    " WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-Public Sub dbDelete_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_BDGT_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbDatabase
->>>>>>
-Attribute VB_Name = "dbDatabase"

-Option Explicit

-

-

-Sub dbOpenConnection(dbConnection As Object)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-<<<<<<
-======================
-dbLPU
->>>>>>
-Attribute VB_Name = "dbLPU"

-Option Explicit

-

-Public Type tLPU

-    id As Long

-    rep_id As Long

-    name As String

-    address As String

-    beds As Integer

-End Type

-

-Function Get_LPU_Record(ByVal lpu_id As Long) As tLPU

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_LPU_Record = dbGet_LPU_Record(dbConnection, lpu_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_LPU_byQTR(allLPU() As tLPU, ent_date As String, rep_id As Long) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_LPU_byQTR = dbGetAll_LPU_byQTR(dbConnection, allLPU, ent_date, rep_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_Record(dbConnection As Object, ByVal lpu_id As Long) As tLPU

-    

-    Dim sql As String

-    Dim objLPU As tLPU

-    

-    objLPU.id = lpu_id

-    objLPU.name = ""

-    objLPU.address = ""

-    

-    sql = "SELECT * FROM lpu WHERE id=" & lpu_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objLPU.name = dbRecordset("name")

-        objLPU.address = dbRecordset("address")

-        objLPU.rep_id = dbRecordset("rep_id")

-        objLPU.beds = dbRecordset("beds")

-    End If

-    

-    dbGet_LPU_Record = objLPU

-

-End Function

-

-Function dbGetAll_LPU_byQTR(dbConnection As Object, allLPU() As tLPU, ent_date As String, rep_id As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    Dim Where As String

-    Where = "WHERE lpu_budget.entry_date like '" & ent_date & "'" & " AND lpu.id=lpu_budget.lpu_id AND lpu.rep_id=" & rep_id

-

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu_budget, lpu " & Where

-    

-    getAll_LPU_SQL = "SELECT lpu.id as id, lpu.rep_id as rep_id, lpu.name as name, lpu.address as address, lpu.beds AS beds " & _

-    "FROM lpu, lpu_budget " & Where

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_LPU_byQTR = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-dbREP
->>>>>>
-Attribute VB_Name = "dbREP"

-'Option Explicit

-'

-'Public Type tREP

-'    FirstName As String

-'    LastName As String

-'    Region As Integer

-'    City As Integer

-'End Type

-'

-'Function GetREPRecord() As tREP

-'    Dim dbConnection As Object

-'

-'    dbOpenConnection dbConnection

-'    GetREPRecord = dbGetREPRecord(dbConnection)

-'    dbCloseConnection dbConnection

-'End Function

-'

-'Sub SetREPRecord(cUser As tREP)

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbSetREPRecord dbConnection, cUser

-'    dbCloseConnection dbConnection

-'End Sub

-'

-'Sub ReSetREPRecord()

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbReSetREPRecord dbConnection

-'    dbCloseConnection dbConnection

-'End Sub

-'

-'Public Function dbGetREPRecord(dbConnection As Object) As tREP

-'

-'    Dim SQL As String

-'    Dim objREP As tREP

-'

-'    objREP.FirstName = ""

-'    objREP.LastName = ""

-'    objREP.Region = 0

-'    objREP.City = 0

-'    SQL = "SELECT firstname, lastname, region, city FROM " & _

-'          "rep"

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open SQL, dbConnection

-'    ', 3, 3

-'    If Not dbRecordset.BOF Then

-'

-'        objREP.FirstName = dbRecordset("firstname")

-'        objREP.LastName = dbRecordset("lastname")

-'        objREP.Region = dbRecordset("region")

-'        objREP.City = dbRecordset("city")

-'

-'    End If

-'

-'    dbGetREPRecord = objREP

-'

-'End Function

-'

-'Public Sub dbSetREPRecord(dbConnection As Object, ByRef objREP As tREP)

-'

-'    Dim DeleteSQL As String

-'    Dim InsertSQL As String

-'

-'    DeleteSQL = "DELETE FROM rep"

-'    InsertSQL = "INSERT INTO rep (firstname, lastname, region, city) VALUES (" & _

-'    "'" & objREP.FirstName & "', " & _

-'    "'" & objREP.LastName & "', " & _

-'    objREP.Region & ", " & _

-'    objREP.City & ")"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-'

-'End Sub

-'

-'Public Sub dbReSetREPRecord(dbConnection As Object)

-'

-'    Dim DeleteSQL As String

-'

-'    DeleteSQL = "DELETE FROM rep"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-'

-'End Sub

-'

-

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    CheckWorkBooksArround Wb

-End Sub

-

-

-Sub CheckWorkBooksArround(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If app.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKOnly, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-        Exit Sub

-    End If

-

-End Sub

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub SaveExcelState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-        ActiveWorkbook.DisplayDrawingObjects = xlDisplayShapes

-        

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars(STDBAR_NAME).Visible = False

-End Sub

-

-

-Public Sub RestoreExcelState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars(STDBAR_NAME).Visible = True

-End Sub

-

-

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Public Const STDBAR_NAME = "Worksheet Menu Bar"

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Import"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmImport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Export"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 620

-                        .OnAction = "cmExport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Exit && Restore Excel"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 548

-                        .OnAction = "cmExitRestore"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-       End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(flag As Boolean)

-    If flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars(STDBAR_NAME)

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmImport()

-    Worksheets(RM_QTR_SHEET).Select

-    ImportData

-End Sub

-

-Sub cmExport()

-    dbExport

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    Dim dlg As dlgAbout

-    Set dlg = New dlgAbout

-    

-    dlg.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlg.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlg.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlg.Show

-End Sub

-

-Sub cmMail2Support()

-    Dim err_description As String

-    Dim dlg_msg As dlg_Mail

-    Set dlg_msg = New dlg_Mail

-    With dlg_msg

-        .Show

-        If .Tag = vbOK Then

-            ThisWorkbook.Worksheets(VAR_SHEET).Range("ERR_MESSAGE") _

-                = .tbMessage.Text

-            ThisWorkbook.Save

-            ThisWorkbook.SendMail Recipients:="infra@i-rs.ru", Subject:=PROGRAM_NAME & " ver.:" & PROGRAM_VERSION

-            MsgBox "Сообщение об ошибке отправлено. Перезагрузите программу.", vbOKOnly, PROGRAM_NAME

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-    End With

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-'        helppath = "hh.exe " & .Path & "\Telfast.chm"

-'        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub set_work_mode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetupEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-End Sub

-

-Sub cmSetStandaloneMode()

-    set_work_mode

-    ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    Dim dlg As dlgGetPwd

-    rp = common_pwd

-    

-    Set dlg = New dlgGetPwd

-    dlg.edPwd = ""

-    dlg.Show

-    

-    If dlg.edPwd = rp Then

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmHomePage()

-    ThisWorkbook.Worksheets("RM_QTR").Select

-End Sub

-

-Sub cmExitRestore()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = True

-    Application.Quit

-End Sub

-

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    Dim dlg_prn As dlgPrint

-    

-    Set dlg_prn = New dlgPrint

-    

-    With dlg_prn

-        .cbMainReport = True

-        .cbMainBudget = False

-        .cbSrcData = False

-        .cbAllSheets = False

-    

-        .Show

-    

-        If .Tag = vbCancel Then

-            Exit Sub

-        End If

-    End With

-    

-    Dim PrnIdx As Integer

-    

-    With dlg_prn

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("REP_QTR", "budget", "Final")

-    Case 1111

-        plist = Array("REP_QTR", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("REP_QTR")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Clexane bar"

-Public Const common_pwd As String = "crdjhxtyjr"

-

-

-Sub SetupEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    Wb.Worksheets(TITLE_SHEET).Select

-    With Application

-        .Caption = PROGRAM_NAME & " " & PROGRAM_VERSION

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .SaveExcelState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = False

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Wb.Worksheets(TITLE_SHEET).Select

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    If cWindow.Type = xlWorkbook Then

-                        cWindow.DisplayHeadings = True

-                    End If

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu True

-        End If

-        With mobjAppState

-            .RestoreExcelState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Worksheets(TITLE_SHEET).Select

-'        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Option Explicit

-

-Sub UpdateHWRecords(objHW() As Long)

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    dbUpdateHWRecords dbConnection, objHW

-    dbCloseConnection dbConnection

-End Sub

-

-Function GetHWRecords(objHW() As Long) As Integer

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    GetHWRecords = dbGetHWRecords(dbConnection, objHW)

-    dbCloseConnection dbConnection

-End Function

-

-Sub HWReset()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbInsertHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    

-    Dim dbRecordset As Object

-    Dim i As Long

-    

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "hw", dbConnection, 2, 2

-    

-    For i = 1 To UBound(objHW)

-        dbRecordset.addnew

-        dbRecordset("num") = objHW(i)

-        dbRecordset.Update

-    Next i

-    

-End Sub

-

-Sub dbUpdateHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    dbDeleteHWRecord dbConnection

-    dbInsertHWRecords dbConnection, objHW

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-dbHir
->>>>>>
-Attribute VB_Name = "dbHir"

-Option Explicit

-

-Public Type tHIRURGIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    operations_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_ambulator_clexan_40mg As Integer

-    patients_ambulator_clexan_20mg As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-    patients_stationar_clexan_40mg As Integer

-    patients_stationar_clexan_20mg As Integer

-End Type

-

-' if objHir.ID <> 0 then updatre else insert

-Sub Insert_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objHir.id <> 0 Then

-        dbUpdate_Hir_Record dbConnection, objHir

-    Else

-        dbInsert_Hir_Record dbConnection, objHir

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Hir_RecordsByLPU_ID(ByRef allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Hir_RecordsByLPU_ID = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, allHir, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Hir_Record dbConnection, objHir

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objHir.ID <> 0 then updatre else insert

-

-Sub dbInsert_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_hir", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objHir

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("operations_per_quarter") = .operations_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_ambulator_clexan_20mg") = .patients_ambulator_clexan_20mg

-        dbRecordset("patients_ambulator_clexan_40mg") = .patients_ambulator_clexan_40mg

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-        dbRecordset("patients_stationar_clexan_20mg") = .patients_stationar_clexan_20mg

-        dbRecordset("patients_stationar_clexan_40mg") = .patients_stationar_clexan_40mg

-        

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objHir.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim UpdateSQL As String

-    

-    With objHir

-        UpdateSQL = "UPDATE lpu_hir SET " & _

-            "entry_date='" & objHir.entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "operations_per_quarter=" & .operations_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_ambulator_clexan_20mg=" & .patients_ambulator_clexan_20mg & "," & _

-            "patients_ambulator_clexan_40mg=" & .patients_ambulator_clexan_40mg & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & "," & _

-            "patients_stationar_clexan_20mg=" & .patients_stationar_clexan_20mg & "," & _

-            "patients_stationar_clexan_40mg=" & .patients_stationar_clexan_40mg & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_Hir_RecordsbyLPU_ID(dbConnection As Object, allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Hir_SQL As String

-    Dim getAll_Hir_SQL As String

-    Dim Hir_Count As Long

-    Hir_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Hir_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Hir_Count = dbRecordset("HIR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Hir_RecordsbyLPU_ID = Hir_Count

-    

-    If Hir_Count > 0 Then

-        'we have records

-        ReDim allHir(1 To Hir_Count)

-        Dim index As Integer

-        index = 1

-        dbRecordset.Open getAll_Hir_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpHir As tHIRURGIA

-                 With tmpHir

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .operations_per_quarter = dbRecordset("operations_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_ambulator_clexan_20mg = dbRecordset("patients_ambulator_clexan_20mg")

-                    .patients_ambulator_clexan_40mg = dbRecordset("patients_ambulator_clexan_40mg")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                    .patients_stationar_clexan_20mg = dbRecordset("patients_stationar_clexan_20mg")

-                    .patients_stationar_clexan_40mg = dbRecordset("patients_stationar_clexan_40mg")

-                 End With

-                 

-                 allHir(index) = tmpHir

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE ID=" & objHir.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Hir_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbTer
->>>>>>
-Attribute VB_Name = "dbTer"

-Option Explicit

-

-Public Type tTERAPIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objTer.ID <> 0 then updatre else insert

-Sub Insert_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objTer.id <> 0 Then

-        dbUpdate_Ter_Record dbConnection, objTer

-    Else

-        dbInsert_Ter_Record dbConnection, objTer

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Ter_RecordsByLPU_ID(ByRef allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Ter_RecordsByLPU_ID = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, allTer, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Ter_Record dbConnection, objTer

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objTer.ID <> 0 then updatre else insert

-

-Sub dbInsert_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_ter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objTer

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objTer.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim Update_SQL As String

-    

-    With objTer

-        Update_SQL = "UPDATE lpu_ter SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_Ter_RecordsbyLPU_ID(dbConnection As Object, allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Ter_SQL As String

-    Dim getAll_Ter_SQL As String

-    Dim Ter_Count As Long

-    Ter_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Ter_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Ter_Count = dbRecordset("TER_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Ter_RecordsbyLPU_ID = Ter_Count

-    

-    If Ter_Count > 0 Then

-        'we have records

-        ReDim allTer(1 To Ter_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_Ter_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpTer As tTERAPIA

-                 With tmpTer

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 allTer(index) = tmpTer

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE ID=" & objTer.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Ter_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-mLPU_LIST
->>>>>>
-Attribute VB_Name = "mLPU_LIST"

-Option Explicit

-

-Public Const CINP_AREA As String = "B12"

-Public Const CLPU_NAME As Integer = 0

-Public Const CLPU_NAME1 As Integer = 1

-Public Const CLPU_NAME2 As Integer = 2

-Public Const CLPU_ID As Integer = 3

-Public Const CLPU_BEDS As Integer = 4

-Public Const CLPU_NFG As Integer = 5

-Public Const CLPU_NMG As Integer = 6

-Public Const CLPU_HIR As Integer = 7

-Public Const CLPU_TER As Integer = 8

-Public Const CLPU_CAR As Integer = 9

-Public Const CLPU_FACT As Integer = 10

-Public Const CLPU_PLAN As Integer = 11

-Public Const CLPU_PAT_LPU As Integer = 16

-Public Const CLPU_BDGT As Integer = 17

-Public Const CLPU_PAT_ALL As Integer = 16

-

-

-

-Sub EditLPU(cLPU As tLPU, ent_date As String)

-    NoFunc

-End Sub

-

-Sub Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-

-End Sub

-

-Sub Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btLPU_DEL_IT()

-    Dim cLPU As tLPU

-    Dim ent_date As String

-    Dim delete_all As Integer

-    Dim dlg_del As dlg_LPU_delete

-

-    With Worksheets("LPU_LIST")

-        ent_date = .Range("ent_date")

-        cLPU.id = .getCurrentLPU_ID()

-    End With

-

-    If cLPU.id = 0 Then

-        MsgBox "Укажите удаляемый объект", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    cLPU = Get_LPU_Record(cLPU.id)

-

-    Set dlg_del = New dlg_LPU_delete

-    With dlg_del

-        .chbDeleteQTR.Value = True

-        .chbDeleteAll.Value = False

-        .lComment = ent_date & ": Удаление ЛПУ '" _

-        & cLPU.name & "', расположенного по адресу:" _

-        & cLPU.address & " не разрешено."

-        .Show

-    End With

-End Sub

-

-Sub btLPU_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        

-        Wks_select .Range("ret_addr")

-    End With

-

-End Sub

-

-

-Sub btLPU_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim lpu_id As Long

-

-    i = Worksheets(VAR_SHEET).Range("QTR_ACTION").Value

-    With Worksheets("LPU_LIST")

-        ent_date = .getEnt_date()

-

-

-        lpu_id = .getCurrentLPU_ID

-        If lpu_id = 0 And i <> 6 Then

-            i = 1

-        End If

-        Select Case i

-            Case 1

-                .SelectLPU_NAME lpu_id, ent_date

-                .Range("JUMP") = ""

-            Case 2

-                .SelectLPU_BDGT lpu_id, ent_date

-                .Range("JUMP") = "LPU_BDGT"

-            Case 3

-                .SelectLPU_HIR lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_HIR"

-

-            Case 4

-                .SelectLPU_TER lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_TER"

-

-            Case 5

-                .SelectLPU_C_ACS lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        End Select

-    End With

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-dbQTR
->>>>>>
-Attribute VB_Name = "dbQTR"

-Option Explicit

-

-Public Type tQTR

-    id As Long

-    entry_date As String

-    rep_id As Long

-    sale_PLAN As Long

-    ClxnH20mg As Long

-    ClxnH40mg As Long

-    ClxnT40mg As Long

-    ClxnC_IM As Long

-    ClxnC_ACS As Long

-End Type

-

-Function Get_QTR_Record(ByVal QTR_ID As Long) As tQTR

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_QTR_Record = dbGet_QTR_Record(dbConnection, QTR_ID)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_Record(dbConnection As Object, ByVal QTR_ID As Long) As tQTR

-    

-    Dim sql As String

-    Dim objQTR As tQTR

-    

-    With objQTR

-        .ClxnC_ACS = 0

-        .ClxnC_IM = 0

-        .ClxnH20mg = 0

-        .ClxnH40mg = 0

-        .ClxnT40mg = 0

-        .entry_date = ""

-        .id = QTR_ID

-    End With

-    

-    sql = "SELECT * FROM quarter WHERE id=" & QTR_ID

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objQTR.entry_date = dbRecordset("entry_date")

-        objQTR.rep_id = dbRecordset("rep_id")

-        objQTR.sale_PLAN = dbRecordset("sale_plan")

-        objQTR.ClxnH20mg = dbRecordset("ClxnH20mg")

-        objQTR.ClxnH40mg = dbRecordset("ClxnH40mg")

-        objQTR.ClxnT40mg = dbRecordset("ClxnT40mg")

-        objQTR.ClxnC_IM = dbRecordset("ClxnC_IM")

-        objQTR.ClxnC_ACS = dbRecordset("ClxnC_ACS")

-        objQTR.id = dbRecordset("id")

-    End If

-    

-    dbGet_QTR_Record = objQTR

-

-End Function

-

-

-Function Get_QTR_Record_by_REP(ent_date As String, rep_id As Long) As tQTR

-    Dim dbConnection As Object

-    Dim allQTR() As tQTR

-    Dim i As Long

-

-    dbOpenConnection dbConnection

-

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id)

-    If i <> 0 Then

-        Get_QTR_Record_by_REP = allQTR(1)

-    End If

-

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTR_Records_by_REP(ByRef all_QTR() As tQTR, ent_date As String, rep_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-

-    GetAll_QTR_Records_by_REP = dbGetAll_QTR_Records_By_REP(dbConnection, all_QTR, ent_date, rep_id)

-

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGetAll_QTR_Records_By_REP(dbConnection As Object, all_QTR() As tQTR, ent_date As String, rep_id As Long) As Integer

-

-    Dim getCount_QTR_SQL As String

-    Dim getAll_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter " & _

-    "WHERE entry_date like '" & ent_date & "' AND rep_id=" & rep_id

-    getAll_QTR_SQL = "SELECT * FROM quarter " & _

-    "WHERE entry_date like '" & ent_date & "' AND rep_id=" & rep_id & " ORDER BY entry_date"

-

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-

-    dbRecordset.Close

-

-    dbGetAll_QTR_Records_By_REP = QTR_Count

-

-    If QTR_Count > 0 Then

-        'we have records

-        ReDim all_QTR(1 To QTR_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTR_SQL, dbConnection

-

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTR As tQTR

-                 With tmp_QTR

-                    .entry_date = dbRecordset("entry_date")

-                    .rep_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .ClxnH20mg = dbRecordset("ClxnH20mg")

-                    .ClxnH40mg = dbRecordset("ClxnH40mg")

-                    .ClxnT40mg = dbRecordset("ClxnT40mg")

-                    .ClxnC_IM = dbRecordset("ClxnC_IM")

-                    .ClxnC_ACS = dbRecordset("ClxnC_ACS")

-                    .id = dbRecordset("id")

-                 End With

-

-                 all_QTR(index) = tmp_QTR

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-cdbQTR
->>>>>>
-Attribute VB_Name = "cdbQTR"

-Option Explicit

-

-Public Type tQTR_COMMON

-    qtr As tQTR

-    i_lcd As Long           ' число ЛПУ в СПИСКЕ

-    lcd() As tLPU_COMMON    ' список ЛПУ

-    c_beds As Long          ' сумма коек

-    c_bdgt_NFG As Long      ' общий бюджет на НФГ

-    c_bdgt_NMG As Long      ' общий бюджет на НМГ

-    c_bdgt_LPU As Long      ' общий бюджет на гепарины

-    c_sale_PLAN As Long     ' план продаж репа

-    c_sale_ALL As Long      ' продажи

-    c_sale_HIR As Long      ' в хирургии

-    c_sale_TER  As Long     ' в терапии

-    c_sale_CRD  As Long     ' в кардиологии

-    c_pat_HIR   As Long     ' пациенты

-    c_pat_TER   As Long     '

-    c_pat_CRD   As Long     '

-    c_pat_ALL   As Long     '

-    c_pat_LPU   As Long     ' Всего операций

-End Type

-

-Function GetLastQTR_fromDB() As String

-    Dim dbConnection As Object

-    Dim getCount_QTR_SQL As String

-    Dim getLast_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter"

-    getLast_QTR_SQL = "SELECT MAX(entry_date) as ent_date FROM quarter"

-    

-    dbOpenConnection dbConnection

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    If QTR_Count > 0 Then

-        'we have records

-        dbRecordset.Open getLast_QTR_SQL, dbConnection

-        getLast_QTR_SQL = dbRecordset("ent_date")

-    End If

-    GetLastQTR_fromDB = getLast_QTR_SQL

-    dbCloseConnection dbConnection

-End Function

-

-Function Get_QTR_CommonList_by_REP(ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_QTR_CommonList_by_REP = dbGet_QTR_CommonList_by_REP(dbConnection, qcd, ent_date, rep_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_CommonList_by_REP(dbConnection As Object, ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim allQTR() As tQTR

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id)

-    dbGet_QTR_CommonList_by_REP = i

-    If i > 0 Then

-        ReDim qcd(i)

-        For i = 1 To UBound(allQTR)

-            With qcd(i)

-                .qtr = allQTR(i)

-                .c_beds = 0

-                .c_bdgt_NFG = 0

-                .c_bdgt_NMG = 0

-                .c_bdgt_LPU = 0

-                .c_sale_PLAN = 0

-                .c_pat_HIR = 0

-                .c_pat_TER = 0

-                .c_pat_CRD = 0

-                .c_pat_ALL = 0

-                .c_sale_HIR = 0

-                .c_sale_TER = 0

-                .c_sale_CRD = 0

-                .c_sale_ALL = 0

-                .c_pat_LPU = 0

-                

-                j = dbGet_LPU_CommonQTR(dbConnection, .lcd, .qtr)

-                .i_lcd = j

-                If j > 0 Then

-                    For j = 1 To UBound(.lcd)

-                        .c_beds = .c_beds + .lcd(j).lpu.beds

-                        .c_bdgt_NFG = .c_bdgt_NFG + .lcd(j).bdgt.bdgt_NFG

-                        .c_bdgt_NMG = .c_bdgt_NMG + .lcd(j).bdgt.bdgt_NMG

-                        .c_bdgt_LPU = .c_bdgt_LPU + .lcd(j).bdgt_LPU

-                        .c_sale_PLAN = .c_sale_PLAN + .lcd(j).bdgt.sale_PLAN

-                        .c_pat_HIR = .c_pat_HIR + .lcd(j).pat_HIR

-                        .c_pat_TER = .c_pat_TER + .lcd(j).pat_TER

-                        .c_pat_CRD = .c_pat_CRD + .lcd(j).pat_CRD

-                        .c_pat_ALL = .c_pat_ALL + .lcd(j).pat_ALL

-                        .c_sale_HIR = .c_sale_HIR + .lcd(j).sale_HIR

-                        .c_sale_TER = .c_sale_TER + .lcd(j).sale_TER

-                        .c_sale_CRD = .c_sale_CRD + .lcd(j).sale_CRD

-                        .c_sale_ALL = .c_sale_ALL + .lcd(j).sale_ALL

-                        .c_pat_LPU = .c_pat_LPU + .lcd(j).pat_LPU

-                    Next j

-                    

-                End If

-            End With

-        Next i

-    End If

-End Function

-

-Function GetLastQtr() As String

-    Dim s As String

-    Dim r As Range

-    Set r = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Do While r.Cells(1, 1) <> ""

-        s = r.Cells(1, 1)

-        Set r = r.Cells.Offset(1, 0)

-    Loop

-    GetLastQtr = s

-End Function

-

-Function GetNextQTR(ent_date As String) As String

-    Dim rd As Range

-    Dim idx As Integer

-    Dim b As Variant

-    Dim dlg As dlg_newQTR

-    Set dlg = New dlg_newQTR

-    

-    If ent_date = "" Then

-        Dim ir As Variant

-        idx = 0

-        dlg.Show

-        b = dlg.Tag

-            

-        If IsNumeric(b) Then

-            GetNextQTR = dlg.cbQTR

-        Else

-            GetNextQTR = ""

-        End If

-    Else

-        Set rd = Worksheets(VAR_SHEET).Range("Date_Lst")

-        idx = WorksheetFunction.Match(ent_date, rd, 0)

-        GetNextQTR = WorksheetFunction.index(rd, idx + 1, 1)

-    End If

-End Function

-<<<<<<
-======================
-mRestView
->>>>>>
-Attribute VB_Name = "mRestView"

-Option Explicit

-

-Sub xlRestoreView()

-Attribute xlRestoreView.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute xlRestoreView.VB_ProcData.VB_Invoke_Func = " \n14"

-    With Application

-        .CommandBars("Standard").Visible = True

-        .CommandBars("Formatting").Visible = True

-        .DisplayFormulaBar = True

-        .DisplayStatusBar = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = True

-    End With

-End Sub

-<<<<<<
-======================
-dlg_newQTR
->>>>>>
-Attribute VB_Name = "dlg_newQTR"

-Attribute VB_Base = "0{3EA3C15A-5493-445F-9858-2F241E7D6CEA}{849C1FE1-631A-485D-BE54-A7B73124582C}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mDec2TS
->>>>>>
-Attribute VB_Name = "mDec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-CHRT_LPU_BBL
->>>>>>
-Attribute VB_Name = "CHRT_LPU_BBL"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Unprotect

-    Range("view_key") = True

-    On Error Resume Next

-    ChangeLabels

-    Range("A1").Select

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Unprotect

-    Dim s As String

-    s = Range("ret_addr")

-    Protect UserInterfaceOnly:=True

-    Wks_select (s)

-End Sub

-

-Sub BCLabelChng_Click()

-    Unprotect

-    If Range("view_key") Then

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать названия"

-    Else

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать объемы"

-    End If

-    Range("view_key") = Not Range("view_key")

-    ChangeLabels

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub ChangeLabels()

-    Dim i As Integer

-    Dim offset_text As Integer

-    Dim src As Range

-    Set src = Range("CHRT_BBL_DATA")

-    

-    offset_text = 3

-    If Range("view_key") Then

-        offset_text = 4

-    End If

-    

-    With ChartObjects(1).Chart

-        With .SeriesCollection(1)

-            For i = 1 To .Points.count

-                On Error GoTo ExitLabel

-                .Points(i).DataLabel.Characters.Text = Format(src.Cells(i, offset_text))

-            Next i

-        End With

-    End With

-ExitLabel:

-End Sub

-

-<<<<<<
-======================
-CHRT_PAT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PAT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-<<<<<<
-======================
-CHRT_PAT_LPU
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_nextQTR
->>>>>>
-Attribute VB_Name = "dlg_nextQTR"

-Attribute VB_Base = "0{B85FF7F1-50C0-4433-BC6F-8A0F2C9BDDDA}{EC2D2B9E-9ED2-4005-A1E9-EF0626D3B7E7}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-cdbLPU
->>>>>>
-Attribute VB_Name = "cdbLPU"

-Option Explicit

-

-Public Type tLPU_COMMON

-    lpu As tLPU

-    bdgt As tBUDGET

-    i_hir As Long

-    hir() As tHIRURGIA

-    i_ter As Long

-    ter() As tTERAPIA

-    i_ACS As Long

-    ACS() As tACS

-    bdgt_LPU As Long

-    sale_HIR As Long

-    sale_TER As Long

-    sale_CRD As Long

-    sale_ALL As Long

-    pat_HIR As Long

-    pat_TER As Long

-    pat_CRD As Long

-    pat_ALL As Long     ' Сумма всех пациентов на клексане

-    pat_LPU As Long     ' Число потенциальных пациентов для продаж клексана

-End Type

-

-Function Get_LPU_CommonQTR(ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    Get_LPU_CommonQTR = dbGet_LPU_CommonQTR(dbConnection, lcd, objQTR)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_CommonQTR(dbConnection As Object, ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    i = dbGetAll_LPU_byQTR(dbConnection, allLPU, objQTR.entry_date, objQTR.rep_id)

-    dbGet_LPU_CommonQTR = i

-    If i > 0 Then

-        ReDim lcd(i)

-        For i = 1 To UBound(allLPU)

-            dbGet_LPU_Common dbConnection, lcd(i), allLPU(i), objQTR

-        Next i

-    End If

-End Function

-

-Sub Get_LPU_Common(ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    dbGet_LPU_Common dbConnection, lcd, cLPU, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbGet_LPU_Common(dbConnection As Object, ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-

-    lcd.lpu = cLPU

-    lcd.bdgt = dbGet_BDGT_Record(dbConnection, cLPU.id, objQTR.entry_date)

-    lcd.i_hir = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, lcd.hir, cLPU.id, objQTR.entry_date)

-    lcd.i_ter = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, lcd.ter, cLPU.id, objQTR.entry_date)

-    lcd.i_ACS = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, lcd.ACS, cLPU.id, objQTR.entry_date)

-    With lcd

-        .bdgt_LPU = .bdgt.bdgt_NFG + .bdgt.bdgt_NMG

-        .pat_LPU = 0

-        If .i_hir > 0 Then

-            .pat_HIR = .hir(1).patients_ambulator_clexan + .hir(1).patients_stationar_clexan

-            .sale_HIR = objQTR.ClxnH20mg * (.hir(1).patients_ambulator_clexan_20mg + .hir(1).patients_stationar_clexan_20mg)

-            .sale_HIR = .sale_HIR + objQTR.ClxnH40mg * (.hir(1).patients_ambulator_clexan_40mg + .hir(1).patients_stationar_clexan_40mg)

-            .pat_LPU = .pat_LPU + .hir(1).operations_per_quarter

-        End If

-        If .i_ter > 0 Then

-            .pat_TER = .ter(1).patients_ambulator_clexan + .ter(1).patients_stationar_clexan

-            .sale_TER = .pat_TER * objQTR.ClxnT40mg

-            .pat_LPU = .pat_LPU + .ter(1).patients_per_quarter

-        End If

-        If .i_ACS > 0 Then

-            .pat_CRD = .ACS(1).patients_stationar_clexan

-            .sale_CRD = .pat_CRD * objQTR.ClxnC_ACS

-            .pat_LPU = .pat_LPU + .ACS(1).patients_per_quarter

-        End If

-        .pat_ALL = .pat_HIR + .pat_TER + .pat_CRD

-        .sale_ALL = .sale_HIR + .sale_TER + .sale_CRD

-    End With

-End Sub

-

-<<<<<<
-======================
-CHRT_PIE
->>>>>>
-Attribute VB_Name = "CHRT_PIE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    

-    Unprotect

-    

-    On Error Resume Next

-    

-    Range("P5:Q24").Sort _

-        Key1:=Range("Q5"), _

-        Order1:=xlDescending, _

-        Header:=xlGuess, _

-        OrderCustom:=1, _

-        MatchCase:=False, _

-        Orientation:=xlTopToBottom

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PLN_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PLN_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_BDGT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_BDGT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_LPU_delete
->>>>>>
-Attribute VB_Name = "dlg_LPU_delete"

-Attribute VB_Base = "0{EC96F2D1-337D-47DF-B0F1-A6DF3F8CD5CC}{7EB42A63-CBFC-45B0-AE4D-C3E3D8FE7420}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlg_Mail
->>>>>>
-Attribute VB_Name = "dlg_Mail"

-Attribute VB_Base = "0{7B669454-C2AA-4FDF-8311-7ADEDDEF3FF3}{D07A0A02-4923-46C8-8EE8-62769243087D}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dbREP_id
->>>>>>
-Attribute VB_Name = "dbREP_id"

-Public Type tREPID

-    rep_id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function GetAll_REPID_Records_by_QTR(ByRef all_REPID() As tREPID, ent_date As String) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_REPID_Records_by_QTR = dbGetAll_REPID_Records_by_QTR(dbConnection, all_REPID, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-Function Get_REPID_Record(id As Long) As tREPID

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REPID_Record = dbGet_REPID_Record(dbConnection, id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_REPID_Records(ByRef all_REPID() As tREPID) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_REPID_Records = dbGetAll_REPID_Records(dbConnection, all_REPID)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function dbGet_REPID_Record(dbConnection As Object, id As Long) As tREPID

-    

-    Dim sql As String

-    Dim objREPID As tREPID

-    

-    objREPID.FirstName = ""

-    objREPID.LastName = ""

-    objREPID.Region = 0

-    objREPID.City = 0

-    sql = "SELECT rep_id, firstname, lastname, region, city FROM " & _

-          "rep WHERE rep_id=" & id

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREPID.rep_id = dbRecordset("rep_id")

-        objREPID.FirstName = dbRecordset("firstname")

-        objREPID.LastName = dbRecordset("lastname")

-        objREPID.Region = dbRecordset("region")

-        objREPID.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REPID_Record = objREPID

-        

-End Function

-

-Function dbGetAll_REPID_Records_by_QTR(dbConnection As Object, ByRef all_REPID() As tREPID, ent_date As String) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    Dim Where As String

-    

-    REPID_Count = 0

-    Where = " WHERE lpu_budget.entry_date like '" & ent_date & "' " & _

-        "AND rep.rep_id=lpu.rep_id AND lpu.id=lpu_budget.lpu_id"

-    

-    

-    getAll_REPID_SQL = "SELECT distinct rep.* FROM rep, lpu, lpu_budget" & Where

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM (" & getAll_REPID_SQL & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records_by_QTR = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Function dbGetAll_REPID_Records(dbConnection As Object, ByRef all_REPID() As tREPID) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    REPID_Count = 0

-    

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM rep"

-    getAll_REPID_SQL = "SELECT * FROM rep"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-cdbExport
->>>>>>
-Attribute VB_Name = "cdbExport"

-Option Explicit

-

-Function GetDBSN() As String

-    Dim n As Long

-    Randomize Timer

-    n = Int((100000000 - 1000000 + 1) * Rnd + 1000000)

-    GetDBSN = Dec2ThirtySix(n)

-End Function

-

-Sub dbExport()

-    Dim src_file As String

-    Dim dst_file As String

-    

-    On Error GoTo ErrHandler

-    

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & GetLastQTR_fromDB & "_" & GetDBSN() & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Данные экспортированы в файл:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для передачи", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-Exit Sub

-

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-<<<<<<
-======================
-mRegs
->>>>>>
-Attribute VB_Name = "mRegs"

-Option Explicit

-

-Function GetRegionName(idx As Integer) As String

-    GetRegionName = Worksheets(REGS_SHEET).Range("LST_REGIONS").Cells(idx + 1, 1).Text

-End Function

-

-Function GetCityName(idx_reg As Integer, idx_city As Integer) As String

-    GetCityName = Worksheets(REGS_SHEET).Range("CITY_TABLES").Offset(idx_city + 1, idx_reg * 2).Text

-End Function

-

-Sub testReg()

-    Dim r As Integer

-    Dim c As Integer

-    Dim s As String

-    

-    r = 3

-    c = 3

-    s = GetRegionName(r)

-    s = s & ", " & GetCityName(r, c)

-    MsgBox s

-End Sub

-

-<<<<<<
-======================
-RM_QTR
->>>>>>
-Attribute VB_Name = "RM_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CRGN_QT As Integer = 0

-Const CRGN_PLN As Integer = 2

-Const CRGN_FCT As Integer = 3

-Const CRGN_BDG As Integer = 4

-Const CRGN_LPU As Integer = 5

-Const CRGN_REP As Integer = 6

-Const CRGN_HIR As Integer = 7

-Const CRGN_TER As Integer = 8

-Const CRGN_CRD As Integer = 9

-Const CRGN_CLXN_BDG As Integer = 10

-Const CRGN_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub ClearRMName()

-    Unprotect

-    Range("D4") = ""

-    Range("D5") = ""

-    Range("H4") = ""

-End Sub

-

-Sub update_history()

-    Dim objRGN() As tREGION

-    Dim i As Long

-    Dim r As Range

-    Dim cRMan As tREGMAN

-

-    cRMan = Get_REGMAN_Record

-    

-    Range("D4") = cRMan.LastName

-    Range("D5") = cRMan.FirstName

-

-    Range("H4") = GetRegionName(cRMan.Region)

-    

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetRGN_COMM_DATA(objRGN)

-    

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objRGN)

-            r.Offset(i - 1, CRGN_QT) = objRGN(i).ent_date

-            r.Offset(i - 1, CRGN_FCT) = objRGN(i).total_SALE

-            r.Offset(i - 1, CRGN_PLN) = objRGN(i).sale_PLAN

-            r.Offset(i - 1, CRGN_BDG) = objRGN(i).total_BDGT

-            r.Offset(i - 1, CRGN_LPU) = objRGN(i).total_LPU

-            r.Offset(i - 1, CRGN_REP) = objRGN(i).total_REP

-            r.Offset(i - 1, CRGN_HIR) = objRGN(i).total_HIR

-            r.Offset(i - 1, CRGN_TER) = objRGN(i).total_TER

-            r.Offset(i - 1, CRGN_CRD) = objRGN(i).total_ACS

-            If objRGN(i).total_BDGT <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_BDG) = objRGN(i).total_SALE / objRGN(i).total_BDGT

-            End If

-            If objRGN(i).total_BDGT_NMG <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_NMG) = objRGN(i).total_SALE / objRGN(i).total_BDGT_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRGN_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRM_QtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR_RM

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR_RM

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR_RM

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = RM_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect UserInterfaceOnly:=True

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CRGN_QT + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    If r = "" Then

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = currRange.address

-        With Worksheets("REP_LIST")

-            .Range("ret_addr") = "RM_QTR"

-            .Range("ent_date") = r

-            .Range("VIEW_ONLY") = True

-        End With

-    End If

-    Cancel = True

-    btRM_QTR_Do_IT

-End Sub

-

-<<<<<<
-======================
-dbREG_MAN
->>>>>>
-Attribute VB_Name = "dbREG_MAN"

-Option Explicit

-

-Public Type tREGMAN

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function Get_REGMAN_Record() As tREGMAN

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REGMAN_Record = dbGet_REGMAN_Record(dbConnection)

-    dbCloseConnection dbConnection

-End Function

-

-Sub Set_REGMAN_Record(cREGMAN As tREGMAN)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbSet_REGMAN_Record dbConnection, cREGMAN

-    dbCloseConnection dbConnection

-End Sub

-

-Sub ReSet_REGMAN_Record()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbReSet_REGMAN_Record dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_REGMAN_Record(dbConnection As Object) As tREGMAN

-    

-    Dim sql As String

-    Dim objREGMAN As tREGMAN

-    

-    objREGMAN.FirstName = ""

-    objREGMAN.LastName = ""

-    objREGMAN.Region = 0

-    objREGMAN.City = 0

-    sql = "SELECT firstname, lastname, region, city FROM " & _

-          "reg_man"

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREGMAN.FirstName = dbRecordset("firstname")

-        objREGMAN.LastName = dbRecordset("lastname")

-        objREGMAN.Region = dbRecordset("region")

-        objREGMAN.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REGMAN_Record = objREGMAN

-        

-End Function

-

-Public Sub dbSet_REGMAN_Record(dbConnection As Object, ByRef objREGMAN As tREGMAN)

-  

-    Dim DeleteSQL As String

-    Dim InsertSQL As String

-    

-    DeleteSQL = "DELETE FROM reg_man"

-    InsertSQL = "INSERT INTO reg_man (firstname, lastname, region, city) VALUES (" & _

-    "'" & objREGMAN.FirstName & "', " & _

-    "'" & objREGMAN.LastName & "', " & _

-    objREGMAN.Region & ", " & _

-    objREGMAN.City & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    dbRecordset.Open InsertSQL, dbConnection

-       

-End Sub

-

-Public Sub dbReSet_REGMAN_Record(dbConnection As Object)

-  

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM reg_man"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    

-End Sub

-

-

-<<<<<<
-======================
-dbDatabaseMerge
->>>>>>
-Attribute VB_Name = "dbDatabaseMerge"

-Option Explicit

-

-Public Type tDBFIELD

-    name As String

-End Type

-

-Public Type tDBTABLE

-    name As String

-    field() As tDBFIELD

-End Type

-

-

-Function dbGetConnection(dbAccessFileFullPath As String) As Object

-    Dim dbConnection As Object

-    Dim dbAccessFilePasswd As String

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFileFullPath & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    Set dbGetConnection = dbConnection

-End Function

-

-Sub dbCloseOpenedConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteOpenedSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-Function dbMergeREP(from_dbConnection As Object, to_dbConnection As Object) As Long

-

-    Dim getRecordset As Object

-    Dim getREPData_SQL As String

-    Dim REP_fn As String

-    Dim REP_ln As String

-    Dim REP_region As String

-    Dim REP_city As String

-

-

-    getREPData_SQL = "SELECT * FROM rep"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getREPData_SQL, from_dbConnection

-        

-        If Not getRecordset.BOF Then

-            REP_fn = getRecordset("firstname")

-            REP_ln = getRecordset("lastname")

-            REP_city = getRecordset("city")

-            REP_region = getRecordset("region")

-        Else

-            MsgBox "There is no information about rep! This database cannot be merged!!!"

-            dbMergeREP = -1

-            Exit Function

-        End If

-    

-    Dim insertRecordset As Object

-    Set insertRecordset = CreateObject("ADODB.Recordset")

-        

-    insertRecordset.Open "rep", to_dbConnection, 2, 2

-    insertRecordset.addnew

-        

-    insertRecordset("firstname") = REP_fn

-    insertRecordset("lastname") = REP_ln

-    insertRecordset("region") = REP_region

-    insertRecordset("city") = REP_city

-    insertRecordset.Update

-    insertRecordset.MoveLast

-    'new ID

-    

-    dbMergeREP = insertRecordset("rep_id")

-    

-End Function

-

-Sub dbMergeLPU(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getLPU_SQL As String

-    Dim getRecordset As Object

-    Dim idx As Long

-    idx = 1

-    

-    getLPU_SQL = "SELECT * FROM lpu"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getLPU_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            ReDim Preserve objLPU(1 To idx)

-            objLPU(idx).old_lpu_id = getRecordset("id")

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "lpu", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("name") = getRecordset("name")

-            insRS("address") = getRecordset("address")

-            insRS("beds") = getRecordset("beds")

-            insRS.Update

-            insRS.MoveLast

-            'new ID

-            

-            objLPU(idx).new_lpu_id = insRS("id")

-                        

-            idx = idx + 1

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about LPU! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-

-Sub dbMergeLPURelated(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object)

-

-    ' 6 tables to change

-    Dim tables(1 To 5) As tDBTABLE

-    

-    'lpu budget

-    tables(1).name = "lpu_budget"

-    ReDim tables(1).field(1 To 4)

-    

-    tables(1).field(1).name = "entry_date"

-    tables(1).field(2).name = "bdgt_NMG"

-    tables(1).field(3).name = "bdgt_NFG"

-    tables(1).field(4).name = "sale_PLAN"

-    

-    'lpu hir

-    tables(2).name = "lpu_hir"

-    ReDim tables(2).field(1 To 13)

-    

-    tables(2).field(1).name = "entry_date"

-    tables(2).field(2).name = "operations_per_quarter"

-    tables(2).field(3).name = "risk_percent"

-    tables(2).field(4).name = "patients_with_risk_ON"

-    tables(2).field(5).name = "patients_ambulator"

-    tables(2).field(6).name = "patients_ambulator_nmg"

-    tables(2).field(7).name = "patients_ambulator_clexan"

-    tables(2).field(8).name = "patients_ambulator_clexan_40mg"

-    tables(2).field(9).name = "patients_ambulator_clexan_20mg"

-    tables(2).field(10).name = "patients_stationar_nmg"

-    tables(2).field(11).name = "patients_stationar_clexan"

-    tables(2).field(12).name = "patients_stationar_clexan_40mg"

-    tables(2).field(13).name = "patients_stationar_clexan_20mg"

-    

-    

-    'lpu acs

-    tables(3).name = "lpu_acs"

-    ReDim tables(3).field(1 To 5)

-    

-    tables(3).field(1).name = "entry_date"

-    tables(3).field(2).name = "patients_with_geparins"

-    tables(3).field(3).name = "patients_per_quarter"

-    tables(3).field(4).name = "patients_stationar_nmg"

-    tables(3).field(5).name = "patients_stationar_clexan"

-    

-    'lpu acs

-    tables(4).name = "lpu_im"

-    ReDim tables(4).field(1 To 5)

-    

-    tables(4).field(1).name = "entry_date"

-    tables(4).field(2).name = "patients_with_geparins"

-    tables(4).field(3).name = "patients_per_quarter"

-    tables(4).field(4).name = "patients_stationar_nmg"

-    tables(4).field(5).name = "patients_stationar_clexan"

-    

-    

-    'lpu acs

-    tables(5).name = "lpu_ter"

-    ReDim tables(5).field(1 To 9)

-    

-    tables(5).field(1).name = "entry_date"

-    tables(5).field(2).name = "patients_per_quarter"

-    tables(5).field(3).name = "risk_percent"

-    tables(5).field(4).name = "patients_with_risk_ON"

-    tables(5).field(5).name = "patients_ambulator"

-    tables(5).field(6).name = "patients_ambulator_nmg"

-    tables(5).field(7).name = "patients_ambulator_clexan"

-    tables(5).field(8).name = "patients_stationar_nmg"

-    tables(5).field(9).name = "patients_stationar_clexan"

-    

-    

-    

-    Dim tbl_idx As Integer

-    

-    For tbl_idx = 1 To UBound(tables)

-        

-        Dim getSQL As String

-        Dim getRS As Object

-        

-        

-        

-        Set getRS = CreateObject("ADODB.Recordset")

-        

-        getSQL = "SELECT * FROM " & tables(tbl_idx).name

-        getRS.Open getSQL, from_db

-        

-        If Not getRS.BOF Then

-            Do While Not getRS.EOF

-                Dim insRS As Object

-                Set insRS = CreateObject("ADODB.Recordset")

-                

-                insRS.Open tables(tbl_idx).name, to_db, 2, 2

-                insRS.addnew

-                Dim fld_idx As Integer

-    

-                    For fld_idx = 1 To UBound(tables(tbl_idx).field)

-                        insRS(tables(tbl_idx).field(fld_idx).name) = getRS(tables(tbl_idx).field(fld_idx).name)

-                        insRS("lpu_id") = findNewLPU_IDByOld(objLPU, getRS("lpu_id"))

-                    Next fld_idx

-                    

-                insRS.Update

-                insRS.MoveLast

-                getRS.MoveNext

-            Loop

-        End If

-        

-        

-    Next tbl_idx

-

-End Sub

-

-Function findNewLPU_IDByOld(objLPU() As tLPUCONVERTION, old_id As Long)

-

-Dim i As Integer

-For i = 1 To UBound(objLPU)

-    If objLPU(i).old_lpu_id = old_id Then

-        findNewLPU_IDByOld = objLPU(i).new_lpu_id

-        Exit Function

-    End If

-Next i

-

-findNewLPU_IDByOld = -1

-End Function

-

-

-

-

-

-Sub dbMergeQTR(from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getQTR_SQL As String

-    Dim getRecordset As Object

-    

-    getQTR_SQL = "SELECT * FROM quarter"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getQTR_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "quarter", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("entry_date") = getRecordset("entry_date")

-            insRS("sale_plan") = getRecordset("sale_plan")

-            insRS("ClxnH20mg") = getRecordset("ClxnH20mg")

-            insRS("ClxnH40mg") = getRecordset("ClxnH40mg")

-            insRS("ClxnT40mg") = getRecordset("ClxnT40mg")

-            insRS("ClxnC_IM") = getRecordset("ClxnC_IM")

-            insRS("ClxnC_ACS") = getRecordset("ClxnC_ACS")

-            

-            

-            insRS.Update

-            

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about quarter budget! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-dbMerge
->>>>>>
-Attribute VB_Name = "dbMerge"

-Option Explicit

-

-Public Type tLPUCONVERTION

-    old_lpu_id As Long

-    new_lpu_id As Long

-End Type

-

-Sub Merge_BackUp_All_Data()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim time_stump As String

-    

-    On Error GoTo ErrHandler

-    

-    time_stump = Format(Date, "yy-mm-dd_") & Format(Time, "hh-mm")

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_BACKUPNAME & time_stump & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Старые данные сохранены в файле:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для восстановления данных в случае утери", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-    Exit Sub

-    

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-

-Sub Merge_Clear_All_Data(access_file_full_path As String)

-    

-    Dim db As Object

-    Dim tables_to_clear() As String

-    On Error GoTo ErrHandler

-    

-    ReDim tables_to_clear(1 To 8)

-    tables_to_clear(1) = "rep"

-    tables_to_clear(2) = "lpu"

-    tables_to_clear(3) = "lpu_budget"

-    tables_to_clear(4) = "lpu_hir"

-    tables_to_clear(5) = "lpu_ter"

-    tables_to_clear(6) = "lpu_acs"

-    tables_to_clear(7) = "lpu_im"

-    tables_to_clear(8) = "quarter"

-    

-    Set db = dbGetConnection(access_file_full_path)

-

-    Dim i As Integer

-    

-    For i = 1 To UBound(tables_to_clear)

-        

-        If tables_to_clear(i) <> "" Then

-            Dim Clear_SQL As String

-            Clear_SQL = "DELETE FROM " & tables_to_clear(i)

-            dbExecuteOpenedSQL db, Clear_SQL

-        Else

-            'do nothing or show message

-        End If

-    Next i

-    

-    dbCloseOpenedConnection db

-    Set db = Nothing

-    

-'    Dim Engine As Object

-'    Set Engine = CreateObject("JRO.JetEngine")

-'    Engine.CompactDatabase "Password=password;Data Source=" & access_file_full_path, _

-'    "Password=password;Data Source=c:\tmp\1.mdb"

-    

-Exit Sub

-

-ErrHandler:

-    MsgBox "something wrong: " & err.Description

-    Resume Next

-    

-End Sub

-

-Function MergeREP(from_file As String, to_file As String) As Long

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    Dim new_rep_id As Long

-

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    MergeREP = dbMergeREP(db1, db2)

-    'MsgBox "new rep ID is " & new_rep_id

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Function

-

-Sub MergeQTR(from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeQTR db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-

-Sub MergeLPU(objLPU() As tLPUCONVERTION, from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeLPU objLPU, db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-Sub MergeLPURelated(objLPU() As tLPUCONVERTION, from_file As String, to_file As String)

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    dbMergeLPURelated objLPU, db1, db2

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-

-End Sub

-

-Sub MergeGlobal(rep_files() As String, rm_file As String)

-

-    Dim i As Integer

-    'clear output file content

-    Merge_Clear_All_Data rm_file

-    

-    For i = 1 To UBound(rep_files)

-        

-        Dim rep_file As String

-        'setup input and output files

-        rep_file = rep_files(i)

-        

-        Dim new_rep_id As Long

-        ' insert REP data and get new rep_id

-        new_rep_id = MergeREP(rep_file, rm_file)

-        

-        Dim objLPU() As tLPUCONVERTION

-        'insert all LPU using new generated rep_id

-        'and populate objLPU old->new relation object

-        

-        MergeLPU objLPU, rep_file, rm_file, new_rep_id

-        'insert quarter data using new rep_id

-        MergeQTR rep_file, rm_file, new_rep_id

-        

-        

-        ' and.... insert all another data (5 tables excl version and hw)

-        'using objLPU old->new relation object

-        MergeLPURelated objLPU, rep_file, rm_file

-    

-    

-    Next i

-    

-End Sub

-

-Function GetDBList(MyPath() As String, ByRef dblist() As String) As Integer

-    Dim i As Integer

-    Dim MyName, MyMask

-    MyMask = MyPath(0) & MyPath(1) & PROGRAM_DATAEXT

-    i = 0

-    MyName = Dir(MyMask)      ' Retrieve the first entry.

-    Do While MyName <> ""    ' Start the loop.

-        ' Ignore the current directory and the encompassing directory.

-        If MyName <> "." And MyName <> ".." Then

-            ' Use bitwise comparison to make sure MyName is a directory.

-            i = i + 1

-            ReDim Preserve dblist(i)

-            dblist(i) = MyPath(0) & MyName

-        End If

-        MyName = Dir    ' Get next entry.

-    Loop

-    GetDBList = i

-End Function

-

-<<<<<<
-======================
-dlgImprtDB
->>>>>>
-Attribute VB_Name = "dlgImprtDB"

-Attribute VB_Base = "0{D5892870-2C88-40C8-A817-AC9B1CF37C2C}{9853EBEA-4E48-41F9-89C0-6F753EB6A0C2}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Private Sub btSelAll_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = True

-    Next i

-End Sub

-

-Private Sub btUnselect_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = False

-    Next i

-End Sub

-<<<<<<
-======================
-dbQTR_RM
->>>>>>
-Attribute VB_Name = "dbQTR_RM"

-Option Explicit

-

-Public Type tQTRRM

-    id As Long

-    entry_date As String

-    rm_id As Long

-    sale_PLAN As Long

-End Type

-

-

-Sub Insert_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objQTRRM.id <> 0 Then

-        dbUpdate_QTRRM_Record dbConnection, objQTRRM

-    Else

-        dbInsert_QTRRM_Record dbConnection, objQTRRM

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-Function Get_QTRRM_Record(ent_date As String) As tQTRRM

-    Dim dbConnection As Object

-    Dim allQTRRM() As tQTRRM

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    i = dbGetAll_QTRRM_Records(dbConnection, allQTRRM, ent_date)

-    If i <> 0 Then

-        Get_QTRRM_Record = allQTRRM(1)

-    End If

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTRRM_Records(ByRef all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_QTRRM_Records = dbGetAll_QTRRM_Records(dbConnection, all_QTRRM, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_QTRRM_Record dbConnection, objQTRRM

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objQTRRM.ID <> 0 then updatre else insert

-Sub dbInsert_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "quarter_rm", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objQTRRM

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("sale_plan") = .sale_PLAN

-        dbRecordset("rm_id") = .rm_id

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objQTRRM.id = dbRecordset("id")

-

-End Sub

-

-Sub dbUpdate_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim Update_SQL As String

-    

-    With objQTRRM

-        Update_SQL = "UPDATE quarter_rm SET " & _

-            "entry_date='" & .entry_date & "'" & "," & _

-            "rm_id=" & .rm_id & "," & _

-            "sale_plan=" & .sale_PLAN & "," & _

-            " WHERE id=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if ent_date = % then all_records

-Function dbGetAll_QTRRM_Records(dbConnection As Object, all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    

-    Dim getCount_QTRRM_SQL As String

-    Dim getAll_QTRRM_SQL As String

-    Dim QTRRM_Count As Long

-    QTRRM_Count = 0

-    

-    getCount_QTRRM_SQL = "SELECT COUNT(*) AS QTRRM_TOTAL FROM quarter_rm WHERE entry_date like '" & ent_date & "'"

-    getAll_QTRRM_SQL = "SELECT * FROM quarter_rm WHERE entry_date like '" & ent_date & "' ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTRRM_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTRRM_Count = dbRecordset("QTRRM_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_QTRRM_Records = QTRRM_Count

-    

-    If QTRRM_Count > 0 Then

-        'we have records

-        ReDim all_QTRRM(1 To QTRRM_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTRRM_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTRRM As tQTRRM

-                 With tmp_QTRRM

-                    .entry_date = dbRecordset("entry_date")

-                    .rm_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .id = dbRecordset("id")

-                 End With

-                 

-                 all_QTRRM(index) = tmp_QTRRM

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM quarter_rm " & _

-    "WHERE id=" & objQTRRM.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-    

-    'delete related budget entries

-    MsgBox "remember delete related"

-'    dbDelete_BDGT_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Hir_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Ter_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_ACS_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-       

-End Sub

-

-

-<<<<<<
-======================
-REP_LIST
->>>>>>
-Attribute VB_Name = "REP_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentREP_ID() As Long

-    Dim r As Range

-

-    With Worksheets("REP_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CREP_ID)

-    End With

-

-    getCurrentREP_ID = r

-End Function

-

-Public Sub REP_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Rep_Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Rep_Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Rep_Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Rep_Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectREP_LPU(rep_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim r_id As Long

-    

-    Range("JUMP") = "LPU_LIST"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-        .Range("ent_date") = ent_date

-    End With

-End Sub

-

-Public Sub SelectREP_QTR(rep_id As Long)

-    Dim vo As Boolean

-    Dim r_id As Long

-    

-    Range("JUMP") = "REP_QTR"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("REP_QTR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateREPList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim rep_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CREP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CREP_AREA).row, CREP_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    rep_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CREP_AREA).Column

-    

-    If i < 4 Then

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 1

-    Else

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 2

-    End If

-    

-    If rep_id = 0 Then

-        Range("LAST_FOCUS") = Range(CREP_AREA).address

-    End If

-

-    If rep_id = 0 Then

-        i = CREP_NAME

-        Range("JUMP") = ""

-    Else

-        btREP_LIST_DO_IT

-    End If

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateREPList()

-    Dim rcd() As tREPID_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-

-    ent_date = getEnt_date

-

-    i = Get_REP_CommonList_by_QTR(rcd, ent_date)

-

-    With ThisWorkbook.Worksheets("REP_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(rcd)

-            r.Offset(i - 1, CREP_NAME) = rcd(i).rep.FirstName & " " & rcd(i).rep.LastName

-            r.Offset(i - 1, CREP_ID) = rcd(i).rep.rep_id

-            r.Offset(i - 1, CREP_BEDS) = rcd(i).qtrs(1).c_beds

-

-            r.Offset(i - 1, CREP_NFG) = rcd(i).qtrs(1).c_bdgt_NFG

-            r.Offset(i - 1, CREP_NMG) = rcd(i).qtrs(1).c_bdgt_NMG

-

-            r.Offset(i - 1, CREP_PLAN) = rcd(i).qtrs(1).qtr.sale_PLAN

-

-            r.Offset(i - 1, CREP_HIR) = rcd(i).qtrs(1).c_pat_HIR

-            r.Offset(i - 1, CREP_TER) = rcd(i).qtrs(1).c_pat_TER

-            r.Offset(i - 1, CREP_CAR) = rcd(i).qtrs(1).c_pat_CRD

-            r.Offset(i - 1, CREP_FACT) = rcd(i).qtrs(1).c_sale_ALL

-            r.Offset(i - 1, CREP_PAT_LPU) = rcd(i).qtrs(1).c_pat_LPU

-            r.Offset(i - 1, CREP_BDGT) = rcd(i).qtrs(1).c_bdgt_LPU

-            If rcd(i).qtrs(1).c_bdgt_LPU > 0 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = rcd(i).qtrs(1).c_sale_ALL / rcd(i).qtrs(1).c_bdgt_LPU

-            End If

-            If r.Offset(i - 1, CREP_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-

-

-<<<<<<
-======================
-mREP_LIST
->>>>>>
-Attribute VB_Name = "mREP_LIST"

-Option Explicit

-

-Public Const CREP_AREA As String = "B12"

-Public Const CREP_NAME As Integer = 0

-Public Const CREP_NAME1 As Integer = 1

-Public Const CREP_NAME2 As Integer = 2

-Public Const CREP_ID As Integer = 3

-Public Const CREP_BEDS As Integer = 4

-Public Const CREP_NFG As Integer = 5

-Public Const CREP_NMG As Integer = 6

-Public Const CREP_HIR As Integer = 7

-Public Const CREP_TER As Integer = 8

-Public Const CREP_CAR As Integer = 9

-Public Const CREP_FACT As Integer = 10

-Public Const CREP_PLAN As Integer = 11

-Public Const CREP_PAT_LPU As Integer = 16

-Public Const CREP_BDGT As Integer = 17

-Public Const CREP_PAT_ALL As Integer = 16

-

-

-

-Sub EditREP(cRep As tREPID, ent_date As String)

-    NoFunc

-End Sub

-

-Sub Rep_Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btREP_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = "RM_QTR"

-    End With

-    ThisWorkbook.Worksheets("RM_QTR").Activate

-End Sub

-

-

-Sub btREP_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim rep_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("REP_LST_DETALS")

-    With Worksheets("REP_LIST")

-        rep_id = .getCurrentREP_ID

-        

-        Select Case i

-            Case 1:

-                .SelectREP_QTR rep_id

-            Case 2:

-                ent_date = .getEnt_date()

-                .SelectREP_LPU rep_id, ent_date

-        End Select

-    End With

-    

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-

-

-

-<<<<<<
-======================
-cdbREP
->>>>>>
-Attribute VB_Name = "cdbREP"

-Option Explicit

-

-Public Type tREPID_COMMON

-    rep As tREPID

-    i_qtrs As Integer

-    qtrs() As tQTR_COMMON

-End Type

-

-Function Get_REP_CommonList_by_QTR(ByRef rcd() As tREPID_COMMON, ent_date As String) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_REP_CommonList_by_QTR = dbGet_REP_CommonList_by_QTR(dbConnection, rcd, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_REP_CommonList_by_QTR(dbConnection As Object, ByRef rcd() As tREPID_COMMON, ent_date As String) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim k As Long

-    Dim allREPID() As tREPID

-    

-    i = dbGetAll_REPID_Records_by_QTR(dbConnection, allREPID, ent_date)

-    dbGet_REP_CommonList_by_QTR = i

-    If i > 0 Then

-        ReDim rcd(i)

-        For i = 1 To UBound(allREPID)

-            rcd(i).rep = allREPID(i)

-            rcd(i).i_qtrs = Get_QTR_CommonList_by_REP(rcd(i).qtrs, ent_date, allREPID(i).rep_id)

-        Next i

-    End If

-End Function

-

-

-

-<<<<<<
-======================
-CHRT_PAT_LPU_A
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU_A"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-cdbRegion
->>>>>>
-Attribute VB_Name = "cdbRegion"

-Option Explicit

-

-Type tREGION

-    ent_date As String

-    total_SALE As Long ' общий объем продаж

-    total_BDGT As Long ' бюджет всех ЛПУ

-    total_BDGT_NMG As Long ' бюджет всех ЛПУ на НМГ

-    total_LPU As Long ' число ЛПУ

-    total_REP   As Long ' число репов

-    total_BEDS As Long ' общее число коек

-    total_HIR As Long '  общее число пациентов на клексане в хирургии

-    total_TER As Long '  общее число пациентов на клексане в терапии

-    total_ACS As Long '  общее число пациентов на клексане в кардиологии

-    sale_PLAN As Long '  план продаж Авентиса

-End Type

-

-Function GetRGN_COMM_DATA(ByRef reg_data() As tREGION) As Integer

-    Dim q_date() As String

-    Dim q_count As Integer, i As Integer

-    

-    q_count = getAllQTRNames(q_date)

-    If q_count > 0 Then

-        ReDim reg_data(q_count)

-        For i = 1 To q_count

-            Dim current_rep_count As Integer

-            current_rep_count = getREGION_by_QTR(q_date(i), reg_data(i))

-        Next i

-    End If

-    

-    GetRGN_COMM_DATA = q_count

-End Function

-

-Function getAllQTRNames(ByRef qtr_lst() As String) As Integer

-    

-    Dim sql As String

-    Dim i As Integer

-    Dim db As Object, rs As Object

-    

-    

-    sql = "SELECT DISTINCT entry_date FROM lpu_budget"

-    i = 0

-    

-    dbOpenConnection db

-    Set rs = CreateObject("ADODB.Recordset")

-    

-    rs.Open sql, db

-        

-        If Not rs.BOF Then

-            Do While Not rs.EOF

-                i = i + 1

-                ReDim Preserve qtr_lst(i)

-                qtr_lst(i) = rs("entry_date")

-                rs.MoveNext

-            Loop

-        Else

-            getAllQTRNames = 0

-            Exit Function

-        End If

-    getAllQTRNames = i

-    dbCloseConnection db

-End Function

-

-Function getREGION_by_QTR(ent_date As String, treg As tREGION) As Integer

-    Dim rep_count As Integer

-    rep_count = 0

-    

-    Dim reps() As tREPID_COMMON

-    rep_count = Get_REP_CommonList_by_QTR(reps, ent_date)

-    

-    treg.ent_date = ent_date

-    treg.total_BDGT = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.total_BDGT_NMG = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.sale_PLAN = 0 ' quarter.sale_plan

-    treg.total_SALE = 0 'summ of

-    ' hir = (amb40+st40)*pr40 + (amb20+st20)*pr20

-    'ter (amb_clx+stat_clx)*price

-    ' acs xxx

-    'price per rep

-    treg.total_HIR = 0 'patiens clxn

-    treg.total_TER = 0 'patiens clxn

-    treg.total_ACS = 0 'patiens clxn

-    treg.total_LPU = 0 'lpu

-    treg.total_BEDS = 0 'lpu.beds

-    treg.total_REP = 0 '

-    

-    If rep_count > 0 Then

-        Dim i As Integer

-        

-        For i = 1 To UBound(reps)

-            ' current rep is reps(i)

-            With reps(i)

-                treg.total_BDGT = treg.total_BDGT + .qtrs(1).c_bdgt_NFG + .qtrs(1).c_bdgt_NMG

-                treg.total_BDGT_NMG = treg.total_BDGT_NMG + .qtrs(1).c_bdgt_NMG

-                treg.sale_PLAN = treg.sale_PLAN + .qtrs(1).c_sale_PLAN

-                treg.total_SALE = treg.total_SALE + .qtrs(1).c_sale_ALL

-                treg.total_HIR = treg.total_HIR + .qtrs(1).c_pat_HIR

-                treg.total_TER = treg.total_TER + .qtrs(1).c_pat_TER

-                treg.total_ACS = treg.total_ACS + .qtrs(1).c_pat_CRD

-                treg.total_LPU = treg.total_LPU + .qtrs(1).i_lcd

-                treg.total_BEDS = treg.total_BEDS + .qtrs(1).c_beds

-                treg.total_REP = treg.total_REP + 1

-            End With

-            

-        Next i

-        

-    End If

-    

-    getREGION_by_QTR = treg.total_REP

-End Function

-

-<<<<<<
-======================
-mRM_QTR
->>>>>>
-Attribute VB_Name = "mRM_QTR"

-Option Explicit

-

-Sub btRM_QTR_Do_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    

-    idx = Worksheets(VAR_SHEET).Range("RM_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            ImportData

-        Case 2

-            Worksheets("REP_LIST").Select

-        Case 3

-            cmExport

-    End Select

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-End Sub

-

-Sub ImportData()

-    Dim i As Integer

-    Dim def_dir As String

-    Dim flist() As String

-    

-    def_dir = GetWBPath(ThisWorkbook.FullName)

-    If GetImportDirectory(def_dir, flist) Then

-        Dim ImpMask() As String

-        ImpMask = Split(flist(1), Chr(95), Compare:=vbBinaryCompare)

-        flist(1) = ImpMask(0) & "*"

-        Dim db_list() As String

-        i = GetDBList(flist(), db_list)

-        If i > 0 Then

-            Merge_BackUp_All_Data

-            MergeGlobal db_list, GetWBPath(ThisWorkbook.FullName) & "clexane-rm.mdb"

-        End If

-    End If

-    Worksheets(RM_QTR_SHEET).update_history

-End Sub

-<<<<<<
-======================
-mImport
->>>>>>
-Attribute VB_Name = "mImport"

-    Option Explicit

-

-Const OFN_ALLOWMULTISELECT As Long = 512

-Const OFN_EXPLORER As Long = 524288

-Const OFN_HIDEREADONLY As Long = 4

-Const OFN_NONETWORKBUTTON As Long = 131072

-Const OFN_READONLY As Long = 1

-       

-Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _

-    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

-

-Private Type OPENFILENAME

-    lStructSize As Long

-    hWndOwner As Long

-    hInstance As Long

-    lpstrFilter As String

-    lpstrCustomFilter As String

-    nMaxCustFilter As Long

-    nFilterIndex As Long

-    lpstrFile As String

-    nMaxFile As Long

-    lpstrFileTitle As String

-    nMaxFileTitle As Long

-    lpstrInitialDir As String

-    lpstrTitle As String

-    flags As Long

-    nFileOffset As Integer

-    nFileExtension As Integer

-    lpstrDefExt As String

-    lCustData As Long

-    lpfnHook As Long

-    lpTemplateName As String

-End Type

-

-Function GetImportDirectory(DB_dir As String, flist() As String) As Boolean

-    Dim OpenFile As OPENFILENAME

-    Dim lReturn As Long

-    Dim sFilter As String

-    

-    OpenFile.lStructSize = Len(OpenFile)

-    '         OpenFile.hwndOwner = Form1.hWnd

-    '         OpenFile.hInstance = App.hInstance

-    sFilter = "Clexane Data Files" & Chr(0) & "mr*.mdb" & Chr(0)

-    OpenFile.lpstrFilter = sFilter

-    OpenFile.nFilterIndex = 1

-    OpenFile.lpstrFile = String(257, 0)

-    OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1

-    OpenFile.lpstrFileTitle = OpenFile.lpstrFile

-    OpenFile.nMaxFileTitle = OpenFile.nMaxFile

-    OpenFile.lpstrInitialDir = DB_dir

-    OpenFile.lpstrTitle = "Импорт данных"

-    OpenFile.flags = OFN_HIDEREADONLY + OFN_EXPLORER

-    lReturn = GetOpenFileName(OpenFile)

-    If lReturn = 0 Then

-        GetImportDirectory = False

-    Else

-        GetImportDirectory = True

-        flist = Split(OpenFile.lpstrFile, Chr(0), Compare:=vbBinaryCompare)

-        Dim i As Integer

-        i = 0

-        Do While flist(i) <> ""

-            i = i + 1

-        Loop

-        If i = 1 Then

-            flist(1) = flist(0)

-            flist(0) = GetWBPath(flist(1))

-            flist(1) = GetWBName(flist(1))

-        Else

-            flist(0) = flist(0) & "\"

-        End If

-    End If

-End Function

-<<<<<<
-Project Name : 'ClexanePM'
-Quirk - duff tag length======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-

-    Application.EnableEvents = True

-    Set MyAppEvents.app = Application

-    

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    

-    MyAppEvents.CheckWorkBooksArround ThisWorkbook

-    

-    cmSetStandaloneMode

-    

-    Application.ScreenUpdating = True

-'    CheckUser

-

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).Select

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).update_history

-    Application.Calculate

-

-End Sub

-

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    

-    Dim RestMode As Boolean

-    RestMode = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE")

-    

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-'        If RestMode Then

-            ThisWorkbook.Saved = True

-'        Else

-'            ThisWorkbook.Save

-'        End If

-    End If

-    If RestMode Then

-        xlRestoreView

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    End If

-    Application.Caption = Empty

-    Application.CommandBars(STDBAR_NAME).Reset

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-    Dim MaxX, MaxY As Integer

-    With ThisWorkbook.Worksheets(TITLE_SHEET)

-        MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-        MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-    End With

-

-    With ThisWorkbook.Application

-        .ScreenUpdating = False

-        .WindowState = xlNormal

-        .Height = MaxY

-        .Width = MaxX

-    End With

-End Sub

-

-

-

-

-

-<<<<<<
-======================
-REP_QTR
->>>>>>
-Attribute VB_Name = "REP_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CQTR_QT As Integer = 0

-Const CQTR_ID As Integer = 1

-Const CQTR_PLN As Integer = 2

-Const CQTR_FCT As Integer = 3

-Const CQTR_BDG As Integer = 4

-Const CQTR_CNT As Integer = 5

-Const CQTR_BEDS As Integer = 6

-Const CQTR_HIR As Integer = 7

-Const CQTR_TER As Integer = 8

-Const CQTR_CRD As Integer = 9

-Const CQTR_CLXN_BDG As Integer = 10

-Const CQTR_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Const LOCAL_ENT_DATE As String = "QTR_SEL"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("REP_QTR")

-        s = .Range("D5") & " " & .Range("D4") & ", " & .Range("H5") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub update_history()

-    Dim objQTR() As tQTR

-    Dim i As Long

-    Dim r As Range

-    Dim cRep As tREPID

-    Dim rm_id As Long

-

-    rm_id = Range("RM_ID")

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    Range("D4") = cRep.LastName

-    Range("D5") = cRep.FirstName

-

-    Range("H4") = GetRegionName(cRep.Region)

-    Range("H5") = GetCityName(cRep.Region, cRep.City)

-

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetAll_QTR_Records_by_REP(objQTR, "%", cRep.rep_id, rm_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CQTR_QT) = objQTR(i).entry_date

-        Next i

-    End If

-    Dim qcd() As tQTR_COMMON

-    i = Get_QTR_CommonList_by_REP(qcd, "%", cRep.rep_id, rm_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(qcd)

-            r.Offset(i - 1, CQTR_QT) = qcd(i).qtr.entry_date

-            r.Offset(i - 1, CQTR_ID) = qcd(i).qtr.id

-            r.Offset(i - 1, CQTR_PLN) = qcd(i).qtr.sale_PLAN

-            r.Offset(i - 1, CQTR_FCT) = qcd(i).c_sale_ALL

-            r.Offset(i - 1, CQTR_BDG) = qcd(i).c_bdgt_LPU

-            r.Offset(i - 1, CQTR_CNT) = qcd(i).i_lcd

-            r.Offset(i - 1, CQTR_BEDS) = qcd(i).c_beds

-            r.Offset(i - 1, CQTR_HIR) = qcd(i).c_pat_HIR

-            r.Offset(i - 1, CQTR_TER) = qcd(i).c_pat_TER

-            r.Offset(i - 1, CQTR_CRD) = qcd(i).c_pat_CRD

-            If qcd(i).c_bdgt_LPU <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_BDG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_LPU

-            End If

-            If qcd(i).c_bdgt_NMG <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_NMG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CQTR_CRD + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-

-Sub Draw_PLN_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_FCT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PLN_QTR").Range("title") = MakeChartTitle

-End Sub

-

-Sub Draw_BDGT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_CLXN_NMG + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_BDGT_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Public Sub cbxRepQtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CQTR_ID + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    i = currRange.Column - Range(CINP_AREA).Column

-

-    QTR_ID = r

-

-    If QTR_ID = 0 Then

-        Worksheets(VAR_SHEET).Range("USER_ACTION") = 1

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        If i > CQTR_FCT Then

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-            Range("LAST_FOCUS") = currRange.address

-        Else

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 3

-            Range("LAST_FOCUS") = currRange.address

-        End If

-    End If

-    Cancel = True

-    btHomeDo_IT

-End Sub

-

-<<<<<<
-======================
-mRep_QTR
->>>>>>
-Attribute VB_Name = "mRep_QTR"

-Option Explicit

-

-Sub NoFunc()

-    MsgBox "Функция не доступна", vbOKOnly, PROGRAM_NAME

-End Sub

-

-Sub DO_Price_qtr(ent_date As String)

-    Dim qtr As tQTR

-    Dim res As Integer

-    Dim cRep As tREPID

-    Dim rm_id As Long

-

-    rm_id = Worksheets(REP_QTR_SHEET).Range("RM_ID")

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    qtr = Get_QTR_Record_by_REP(ent_date, cRep.rep_id, cRep.rm_id)

-

-    If qtr.id = 0 Then

-        qtr.entry_date = ent_date

-

-        With Worksheets(VAR_SHEET)

-            qtr.ClxnH20mg = .Range("ClxnH20mg")

-            qtr.ClxnH40mg = .Range("ClxnH40mg")

-            qtr.ClxnT40mg = .Range("ClxnT40mg")

-            qtr.ClxnC_ACS = .Range("ClxnC_ACS")

-            qtr.ClxnC_IM = .Range("ClxnC_IM")

-        End With

-    End If

-

-    Dim dlg_nq As dlg_nextQTR

-    Set dlg_nq = New dlg_nextQTR

-

-    With dlg_nq

-        .tb_qtr_name = qtr.entry_date

-        .tb_bdgt_avts = qtr.sale_PLAN

-        .tb_qtr_name = qtr.entry_date

-        .tb_ClxnH20mg = qtr.ClxnH20mg

-        .tb_ClxnH40mg = qtr.ClxnH40mg

-        .tb_ClxnT40mg = qtr.ClxnT40mg

-        .tb_ClxnC_ACS = qtr.ClxnC_ACS

-        .tb_ClxnC_IM = qtr.ClxnC_IM

-    End With

-

-    dlg_nq.Show

-End Sub

-

-Sub DO_Edit_qtr(ent_date As String)

-    If ent_date = "" Then

-        NoFunc

-    Else

-        Dim rep_id As Long

-        rep_id = Worksheets(REP_QTR_SHEET).Range("REP_ID")

-        With ThisWorkbook.Worksheets("LPU_LIST")

-            .Range("VIEW_ONLY") = True

-            .setEnt_date (ent_date)

-            .Range("REP_ID") = rep_id

-            .Select

-        End With

-    End If

-End Sub

-

-Sub DO_Delete_qtr(ent_date As String)

-    If ent_date <> "" Then

-        MsgBox "Удалить данные за период [" & ent_date & "] нельзя ", vbOKOnly, PROGRAM_NAME

-    End If

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-

-Sub btHomeDo_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    idx = Worksheets(VAR_SHEET).Range("USER_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).getEnt_date()

-    Select Case idx

-        Case 1

-            NoFunc

-            ' Обновляем экран

-        Case 2

-            DO_Edit_qtr ent_date

-        Case 3

-            DO_Price_qtr ent_date

-        Case 4

-            NoFunc

-    End Select

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-Sub Delete_qtr()

-'    Dim ent_date As String

-'    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-'    DO_Delete_qtr ent_date

-End Sub

-

-Sub btREP_QTR_RET_IT()

-    Dim s As String

-    With Worksheets("REP_QTR")

-        .Range("LAST_FOCUS") = ""

-        s = .Range("ret_addr")

-        .Range("ret_addr") = ""

-    End With

-    If s <> "" Then

-        ThisWorkbook.Worksheets(s).Select

-    Else

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public ppReport As New cPPReport

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane[PM]"

-Public Const PROGRAM_VERSION As String = "Clexane[PM] ver 1.1"

-Public Const PROGRAM_FILENAME As String = "clexane-pm"

-Public Const PROGRAM_BACKUPNAME As String = "pm-backup-"

-Public Const PROGRAM_EXPORTNAME As String = "pm-ex-"

-Public Const PROGRAM_IMPORTNAME As String = "rm-ex*"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-Public Const CHART_DEF_TITLE As String = "* * *"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20031207

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "O41"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-Public Const RM_QTR_SHEET As String = "RM_QTR"

-Public Const PRJ_QTR_SHEET As String = "PRJ_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-Function time_correct(end_date As Long, ByVal theDate As Date) As Boolean

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-    If end_date = NO_ESTIMATION_DATE Then

-        time_correct = True

-        Exit Function

-    End If

-    

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    

-    time_correct = CurDate <= end_date

-    

-End Function

-

-Sub EnableRun(end_date As Long)

-    If Not time_correct(end_date, Now) Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-Sub t()

-    EnableRun ESTIMATION_DATE

-End Sub

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Sub OpenPPT()

-    ppReport.ReportView

-End Sub

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-

-End Sub

-

-Function Double2Str(ByVal d As Double, ByVal precision As Integer, Optional Delim As String = ".") As String

-    Dim s As String

-    If Not precision > 0 Then

-        s = Round(d)

-    Else

-        Dim i As Integer

-        i = Fix(d)

-        s = i & Delim

-        d = Abs(d - i)

-        Do

-            precision = precision - 1

-            d = d * 10

-            If precision > 0 Then

-                i = Fix(d)

-            Else

-                i = Round(d)

-            End If

-            If i < 1 Then

-                s = s & "0"

-            Else

-                s = s & i

-                d = d - i

-            End If

-        Loop While precision > 0

-    End If

-    Double2Str = s

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetWBName(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBName = Right(FullName, s_len - pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.Name = VAR_SHEET Or sh.Name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-<<<<<<
-======================
-Var
->>>>>>
-Attribute VB_Name = "Var"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-title
->>>>>>
-Attribute VB_Name = "title"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LPU_LIST
->>>>>>
-Attribute VB_Name = "LPU_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Const LOCAL_ENT_DATE As String = "C10"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Function getCurrentLPU_ID() As Long

-    Dim r As Range

-

-    With Worksheets("LPU_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CLPU_ID)

-    End With

-

-    getCurrentLPU_ID = r

-End Function

-

-Public Sub LPU_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectLPU_NAME(lpu_id As Long, ent_date As String)

-    SelectLPU_BDGT lpu_id, ent_date

-End Sub

-

-Sub SelectLPU_BDGT(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    If lpu_id = 0 Then

-        SelectLPU_NAME lpu_id, ent_date

-    Else

-        With ThisWorkbook.Worksheets("LPU_BDGT")

-            .Range("VIEW_ONLY") = vo

-            .Range("ret_addr") = "LPU_LIST"

-            .setEnt_date (ent_date)

-            .Range("lpu_id") = lpu_id

-            .Range("REP_ID") = rep_id

-            .Range("RM_ID") = rm_id

-        End With

-    End If

-End Sub

-

-Sub SelectLPU_HIR(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_HIR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .setEnt_date (ent_date)

-        .Range("lpu_id") = lpu_id

-        .Range("REP_ID") = rep_id

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Sub SelectLPU_TER(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_TER")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .setEnt_date (ent_date)

-        .Range("lpu_id") = lpu_id

-        .Range("REP_ID") = rep_id

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Sub SelectLPU_C_ACS(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_C_ACS")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .setEnt_date (ent_date)

-        .Range("RM_ID") = rm_id

-        .Range("REP_ID") = rep_id

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateLPUList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim lpu_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CINP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CINP_AREA).row, CLPU_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    lpu_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CINP_AREA).Column

-

-    If lpu_id = 0 Then

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    End If

-

-    If lpu_id = 0 Then

-        i = CLPU_NAME

-        Range("JUMP") = ""

-    End If

-    Select Case i

-        Case CLPU_NAME, CLPU_NAME1, CLPU_NAME2, CLPU_BEDS

-            SelectLPU_NAME lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-

-        Case CLPU_NMG, CLPU_NFG, CLPU_PLAN, CLPU_FACT

-            SelectLPU_BDGT lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-

-        Case CLPU_HIR

-            SelectLPU_HIR lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_HIR"

-

-        Case CLPU_TER

-            SelectLPU_TER lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_TER"

-

-        Case CLPU_CAR

-            SelectLPU_C_ACS lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        Case Else

-            Range("JUMP") = ""

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateLPUList()

-    Dim lcd() As tLPU_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-    Dim objQTR As tQTR

-    Dim cRep As tREPID

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    ent_date = getEnt_date

-

-'     ent_date = "%" ' % - all records

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id, cRep.rm_id)

-    i = Get_LPU_CommonQTR(lcd, objQTR)

-

-'     стираем ФИО

-    Range("C3:C4").ClearContents

-

-    Range("C3") = cRep.LastName

-    Range("C4") = cRep.FirstName

-    Range("G3") = GetRegionName(cRep.Region)

-    Range("G4") = GetCityName(cRep.Region, cRep.City)

-    Range("G5") = objQTR.sale_PLAN

-

-

-

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(lcd)

-            r.Offset(i - 1, CLPU_NAME) = lcd(i).lpu.Name

-            r.Offset(i - 1, CLPU_ID) = lcd(i).lpu.id

-            r.Offset(i - 1, CLPU_BEDS) = lcd(i).lpu.beds

-

-

-            r.Offset(i - 1, CLPU_NFG) = lcd(i).bdgt.bdgt_NFG

-            r.Offset(i - 1, CLPU_NMG) = lcd(i).bdgt.bdgt_NMG

-            r.Offset(i - 1, CLPU_PLAN) = lcd(i).bdgt.sale_PLAN

-

-            r.Offset(i - 1, CLPU_HIR) = lcd(i).pat_HIR

-            r.Offset(i - 1, CLPU_TER) = lcd(i).pat_TER

-            r.Offset(i - 1, CLPU_CAR) = lcd(i).pat_CRD

-            r.Offset(i - 1, CLPU_FACT) = lcd(i).sale_ALL

-            r.Offset(i - 1, CLPU_PAT_LPU) = lcd(i).pat_LPU

-            r.Offset(i - 1, CLPU_BDGT) = lcd(i).bdgt_LPU

-            If lcd(i).bdgt_LPU > 0 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = lcd(i).sale_ALL / lcd(i).bdgt_LPU

-            End If

-            If r.Offset(i - 1, CLPU_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{32FB0F3D-6884-41DC-99DB-E2C55B2257C4}{DED79A66-DA60-4CCC-9003-082480235D55}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-dbACS
->>>>>>
-Attribute VB_Name = "dbACS"

-Option Explicit

-

-Public Type tACS

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    patients_with_geparins As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objACS.ID <> 0 then updatre else insert

-Sub Insert_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objACS.id <> 0 Then

-        dbUpdate_ACS_Record dbConnection, objACS

-    Else

-        dbInsert_ACS_Record dbConnection, objACS

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_ACS_RecordsByLPU_ID(ByRef all_ACS_() As tACS, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_ACS_RecordsByLPU_ID = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, all_ACS_, lpu_id, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_ACS_Record dbConnection, objACS

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub dbInsert_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_acs", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objACS

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("patients_with_geparins") = .patients_with_geparins

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objACS.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim Update_SQL As String

-    

-    With objACS

-        Update_SQL = "UPDATE lpu_acs SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "patients_with_geparins=" & .patients_with_geparins & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_ACS_RecordsbyLPU_ID(dbConnection As Object, all_ACS() As tACS, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_ACS_SQL As String

-    Dim getAll_ACS_SQL As String

-    Dim ACS_Count As Long

-    ACS_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    Else

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_ACS_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        ACS_Count = dbRecordset("ACS_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_ACS_RecordsbyLPU_ID = ACS_Count

-    

-    If ACS_Count > 0 Then

-        'we have records

-        ReDim all_ACS(1 To ACS_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_ACS_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_ACS As tACS

-                 With tmp_ACS

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .patients_with_geparins = dbRecordset("patients_with_geparins")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 all_ACS(index) = tmp_ACS

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE ID=" & objACS.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_ACS_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_HIR
->>>>>>
-Attribute VB_Name = "LPU_CLSN_HIR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const LOCAL_ENT_DATE As String = "S38"

-

-Sub PrintCopy()

-    Range("A1:M26").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-

-        Dim objHir As tHIRURGIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objHir

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .operations_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L9")

-                .patients_ambulator_clexan_20mg = Range("L10")

-                .patients_ambulator_clexan_40mg = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L19")

-                .patients_stationar_clexan_20mg = Range("L20")

-                .patients_stationar_clexan_40mg = Range("L21")

-            End With

-            Insert_Hir_Record objHir

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objHir.id = Range("rec_id")

-                    If objHir.id <> 0 Then

-                        Delete_Hir_Record objHir

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-End Sub

-

-Sub SetupData(objHir As tHIRURGIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    With objHir

-        Range("rec_id") = .id

-        Range("F6") = .operations_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L9") = .patients_ambulator_clexan

-        Range("L10") = .patients_ambulator_clexan_20mg

-        Range("I21") = .patients_stationar_nmg

-        Range("L19") = .patients_stationar_clexan

-        Range("L20") = .patients_stationar_clexan_20mg

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id, cRep.rm_id)

-

-        formula = "=" & qtr.ClxnH20mg & "*($L$10+$L$20)+" & qtr.ClxnH40mg & "*($L$11+$L$21)"

-        Range("F11").formula = formula

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id, Range("RM_ID"))

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.Name

-        Range("lpu_addr") = lpu.address

-

-        Dim objHir() As tHIRURGIA

-        Dim i As Integer

-        i = GetAll_Hir_RecordsByLPU_ID(objHir, id, Range("ent_date"), Range("RM_ID"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.3

-        Else

-            SetupData objHir(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-mSapes
->>>>>>
-Attribute VB_Name = "mSapes"

-Option Explicit

-

-Const SHAPE_COLOR As Integer = 1

-Const SHAPE_NAME As Integer = 2

-

-

-Sub ShapeView(r_sh_finite_state As Range)

-    Dim chk As Range

-    Dim s As String

-    Dim c, idx As Integer

-    For Each chk In r_sh_finite_state

-        idx = 0

-        If chk = "+" Then

-            c = chk.Offset(0, idx + SHAPE_COLOR)

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While c <> 0

-                ShapeFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s)), c

-                idx = idx + 2

-                c = chk.Offset(0, idx + SHAPE_COLOR)

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        Else

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While s <> ""

-                ShapeUnFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s))

-                idx = idx + 2

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        End If

-    Next chk

-End Sub

-

-Sub ShapeFill(sh As ShapeRange, ByVal color As Integer)

-    sh.Fill.Visible = msoTrue

-    sh.Fill.Solid

-    sh.Fill.ForeColor.SchemeColor = color

-    sh.Fill.Transparency = 0#

-End Sub

-

-Sub ShapeUnFill(sh As ShapeRange)

-    sh.Fill.Visible = msoFalse

-    sh.Fill.Transparency = 0#

-End Sub

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Public Const INPUT_NO = 0

-Public Const INPUT_NUMBER = 1

-Public Const INPUT_PERCENT = 2

-Public Const INPUT_STRING = 3

-Public Const INPUT_CHECK = 4

-

-Public Const INP_IDX_TYPE = 1

-Public Const INP_IDX_NEXT = 2

-Public Const INP_IDX_MIN = 3

-Public Const INP_IDX_MAX = 4

-Public Const INP_IDX_DEP = 5

-Public Const INP_IDX_ALT = 7

-

-

-Public Type tInputSet

-    vType As Integer

-    vMin As Long

-    vMax As Long

-    rChk As String

-End Type

-

-Function is_input_cell(ByVal Target As Range, inputs As Range) As tInputSet

-    Dim t As Range

-    Dim iset As tInputSet

-    Dim test As Range

-    iset.vType = INPUT_NO

-    iset.vMin = 0

-    iset.vMax = 0

-    iset.rChk = ""

-    is_input_cell = iset

-

-' Закоментировать следующую сточку для работы

-'  Exit Function

-

-    Set test = Target.Cells(1, 1)

-    For Each t In inputs

-        If Range(t).Column = test.Column And Range(t).row = test.row Then

-            iset.vType = t.Offset(0, INP_IDX_TYPE).Value

-            Select Case iset.vType

-                Case INPUT_CHECK

-                    iset.rChk = t.Offset(0, INP_IDX_ALT)

-                Case INPUT_NUMBER, INPUT_PERCENT

-                    iset.vMin = t.Offset(0, INP_IDX_MIN).Value

-                    iset.vMax = t.Offset(0, INP_IDX_MAX).Value

-            End Select

-            is_input_cell = iset

-            Exit Function

-        End If

-    Next t

-End Function

-

-Function GetFocusAddress(ByVal r As Range, f_next As Range) As String

-    Dim chk, t As Range

-    

-    For Each chk In f_next

-        For Each t In r

-            If t.address = chk Then

-                GetFocusAddress = chk

-                Exit Function

-            End If

-            If Range(chk).Column = t.Column - 1 And Range(chk).row = t.row _

-            Or Range(chk).Column = t.Column And Range(chk).row = t.row - 1 _

-            Then

-                If Range(chk) <> "" Then

-                    If Range(chk) = 0 Then

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_ALT)).address

-                    Else

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_NEXT)).address

-                    End If

-                Else

-                    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-                End If

-                Exit Function

-            End If

-        Next t

-    Next chk

-    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-End Function

-

-Sub SetDependet(r As Range, inputs As Range)

-    Dim chk As Range

-    Dim s, serr As String

-    Dim idx As Integer

-    Dim iset As tInputSet

-    Dim err_found As Boolean

-    

-    If r.count > 1 Then

-        Exit Sub

-    End If

-    

-    err_found = False

-    For Each chk In inputs

-        idx = INP_IDX_DEP

-        

-        

-        iset.vType = chk.Offset(0, INP_IDX_TYPE).Value

-        Select Case iset.vType

-            Case INPUT_NUMBER, INPUT_PERCENT

-                iset.vMin = chk.Offset(0, INP_IDX_MIN).Value

-                iset.vMax = chk.Offset(0, INP_IDX_MAX).Value

-                

-                If Range(chk) > iset.vMax Then

-                    err_found = True

-                    Range(chk) = iset.vMax

-                    serr = "Выход за дозволенный диапазон [" & iset.vMin & ".." & iset.vMax & "]! Данные скорректированы."

-                End If

-                

-                If Range(chk) = "" Then

-                    s = chk.Offset(0, idx)

-                    Do While s <> ""

-                        Range(s) = ""

-                        idx = idx + 1

-                        s = chk.Offset(0, idx)

-                    Loop

-                End If

-        End Select

-    Next chk

-    If err_found Then

-        MsgBox serr, vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Function CheckInputData(inputs As Range) As Boolean

-    Dim r As Range

-    

-    CheckInputData = True

-    For Each r In inputs

-        If Range(r) = "" Then

-            CheckInputData = False

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100.", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Sub Check_Int_Number(Target As Range, Def_Val As Long)

-    Dim err As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    err = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                err = True

-            End If

-        End If

-    Next r

-    If err Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_TER
->>>>>>
-Attribute VB_Name = "LPU_CLSN_TER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const LOCAL_ENT_DATE As String = "S38"

-

-Sub PrintCopy()

-    Range("A1:M26").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim objTer As tTERAPIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objTer

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .patients_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L20")

-            End With

-            Insert_Ter_Record objTer

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objTer.id = Range("rec_id")

-                    If objTer.id <> 0 Then

-                        Delete_Ter_Record objTer

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-

-End Sub

-

-Sub SetupData(objTer As tTERAPIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    With objTer

-        Range("rec_id") = .id

-        Range("F6") = .patients_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L11") = .patients_ambulator_clexan

-        Range("I21") = .patients_stationar_nmg

-        Range("L20") = .patients_stationar_clexan

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id, cRep.rm_id)

-        formula = "=" & qtr.ClxnT40mg & "*($L$12+$L$20)"

-        Range("F11").formula = formula

-

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id, Range("RM_ID"))

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.Name

-        Range("lpu_addr") = lpu.address

-

-        Dim objTer() As tTERAPIA

-        Dim i As Integer

-        i = GetAll_Ter_RecordsByLPU_ID(objTer, id, Range("ent_date"), Range("RM_ID"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.25

-        Else

-            SetupData objTer(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{0DC9E035-CE0A-49FF-85A2-A4EC5FF8FE96}{D54DDC8A-1EE2-4BB3-8B94-343B521AF098}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-LPU_BDGT
->>>>>>
-Attribute VB_Name = "LPU_BDGT"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const LOCAL_ENT_DATE As String = "S15"

-

-Sub PrintCopy()

-    Range("B1:K21").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Sub SetDefFocus()

-    Range(Range("DEF_FOCUS")).Select

-End Sub

-

-Public Sub ClearData()

-    ClearSheetData

-End Sub

-

-Sub ClearSheetData()

-    If Range("F10") = 0 And Range("F13") = 0 Then

-        Range("F11:F18") = ""

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("F11:F13") = ""

-    End If

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim bdgt As tBUDGET

-        Dim sum As Long

-        Dim test As Boolean

-        With bdgt

-            .lpu_id = Range("lpu_id")

-            .id = Range("rec_id")

-            .entry_date = Range("ent_date")

-            .bdgt_NMG = Round(Range("F11").Value, 0)

-            .bdgt_NFG = Round(Range("F12").Value, 0)

-            .sale_PLAN = Round(Range("F13").Value, 0)

-

-            sum = .bdgt_NFG + .bdgt_NMG - .sale_PLAN

-            test = .bdgt_NFG <> 0 Or .bdgt_NMG <> 0 Or .sale_PLAN <> 0

-        End With

-        If test Then

-            If sum < 0 Then

-                MsgBox _

-                    "Ваш план превышает выделенный на гепарины бюджет. Сохранить данные?", _

-                    vbOKOnly, PROGRAM_NAME

-            End If

-            If test Then

-                Insert_BDGT_Record bdgt

-            End If

-        Else

-            If bdgt.id <> 0 Then

-                If vbYes = MsgBox("Удалить данные из базы!", vbYesNo, PROGRAM_NAME) Then

-                    Delete_BDGT_Record bdgt

-                End If

-                ret_back Range("DEF_FOCUS").Worksheet

-                Exit Sub

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-    End If

-

-   ClearData

-   ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(cLPU As tLPU_COMMON)

-    Dim t_sum As Long

-    t_sum = 0

-' Setup budget data

-    Range("F11") = cLPU.bdgt.bdgt_NMG

-    Range("F12") = cLPU.bdgt.bdgt_NFG

-    Range("F13") = cLPU.bdgt.sale_PLAN

-

-    With cLPU

-        Range("F14") = .pat_ALL

-        Range("F15") = .pat_HIR

-        Range("F16") = .pat_TER

-        Range("F17") = .pat_CRD

-        Range("F18") = .sale_ALL

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    ws_activate

-End Sub

-

-

-Sub ws_activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Dim cLPU As tLPU_COMMON

-    Dim objQTR As tQTR

-    Dim objLPU As tLPU

-    Dim ent_date As String

-    Dim id As Long

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"), Range("RM_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    id = Range("lpu_id").Value

-    ent_date = Range("ent_date")

-    

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id, cRep.rm_id)

-

-    objLPU = Get_LPU_Record(id, Range("RM_ID"))

-    Get_LPU_Common cLPU, objLPU, objQTR

-

-    If cLPU.lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = cLPU.lpu.beds

-        Range("lpu_name") = cLPU.lpu.Name

-        Range("lpu_addr") = cLPU.lpu.address

-        Range("rec_id") = cLPU.bdgt.id

-

-        SetupData cLPU

-

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-'    MsgBox Target.address

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case INPUT_CHECK

-

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{BFB4547C-96A7-4739-AA0A-CEF1E35E2BDC}{C3D618A3-9410-4BC7-9D93-3B049D361132}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mSheets
->>>>>>
-Attribute VB_Name = "mSheets"

-Option Explicit

-

-Function am_load_now() As Boolean

-    am_load_now = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE")

-End Function

-

-Sub Wks_select(RetSheet As String)

-    Dim sheet As Worksheet

-    For Each sheet In ThisWorkbook.Worksheets

-        If sheet.Name = RetSheet Then

-            ThisWorkbook.Worksheets(RetSheet).Select

-            Exit Sub

-        End If

-    Next sheet

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub ret_back(sh As Worksheet)

-    Dim RetSheet As String

-    RetSheet = sh.Range("ret_addr")

-    sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    sh.Range("rec_id") = ""

-    sh.Range("lpu_id") = ""

-    sh.Range("ent_date") = ""

-    sh.Range("lpu_name") = ""

-    sh.Range("lpu_addr") = ""

-    sh.Range("lpu_beds") = ""

-    Wks_select RetSheet

-    sh.Range("ret_addr") = ""

-End Sub

-

-Sub ClearSheetData(r_start As Range)

-    If r_start <> "" Then

-        r_start.Worksheet.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        r_start = ""

-    Else

-        ret_back r_start.Worksheet

-    End If

-End Sub

-

-Sub wks_sel_chng(iset As tInputSet, ByVal Target As Range, sh As Worksheet)

-    Dim DebugMode As Boolean

-    Dim in_range As Range

-    

-    DebugMode = Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-

-    If DebugMode Then

-        sh.Unprotect

-    Else

-        sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    End If

-

-    If iset.vType = INPUT_CHECK Then

-        Set in_range = Target.Worksheet.Range(iset.rChk)

-    Else

-        Set in_range = Target

-    End If

-    

-    Dim str As String

-    str = GetFocusAddress(in_range, sh.Range("h_inputs"))

-

-'    MsgBox Target.Address & "; " & str

-    If str <> Target.address Then

-        sh.Range(str).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-Dlg_lpu_card
->>>>>>
-Attribute VB_Name = "Dlg_lpu_card"

-Attribute VB_Base = "0{9AAD262F-A6C4-4912-9C58-D7A2071181B8}{9470F4EB-DA9F-4584-9159-D09319548D21}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbLPU_List_Change()

-    Dim src As Range

-    Dim idx_src As Integer

-    

-    Set src = Worksheets(VAR_SHEET).Range(Me.cbLPU_List.RowSource)

-    idx_src = Me.cbLPU_List.ListIndex + 1

-    Me.tb_lpu_name.Text = src.Cells(idx_src, 1)

-    Me.tb_lpu_address.Text = src.Cells(idx_src, 2)

-    Me.tbBedsCount.Text = src.Cells(idx_src, 3)

-End Sub

-

-

-Private Sub cbxLPU_List_Enable_Click()

-    

-    If Me.cbxLPU_List_Enable Then

-        

-        Me.tb_lpu_name.Text = ""

-        Me.tb_lpu_name.Enabled = False

-        

-        Me.tb_lpu_address.Text = ""

-        Me.tb_lpu_address.Enabled = False

-        

-        Me.tbBedsCount.Text = ""

-        Me.tbBedsCount.Enabled = False

-        

-        Me.cbLPU_List.Enabled = True

-        cbLPU_List_Change

-    Else

-        Me.tb_lpu_name.Enabled = True

-        Me.tb_lpu_name.Text = ""

-        

-        Me.tb_lpu_address.Enabled = True

-        Me.tb_lpu_address.Text = ""

-        

-        Me.tbBedsCount.Enabled = True

-        Me.tbBedsCount.Text = ""

-        

-        Me.cbLPU_List.Enabled = False

-    End If

-End Sub

-

-<<<<<<
-======================
-UserInfo
->>>>>>
-Attribute VB_Name = "UserInfo"

-Attribute VB_Base = "0{A8FBEE9C-DE59-49DE-971D-07BC9C0E9BD2}{C712732B-D8E4-4C2D-8E78-AC90968E0CD7}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Tag = vbOK

-End Sub

-

-Private Sub cbCity_Change()

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_CITY") = Me.cbCity.ListIndex

-        .Calculate

-    End With

-End Sub

-

-Private Sub cbRegion_Change()

-    Dim LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        NewRangeOffsetCol = cbRegion.Value * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .Name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).address

-        NewSumRange = .Name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).address

-        .Calculate

-        .Range("IDX_CITY") = 0

-        cbCity.RowSource = NewCbxRange

-

-    End With

-    cbCity.ListIndex = 0

-End Sub

-

-<<<<<<
-======================
-mREGMAN
->>>>>>
-Attribute VB_Name = "mREGMAN"

-Option Explicit

-

-Sub hw_reset()

-    Dim rs As Range

-    Dim re As Object

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    HWReset

-    With Application

-        .DisplayAlerts = False

-        .Quit

-    End With

-End Sub

-

-Sub CheckUser()

-    If Range("HW_Number") = "" Then

-        StoreHWInfo

-    End If

-    If CheckHWInfo <> True Then

-        MsgBox "2"

-        cmAbout

-'        With Application

-'            .DisplayAlerts = False

-'            .Quit

-'        End With

-    Else

-        SetupUser

-    End If

-End Sub

-

-

-Sub SetupUser()

-'    Dim cREGMAN As tREGMAN

-'    Dim idx As Integer

-'    Dim dlg_ui As UserInfo

-'

-'    Set dlg_ui = New UserInfo

-'

-'    cREGMAN = Get_REGMAN_Record()

-'

-'    With ThisWorkbook.Worksheets(REGS_SHEET)

-'        .Range("IDX_REGION") = cREGMAN.Region

-'        .Range("IDX_CITY") = cREGMAN.City

-'    End With

-'

-'    With dlg_ui

-'        .cbRegion = cREGMAN.Region

-'        .cbCity = cREGMAN.City

-'        .tbFName = cREGMAN.FirstName

-'        .tbLName = cREGMAN.LastName

-'    End With

-'

-'    dlg_ui.Show

-'    Worksheets(REGS_SHEET).Calculate

-'

-'    If dlg_ui.Tag = vbOK Then

-'        With cREGMAN

-'            .Region = dlg_ui.cbRegion.Value

-'            .City = dlg_ui.cbCity.Value

-'            .FirstName = dlg_ui.tbFName.Value

-'            .LastName = dlg_ui.tbLName.Value

-'        End With

-'        Set_REGMAN_Record cREGMAN

-'    Else

-'        cmAbout

-'        With Application

-'            .DisplayAlerts = False

-'            .Quit

-'        End With

-'    End If

-End Sub

-

-Sub StoreHWInfo()

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim objHW() As Long

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    Set r = Range("HW_Number")

-    i = 1

-    For Each d In dc

-        If d.drivetype = 2 Then

-            r = d.SerialNumber

-            Set r = r.Offset(1, 0)

-            ReDim Preserve objHW(i)

-            objHW(i) = d.SerialNumber

-            i = i + 1

-        End If

-    Next

-    

-    UpdateHWRecords objHW

-End Sub

-

-Function CheckHWInfo()

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim objHW() As Long

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    

-    CheckHWInfo = False

-    

-    i = GetHWRecords(objHW)

-    If i = 0 And Range("HW_Number") <> 0 Then

-        Exit Function

-    End If

-    For Each d In dc

-        If d.drivetype = 2 Then

-            Set r = Range("HW_Number")

-            Do While r <> ""

-                If r = d.SerialNumber Then

-                    For i = 1 To UBound(objHW)

-                        If d.SerialNumber = objHW(i) Then

-                            CheckHWInfo = True

-                            Exit Function

-                        End If

-                    Next i

-                End If

-                Set r = r.Offset(1, 0)

-            Loop

-        End If

-    Next

-End Function

-<<<<<<
-======================
-dbBudget
->>>>>>
-Attribute VB_Name = "dbBudget"

-Option Explicit

-

-Public Type tBUDGET

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    rm_id As Long

-    bdgt_NMG As Long

-    bdgt_NFG As Long

-    sale_PLAN As Long

-End Type

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function GetAll_BDGT_RecordsByLPU_ID(ByRef allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_BDGT_RecordsByLPU_ID = dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection, allBDGT, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function Get_BDGT_Record(ByVal lpu_id As Long, ByVal ent_date As String, rm_id As Long) As tBUDGET

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    Get_BDGT_Record = dbGet_BDGT_Record(dbConnection, lpu_id, ent_date, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-' if objBDGT.ID <> 0 then updatre else insert

-Public Sub Insert_BDGT_Record(objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    If objBDGT.id <> 0 Then

-        dbUpdate_BDGT_Record dbConnection, objBDGT

-    Else

-        dbInsert_BDGT_Record dbConnection, objBDGT

-    End If

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Public Sub Delete_BDGT_Record(ByRef objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    dbDelete_BDGT_Record dbConnection, objBDGT

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_BDGT_Record(dbConnection As Object, ByVal lpu_id As Long, ent_date As String, rm_id As Long) As tBUDGET

-    

-    Dim sql As String

-    Dim objBDGT As tBUDGET

-    

-    With objBDGT

-        .id = 0

-        .lpu_id = lpu_id

-        .rm_id = rm_id

-        .entry_date = ent_date

-        .bdgt_NMG = 0

-        .bdgt_NFG = 0

-        .sale_PLAN = 0

-    End With

-        

-    

-    sql = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        With objBDGT

-            .entry_date = dbRecordset("entry_date")

-            .id = dbRecordset("id")

-            .lpu_id = dbRecordset("lpu_id")

-            .bdgt_NFG = dbRecordset("bdgt_NFG")

-            .bdgt_NMG = dbRecordset("bdgt_NMG")

-            .sale_PLAN = dbRecordset("sale_PLAN")

-        End With

-    End If

-    

-    dbGet_BDGT_Record = objBDGT

-End Function

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection As Object, allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_BDGT_SQL As String

-    Dim getAll_BDGT_SQL As String

-    Dim BDGT_Count As Long

-    BDGT_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_BDGT_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        BDGT_Count = dbRecordset("BDGT_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_BDGT_RecordsbyLPU_ID = BDGT_Count

-    

-    If BDGT_Count > 0 Then

-        'we have records

-        ReDim allBDGT(1 To BDGT_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_BDGT_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpBDGT As tBUDGET

-                 With tmpBDGT

-                    .entry_date = dbRecordset("entry_date")

-                    .id = dbRecordset("id")

-                    .lpu_id = dbRecordset("lpu_id")

-                    .bdgt_NFG = dbRecordset("bdgt_NFG")

-                    .bdgt_NMG = dbRecordset("bdgt_NMG")

-                    .sale_PLAN = dbRecordset("sale_PLAN")

-                 End With

-                 

-                 allBDGT(index) = tmpBDGT

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbInsert_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "lpu_budget", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    dbRecordset("entry_date") = objBDGT.entry_date

-    dbRecordset("lpu_id") = objBDGT.lpu_id

-    dbRecordset("bdgt_NMG") = objBDGT.bdgt_NMG

-    dbRecordset("bdgt_NFG") = objBDGT.bdgt_NFG

-    dbRecordset("sale_PLAN") = objBDGT.sale_PLAN

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objBDGT.id = dbRecordset("id")

-  

-End Sub

-

-Public Sub dbUpdate_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu_budget SET " & _

-    "entry_date='" & objBDGT.entry_date & "'," & _

-    "lpu_id=" & objBDGT.lpu_id & "," & _

-    "bdgt_NMG=" & objBDGT.bdgt_NMG & "," & _

-    "bdgt_NFG=" & objBDGT.bdgt_NFG & "," & _

-    "sale_PLAN=" & objBDGT.sale_PLAN & _

-    " WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-Public Sub dbDelete_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_BDGT_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbDatabase
->>>>>>
-Attribute VB_Name = "dbDatabase"

-Option Explicit

-

-

-Sub dbOpenConnection(dbConnection As Object)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-<<<<<<
-======================
-dbLPU
->>>>>>
-Attribute VB_Name = "dbLPU"

-Option Explicit

-

-Public Type tLPU

-    id As Long

-    rep_id As Long

-    rm_id As Long

-    Name As String

-    address As String

-    beds As Integer

-End Type

-

-Function Get_LPU_Record(ByVal lpu_id As Long, rm_id As Long) As tLPU

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_LPU_Record = dbGet_LPU_Record(dbConnection, lpu_id, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_LPU_byQTR(allLPU() As tLPU, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_LPU_byQTR = dbGetAll_LPU_byQTR(dbConnection, allLPU, ent_date, rep_id, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_Record(dbConnection As Object, ByVal lpu_id As Long, rm_id As Long) As tLPU

-    

-    Dim sql As String

-    Dim objLPU As tLPU

-    

-    objLPU.id = lpu_id

-    objLPU.Name = ""

-    objLPU.address = ""

-    

-    sql = "SELECT * FROM lpu WHERE id=" & lpu_id & " AND rm_id=" & rm_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objLPU.Name = dbRecordset("name")

-        objLPU.address = dbRecordset("address")

-        objLPU.rep_id = dbRecordset("rep_id")

-        objLPU.rm_id = dbRecordset("rm_id")

-        objLPU.beds = dbRecordset("beds")

-    End If

-    

-    dbGet_LPU_Record = objLPU

-

-End Function

-

-Function dbGetAll_LPU_byQTR(dbConnection As Object, allLPU() As tLPU, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    Dim Where As String

-    Where = "WHERE lpu_budget.entry_date like '" & ent_date & "'" & " AND lpu.id=lpu_budget.lpu_id " & _

-    "AND lpu.rep_id=" & rep_id & " AND lpu.rm_id=lpu_budget.rm_id AND lpu.rm_id=" & rm_id

-

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu_budget, lpu " & Where

-    

-    getAll_LPU_SQL = "SELECT lpu.id as id, lpu.rep_id as rep_id, lpu.name as name, lpu.address as address, lpu.beds AS beds, lpu.rm_id AS rm_id " & _

-    "FROM lpu, lpu_budget " & Where

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_LPU_byQTR = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .Name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-dbREP
->>>>>>
-Attribute VB_Name = "dbREP"

-'Option Explicit

-'

-'Public Type tREP

-'    FirstName As String

-'    LastName As String

-'    Region As Integer

-'    City As Integer

-'End Type

-'

-'Function GetREPRecord() As tREP

-'    Dim dbConnection As Object

-'

-'    dbOpenConnection dbConnection

-'    GetREPRecord = dbGetREPRecord(dbConnection)

-'    dbCloseConnection dbConnection

-'End Function

-'

-'Sub SetREPRecord(cUser As tREP)

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbSetREPRecord dbConnection, cUser

-'    dbCloseConnection dbConnection

-'End Sub

-'

-'Public Function dbGetREPRecord(dbConnection As Object) As tREP

-'

-'    Dim SQL As String

-'    Dim objREP As tREP

-'

-'    objREP.FirstName = ""

-'    objREP.LastName = ""

-'    objREP.Region = 0

-'    objREP.City = 0

-'    SQL = "SELECT firstname, lastname, region, city FROM " & _

-'          "rep"

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open SQL, dbConnection

-'    ', 3, 3

-'    If Not dbRecordset.BOF Then

-'

-'        objREP.FirstName = dbRecordset("firstname")

-'        objREP.LastName = dbRecordset("lastname")

-'        objREP.Region = dbRecordset("region")

-'        objREP.City = dbRecordset("city")

-'

-'    End If

-'

-'    dbGetREPRecord = objREP

-'

-'End Function

-'

-'Public Sub dbSetREPRecord(dbConnection As Object, ByRef objREP As tREP)

-'

-'    Dim DeleteSQL As String

-'    Dim InsertSQL As String

-'

-'    DeleteSQL = "DELETE FROM rep"

-'    InsertSQL = "INSERT INTO rep (firstname, lastname, region, city) VALUES (" & _

-'    "'" & objREP.FirstName & "', " & _

-'    "'" & objREP.LastName & "', " & _

-'    objREP.Region & ", " & _

-'    objREP.City & ")"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-'

-'End Sub

-'

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    CheckWorkBooksArround Wb

-End Sub

-

-

-Sub CheckWorkBooksArround(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If app.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEL сейчас будут закрыты!", vbOKOnly, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub GetState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-        ActiveWorkbook.DisplayDrawingObjects = xlDisplayShapes

-        

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.Name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars(STDBAR_NAME).Visible = False

-End Sub

-

-

-Public Sub RestoreState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars(STDBAR_NAME).Visible = True

-End Sub

-

-

-

-<<<<<<
-======================
-cdbRM
->>>>>>
-Attribute VB_Name = "cdbRM"

-Option Explicit

-

-Public Type tRMID_COMMON

-    rm As tREGMAN

-    rgcd_count As Integer

-    rgcd() As tREGION

-End Type

-

-Function Get_RM_CommonList_by_QTR(ByRef rmcd() As tRMID_COMMON, ent_date As String) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_RM_CommonList_by_QTR = dbGet_RM_CommonList_by_QTR(dbConnection, rmcd(), ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_RM_CommonList_by_QTR(dbConnection As Object, ByRef rmcd() As tRMID_COMMON, ent_date As String) As Integer

-    ' Получить список RM-ов

-    Dim count As Integer

-    count = db_get_All_RM_by_QTR(dbConnection, rmcd(), ent_date)

-    

-    Dim i As Integer

-    For i = 1 To count

-        rmcd(i).rgcd_count = 1

-        ReDim rmcd(i).rgcd(1 To 1)

-        getREGION_by_QTR ent_date, rmcd(i).rgcd(1), rmcd(i).rm.rm_id

-    Next i

-    dbGet_RM_CommonList_by_QTR = count

-End Function

-

-Function db_get_All_RM_by_QTR(dbConnection As Object, rmcd() As tRMID_COMMON, ent_date As String) As Integer

-    

-    Dim count_sql As String

-    Dim get_sql As String

-    Dim rs As Object

-    Dim RM_Count As Integer

-        

-    count_sql = "SELECT COUNT(*) AS RM_TOTAL FROM reg_man"

-    get_sql = "SELECT * FROM reg_man"

-    Set rs = CreateObject("ADODB.Recordset")

-    rs.Open count_sql, dbConnection

-    

-    If Not rs.BOF Then

-        RM_Count = rs("RM_TOTAL")

-    End If

-    

-    rs.Close

-    

-     db_get_All_RM_by_QTR = RM_Count

-    

-    If RM_Count > 0 Then

-        'we have records

-        ReDim rmcd(1 To RM_Count)

-        Dim index As Long

-        index = 1

-        rs.Open get_sql, dbConnection

-        

-        If Not rs.BOF Then

-             Do While Not rs.EOF

-                 Dim tmp_rmcd As tRMID_COMMON

-                 With tmp_rmcd

-                    .rgcd_count = 0

-                    .rm.City = rs("city")

-                    .rm.FirstName = rs("firstname")

-                    .rm.LastName = rs("lastname")

-                    .rm.rm_id = rs("mgr_id")

-                    .rm.Region = rs("region")

-                 End With

-                 

-                 rmcd(index) = tmp_rmcd

-                 index = index + 1

-                 rs.MoveNext

-             Loop

-        End If

-    End If

-    

-End Function

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Public Const STDBAR_NAME = "Worksheet Menu Bar"

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Import data"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmDataImport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-             With .Add(msoControlPopup)

-                .Caption = "&Report"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&New Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 18

-                        .OnAction = "cmNewReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Open Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmOpenReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Close && Save"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseReport"

-                    End With

-                End With

-            End With

-           With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Exit && Restore Excel"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 548

-                        .OnAction = "cmExitRestore"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-        End With

-    End With

-End Sub

-

-Sub CreateExtCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom extendet commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Import data"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmDataImport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-             With .Add(msoControlPopup)

-                .Caption = "&Report"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&New Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 18

-                        .OnAction = "cmNewReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Open Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmOpenReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Close && Save"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseReport"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Add New Slide"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 280

-                .OnAction = "cmAddSlide"

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(flag As Boolean)

-    If flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars(STDBAR_NAME)

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmExport()

-    dbExport

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    Dim dlg As dlgAbout

-    Set dlg = New dlgAbout

-    

-    dlg.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlg.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlg.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlg.Show

-End Sub

-

-Sub cmMail2Support()

-    Dim err_description As String

-    Dim dlg_msg As dlg_Mail

-    Set dlg_msg = New dlg_Mail

-    With dlg_msg

-        .Show

-        If .Tag = vbOK Then

-            ThisWorkbook.Worksheets(VAR_SHEET).Range("ERR_MESSAGE") _

-                = .tbMessage.Text

-            ThisWorkbook.Save

-            ThisWorkbook.SendMail Recipients:="infra@i-rs.ru", Subject:=PROGRAM_NAME & " ver.:" & PROGRAM_VERSION

-            MsgBox "Сообщение об ошибке отправлено. Перезагрузите программу.", vbOKOnly, PROGRAM_NAME

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-    End With

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-'        helppath = "hh.exe " & .Path & "\Telfast.chm"

-'        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub set_work_mode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-End Sub

-

-Sub cmSetStandaloneMode()

-    set_work_mode

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    Dim dlg As dlgGetPwd

-    rp = common_pwd

-    

-    Set dlg = New dlgGetPwd

-    dlg.edPwd = ""

-    dlg.Show

-    

-    If dlg.edPwd = rp Then

-        Application.ScreenUpdating = False

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-        xlRestoreView

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-        Application.ScreenUpdating = True

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmNewReport()

-    ppReport.CreateReport

-    MsgBox "Новый отчет создан", vbInformation + vbOKOnly, PROGRAM_NAME

-    CreateExtCommandBar theApp:=ThisWorkbook.Application

-End Sub

-

-Sub cmOpenReport()

-    Dim fileToOpen

-    Dim s As String

-    fileToOpen = Application _

-        .GetOpenFileName("Report Files (*.ppt), *.ppt", title:="Report OPen", MultiSelect:=False)

-    If fileToOpen <> False Then

-        s = fileToOpen

-        ppReport.OpenReport s

-        CreateExtCommandBar theApp:=ThisWorkbook.Application

-    End If

-End Sub

-

-Sub cmCloseReport()

-    On Error Resume Next

-    ppReport.SaveReport

-    CreateCommandBar theApp:=ThisWorkbook.Application

-End Sub

-

-Sub cmAddSlide()

-    ThisWorkbook.ActiveSheet.PrintCopy

-    ppReport.InsertSlide

-End Sub

-

-Sub cmHomePage()

-    ThisWorkbook.Worksheets("PRJ_QTR").Select

-End Sub

-

-Sub cmExitRestore()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = True

-    Application.Quit

-End Sub

-

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    Dim dlg_prn As dlgPrint

-    

-    Set dlg_prn = New dlgPrint

-    

-    With dlg_prn

-        .cbMainReport = True

-        .cbMainBudget = False

-        .cbSrcData = False

-        .cbAllSheets = False

-    

-        .Show

-    

-        If .Tag = vbCancel Then

-            Exit Sub

-        End If

-    End With

-    

-    Dim PrnIdx As Integer

-    

-    With dlg_prn

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("REP_QTR", "budget", "Final")

-    Case 1111

-        plist = Array("REP_QTR", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("REP_QTR")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Clexane bar"

-Public Const common_pwd As String = "crdjhxtyjr"

-

-

-Sub SetEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    With Application

-        .Caption = PROGRAM_NAME

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .GetState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = False

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Unprotect

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    If cWindow.Type = xlWorkbook Then

-                        cWindow.DisplayHeadings = True

-                    End If

-                Next

-            End If

-        Next

-        If DesignMode Then

-            SetupDesignMenu True

-        End If

-        With mobjAppState

-            .RestoreState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Option Explicit

-

-Sub UpdateHWRecords(objHW() As Long)

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    dbUpdateHWRecords dbConnection, objHW

-    dbCloseConnection dbConnection

-End Sub

-

-Function GetHWRecords(objHW() As Long) As Integer

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    GetHWRecords = dbGetHWRecords(dbConnection, objHW)

-    dbCloseConnection dbConnection

-End Function

-

-Sub HWReset()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbInsertHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    

-    Dim dbRecordset As Object

-    Dim i As Long

-    

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "hw", dbConnection, 2, 2

-    

-    For i = 1 To UBound(objHW)

-        dbRecordset.addnew

-        dbRecordset("num") = objHW(i)

-        dbRecordset.Update

-    Next i

-    

-End Sub

-

-Sub dbUpdateHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    dbDeleteHWRecord dbConnection

-    dbInsertHWRecords dbConnection, objHW

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-dbHir
->>>>>>
-Attribute VB_Name = "dbHir"

-Option Explicit

-

-Public Type tHIRURGIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    operations_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_ambulator_clexan_40mg As Integer

-    patients_ambulator_clexan_20mg As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-    patients_stationar_clexan_40mg As Integer

-    patients_stationar_clexan_20mg As Integer

-End Type

-

-' if objHir.ID <> 0 then updatre else insert

-Sub Insert_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objHir.id <> 0 Then

-        dbUpdate_Hir_Record dbConnection, objHir

-    Else

-        dbInsert_Hir_Record dbConnection, objHir

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Hir_RecordsByLPU_ID(ByRef allHir() As tHIRURGIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Hir_RecordsByLPU_ID = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, allHir, lpu_id, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Hir_Record dbConnection, objHir

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objHir.ID <> 0 then updatre else insert

-

-Sub dbInsert_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_hir", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objHir

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("operations_per_quarter") = .operations_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_ambulator_clexan_20mg") = .patients_ambulator_clexan_20mg

-        dbRecordset("patients_ambulator_clexan_40mg") = .patients_ambulator_clexan_40mg

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-        dbRecordset("patients_stationar_clexan_20mg") = .patients_stationar_clexan_20mg

-        dbRecordset("patients_stationar_clexan_40mg") = .patients_stationar_clexan_40mg

-        

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objHir.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim UpdateSQL As String

-    

-    With objHir

-        UpdateSQL = "UPDATE lpu_hir SET " & _

-            "entry_date='" & objHir.entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "operations_per_quarter=" & .operations_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_ambulator_clexan_20mg=" & .patients_ambulator_clexan_20mg & "," & _

-            "patients_ambulator_clexan_40mg=" & .patients_ambulator_clexan_40mg & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & "," & _

-            "patients_stationar_clexan_20mg=" & .patients_stationar_clexan_20mg & "," & _

-            "patients_stationar_clexan_40mg=" & .patients_stationar_clexan_40mg & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_Hir_RecordsbyLPU_ID(dbConnection As Object, allHir() As tHIRURGIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_Hir_SQL As String

-    Dim getAll_Hir_SQL As String

-    Dim Hir_Count As Long

-    Hir_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    Else

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Hir_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Hir_Count = dbRecordset("HIR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Hir_RecordsbyLPU_ID = Hir_Count

-    

-    If Hir_Count > 0 Then

-        'we have records

-        ReDim allHir(1 To Hir_Count)

-        Dim index As Integer

-        index = 1

-        dbRecordset.Open getAll_Hir_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpHir As tHIRURGIA

-                 With tmpHir

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .operations_per_quarter = dbRecordset("operations_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_ambulator_clexan_20mg = dbRecordset("patients_ambulator_clexan_20mg")

-                    .patients_ambulator_clexan_40mg = dbRecordset("patients_ambulator_clexan_40mg")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                    .patients_stationar_clexan_20mg = dbRecordset("patients_stationar_clexan_20mg")

-                    .patients_stationar_clexan_40mg = dbRecordset("patients_stationar_clexan_40mg")

-                 End With

-                 

-                 allHir(index) = tmpHir

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE ID=" & objHir.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Hir_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbTer
->>>>>>
-Attribute VB_Name = "dbTer"

-Option Explicit

-

-Public Type tTERAPIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objTer.ID <> 0 then updatre else insert

-Sub Insert_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objTer.id <> 0 Then

-        dbUpdate_Ter_Record dbConnection, objTer

-    Else

-        dbInsert_Ter_Record dbConnection, objTer

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Ter_RecordsByLPU_ID(ByRef allTer() As tTERAPIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Ter_RecordsByLPU_ID = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, allTer, lpu_id, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Ter_Record dbConnection, objTer

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objTer.ID <> 0 then updatre else insert

-

-Sub dbInsert_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_ter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objTer

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objTer.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim Update_SQL As String

-    

-    With objTer

-        Update_SQL = "UPDATE lpu_ter SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_Ter_RecordsbyLPU_ID(dbConnection As Object, allTer() As tTERAPIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_Ter_SQL As String

-    Dim getAll_Ter_SQL As String

-    Dim Ter_Count As Long

-    Ter_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    Else

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Ter_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Ter_Count = dbRecordset("TER_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Ter_RecordsbyLPU_ID = Ter_Count

-    

-    If Ter_Count > 0 Then

-        'we have records

-        ReDim allTer(1 To Ter_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_Ter_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpTer As tTERAPIA

-                 With tmpTer

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 allTer(index) = tmpTer

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE ID=" & objTer.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Ter_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-mLPU_LIST
->>>>>>
-Attribute VB_Name = "mLPU_LIST"

-Option Explicit

-

-Public Const CINP_AREA As String = "B12"

-Public Const CLPU_NAME As Integer = 0

-Public Const CLPU_NAME1 As Integer = 1

-Public Const CLPU_NAME2 As Integer = 2

-Public Const CLPU_ID As Integer = 3

-Public Const CLPU_BEDS As Integer = 4

-Public Const CLPU_NFG As Integer = 5

-Public Const CLPU_NMG As Integer = 6

-Public Const CLPU_HIR As Integer = 7

-Public Const CLPU_TER As Integer = 8

-Public Const CLPU_CAR As Integer = 9

-Public Const CLPU_FACT As Integer = 10

-Public Const CLPU_PLAN As Integer = 11

-Public Const CLPU_PAT_LPU As Integer = 16

-Public Const CLPU_BDGT As Integer = 17

-Public Const CLPU_PAT_ALL As Integer = 16

-

-Sub EditLPU(cLPU As tLPU, ent_date As String)

-    NoFunc

-End Sub

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("LPU_LIST")

-        s = .Range("C4") & " " & .Range("C3") & ", " & .Range("G4") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_LPU_BBL").Range("title") = MakeChartTitle

-End Sub

-

-Sub Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PIE").Range("title") = MakeChartTitle

-End Sub

-

-Sub Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU_A").Range("title") = MakeChartTitle

-End Sub

-

-Sub btLPU_DEL_IT()

-'    Dim cLPU As tLPU

-'    Dim ent_date As String

-'    Dim delete_all As Integer

-'    Dim dlg_del As dlg_LPU_delete

-'

-'    With Worksheets("LPU_LIST")

-'        ent_date = .Range("ent_date")

-'        cLPU.id = .getCurrentLPU_ID()

-'    End With

-'

-'    If cLPU.id = 0 Then

-'        MsgBox "Укажите удаляемый объект", vbOKOnly, PROGRAM_NAME

-'        Exit Sub

-'    End If

-'    cLPU = Get_LPU_Record(cLPU.id)

-'

-'    Set dlg_del = New dlg_LPU_delete

-'    With dlg_del

-'        .chbDeleteQTR.Value = True

-'        .chbDeleteAll.Value = False

-'        .lComment = ent_date & ": Удаление ЛПУ '" _

-'        & cLPU.Name & "', расположенного по адресу:" _

-'        & cLPU.address & " не разрешено."

-'        .Show

-'    End With

-End Sub

-

-Sub btLPU_RET_IT()

-    With Worksheets("LPU_LIST")

-        .setEnt_date ("")

-        .Range("LAST_FOCUS") = ""

-        

-        Wks_select .Range("ret_addr")

-    End With

-

-End Sub

-

-

-Sub btLPU_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim lpu_id As Long

-

-    i = Worksheets(VAR_SHEET).Range("QTR_ACTION").Value

-    With Worksheets("LPU_LIST")

-        ent_date = .getEnt_date()

-

-

-        lpu_id = .getCurrentLPU_ID

-        If lpu_id = 0 And i <> 6 Then

-            i = 1

-        End If

-        Select Case i

-            Case 1

-                .SelectLPU_NAME lpu_id, ent_date

-                .Range("JUMP") = "LPU_BDGT"

-            Case 2

-                .SelectLPU_BDGT lpu_id, ent_date

-                .Range("JUMP") = "LPU_BDGT"

-            Case 3

-                .SelectLPU_HIR lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_HIR"

-

-            Case 4

-                .SelectLPU_TER lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_TER"

-

-            Case 5

-                .SelectLPU_C_ACS lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        End Select

-    End With

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-dbQTR
->>>>>>
-Attribute VB_Name = "dbQTR"

-Option Explicit

-

-Public Type tQTR

-    id As Long

-    entry_date As String

-    rep_id As Long

-    rm_id As Long

-    sale_PLAN As Long

-    ClxnH20mg As Long

-    ClxnH40mg As Long

-    ClxnT40mg As Long

-    ClxnC_IM As Long

-    ClxnC_ACS As Long

-End Type

-

-Function Get_QTR_Record(ByVal QTR_ID As Long, rm_id As Long) As tQTR

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_QTR_Record = dbGet_QTR_Record(dbConnection, QTR_ID, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_Record(dbConnection As Object, ByVal QTR_ID As Long, rm_id As Long) As tQTR

-    

-    Dim sql As String

-    Dim objQTR As tQTR

-    

-    With objQTR

-        .ClxnC_ACS = 0

-        .ClxnC_IM = 0

-        .ClxnH20mg = 0

-        .ClxnH40mg = 0

-        .ClxnT40mg = 0

-        .entry_date = ""

-        .id = QTR_ID

-        .rm_id = rm_id

-    End With

-    

-    sql = "SELECT * FROM quarter WHERE id=" & QTR_ID & " AND rm_id=" & rm_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objQTR.entry_date = dbRecordset("entry_date")

-        objQTR.rep_id = dbRecordset("rep_id")

-        objQTR.rm_id = dbRecordset("rm_id")

-        objQTR.sale_PLAN = dbRecordset("sale_plan")

-        objQTR.ClxnH20mg = dbRecordset("ClxnH20mg")

-        objQTR.ClxnH40mg = dbRecordset("ClxnH40mg")

-        objQTR.ClxnT40mg = dbRecordset("ClxnT40mg")

-        objQTR.ClxnC_IM = dbRecordset("ClxnC_IM")

-        objQTR.ClxnC_ACS = dbRecordset("ClxnC_ACS")

-        objQTR.id = dbRecordset("id")

-    End If

-    

-    dbGet_QTR_Record = objQTR

-

-End Function

-

-

-Function Get_QTR_Record_by_REP(ent_date As String, rep_id As Long, rm_id As Long) As tQTR

-    Dim dbConnection As Object

-    Dim allQTR() As tQTR

-    Dim i As Long

-

-    dbOpenConnection dbConnection

-

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id, rm_id)

-    If i <> 0 Then

-        Get_QTR_Record_by_REP = allQTR(1)

-    End If

-

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTR_Records_by_REP(ByRef all_QTR() As tQTR, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-

-    GetAll_QTR_Records_by_REP = dbGetAll_QTR_Records_By_REP(dbConnection, all_QTR, ent_date, rep_id, rm_id)

-

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGetAll_QTR_Records_By_REP(dbConnection As Object, all_QTR() As tQTR, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-

-    Dim getCount_QTR_SQL As String

-    Dim getAll_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    Dim rep_sql As String

-    Dim rm_sql As String

-    

-    rep_sql = ""

-    rm_sql = ""

-    

-    If rep_id <> 0 Then

-        rep_sql = " AND rep_id=" & rep_id

-    End If

-    

-    If rm_id <> 0 Then

-        rm_sql = " AND rm_id=" & rm_id

-    End If

-    

-    

-        getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter " & _

-        "WHERE entry_date like '" & ent_date & "' " & rep_sql & rm_sql

-        getAll_QTR_SQL = "SELECT * FROM quarter " & _

-        "WHERE entry_date like '" & ent_date & "' " & rep_sql & rm_sql & " ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-

-    dbRecordset.Close

-

-    dbGetAll_QTR_Records_By_REP = QTR_Count

-

-    If QTR_Count > 0 Then

-        'we have records

-        ReDim all_QTR(1 To QTR_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTR_SQL, dbConnection

-

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTR As tQTR

-                 With tmp_QTR

-                    .entry_date = dbRecordset("entry_date")

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .ClxnH20mg = dbRecordset("ClxnH20mg")

-                    .ClxnH40mg = dbRecordset("ClxnH40mg")

-                    .ClxnT40mg = dbRecordset("ClxnT40mg")

-                    .ClxnC_IM = dbRecordset("ClxnC_IM")

-                    .ClxnC_ACS = dbRecordset("ClxnC_ACS")

-                    .id = dbRecordset("id")

-                 End With

-

-                 all_QTR(index) = tmp_QTR

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-cdbQTR
->>>>>>
-Attribute VB_Name = "cdbQTR"

-Option Explicit

-

-Public Type tQTR_COMMON

-    qtr As tQTR

-    i_lcd As Long           ' число ЛПУ в СПИСКЕ

-    lcd() As tLPU_COMMON    ' список ЛПУ

-    c_beds As Long          ' сумма коек

-    c_bdgt_NFG As Long      ' общий бюджет на НФГ

-    c_bdgt_NMG As Long      ' общий бюджет на НМГ

-    c_bdgt_LPU As Long      ' общий бюджет на гепарины

-    c_sale_PLAN As Long     ' план продаж репа

-    c_sale_ALL As Long      ' продажи

-    c_sale_HIR As Long      ' в хирургии

-    c_sale_TER  As Long     ' в терапии

-    c_sale_CRD  As Long     ' в кардиологии

-    c_pat_HIR   As Long     ' пациенты

-    c_pat_TER   As Long     '

-    c_pat_CRD   As Long     '

-    c_pat_ALL   As Long     '

-    c_pat_LPU   As Long     ' Всего операций

-End Type

-

-Function Get_QTR_CommonList_by_REP(ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long, rm_id As Long) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_QTR_CommonList_by_REP = dbGet_QTR_CommonList_by_REP(dbConnection, qcd, ent_date, rep_id, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_CommonList_by_REP(dbConnection As Object, ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long, rm_id As Long) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim allQTR() As tQTR

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id, rm_id)

-    dbGet_QTR_CommonList_by_REP = i

-    If i > 0 Then

-        ReDim qcd(i)

-        For i = 1 To UBound(allQTR)

-            With qcd(i)

-                .qtr = allQTR(i)

-                .c_beds = 0

-                .c_bdgt_NFG = 0

-                .c_bdgt_NMG = 0

-                .c_bdgt_LPU = 0

-                .c_sale_PLAN = 0

-                .c_pat_HIR = 0

-                .c_pat_TER = 0

-                .c_pat_CRD = 0

-                .c_pat_ALL = 0

-                .c_sale_HIR = 0

-                .c_sale_TER = 0

-                .c_sale_CRD = 0

-                .c_sale_ALL = 0

-                .c_pat_LPU = 0

-                

-                j = dbGet_LPU_CommonQTR(dbConnection, .lcd, .qtr)

-                .i_lcd = j

-                If j > 0 Then

-                    For j = 1 To UBound(.lcd)

-                        .c_beds = .c_beds + .lcd(j).lpu.beds

-                        .c_bdgt_NFG = .c_bdgt_NFG + .lcd(j).bdgt.bdgt_NFG

-                        .c_bdgt_NMG = .c_bdgt_NMG + .lcd(j).bdgt.bdgt_NMG

-                        .c_bdgt_LPU = .c_bdgt_LPU + .lcd(j).bdgt_LPU

-                        .c_sale_PLAN = .c_sale_PLAN + .lcd(j).bdgt.sale_PLAN

-                        .c_pat_HIR = .c_pat_HIR + .lcd(j).pat_HIR

-                        .c_pat_TER = .c_pat_TER + .lcd(j).pat_TER

-                        .c_pat_CRD = .c_pat_CRD + .lcd(j).pat_CRD

-                        .c_pat_ALL = .c_pat_ALL + .lcd(j).pat_ALL

-                        .c_sale_HIR = .c_sale_HIR + .lcd(j).sale_HIR

-                        .c_sale_TER = .c_sale_TER + .lcd(j).sale_TER

-                        .c_sale_CRD = .c_sale_CRD + .lcd(j).sale_CRD

-                        .c_sale_ALL = .c_sale_ALL + .lcd(j).sale_ALL

-                        .c_pat_LPU = .c_pat_LPU + .lcd(j).pat_LPU

-                    Next j

-                    

-                End If

-            End With

-        Next i

-    End If

-End Function

-

-Function GetLastQtr() As String

-    Dim s As String

-    Dim r As Range

-    Set r = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Do While r.Cells(1, 1) <> ""

-        s = r.Cells(1, 1)

-        Set r = r.Cells.Offset(1, 0)

-    Loop

-    GetLastQtr = s

-End Function

-

-Function GetNextQTR(ent_date As String) As String

-    Dim rd As Range

-    Dim idx As Integer

-    Dim b As Variant

-    Dim dlg As dlg_newQTR

-    Set dlg = New dlg_newQTR

-    

-    If ent_date = "" Then

-        Dim ir As Variant

-        idx = 0

-        dlg.Show

-        b = dlg.Tag

-            

-        If IsNumeric(b) Then

-            GetNextQTR = dlg.cbQTR

-        Else

-            GetNextQTR = ""

-        End If

-    Else

-        Set rd = Worksheets(VAR_SHEET).Range("Date_Lst")

-        idx = WorksheetFunction.Match(ent_date, rd, 0)

-        GetNextQTR = WorksheetFunction.index(rd, idx + 1, 1)

-    End If

-End Function

-<<<<<<
-======================
-mRestView
->>>>>>
-Attribute VB_Name = "mRestView"

-Option Explicit

-

-Sub xlRestoreView()

-Attribute xlRestoreView.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute xlRestoreView.VB_ProcData.VB_Invoke_Func = " \n14"

-    With Application

-        .CommandBars("Standard").Visible = True

-        .CommandBars("Formatting").Visible = True

-        .DisplayFormulaBar = True

-        .DisplayStatusBar = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = True

-    End With

-End Sub

-<<<<<<
-======================
-dlg_newQTR
->>>>>>
-Attribute VB_Name = "dlg_newQTR"

-Attribute VB_Base = "0{92648543-CB84-4B6B-BEB3-539AE7EF9D84}{7E20E3E3-027A-483B-A14D-AA9EA5398ACC}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mDec2TS
->>>>>>
-Attribute VB_Name = "mDec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-CHRT_LPU_BBL
->>>>>>
-Attribute VB_Name = "CHRT_LPU_BBL"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    Unprotect

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Потенциал рынка: " & Range("title")

-    Range("view_key") = False

-    ChangeLabels

-    Range("A1").Select

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Unprotect

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub BCLabelChng_Click()

-    Unprotect

-    If Range("view_key") Then

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать названия"

-    Else

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать объемы"

-    End If

-    Range("view_key") = Not Range("view_key")

-    ChangeLabels

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub ChangeLabels()

-    Dim i As Integer

-    Dim offset_text As Integer

-    Dim src As Range

-    Set src = Range("CHRT_BBL_DATA")

-    

-    offset_text = 3

-    If Range("view_key") Then

-        offset_text = 4

-    End If

-    

-    With ChartObjects(1).Chart

-        With .SeriesCollection(1)

-            For i = 1 To .Points.count

-                On Error GoTo ExitLabel

-                .Points(i).DataLabel.Characters.Text = Format(src.Cells(i, offset_text))

-            Next i

-        End With

-    End With

-ExitLabel:

-End Sub

-<<<<<<
-======================
-CHRT_PAT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PAT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Пациенты на Клексане(чел.): " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-<<<<<<
-======================
-CHRT_PAT_LPU
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Пациенты на Клексане(%): " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_nextQTR
->>>>>>
-Attribute VB_Name = "dlg_nextQTR"

-Attribute VB_Base = "0{067FED69-B41E-427D-AF59-5798B8E2E73A}{4C13CAB1-FDCC-4708-89EB-E92EDC125712}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-cdbLPU
->>>>>>
-Attribute VB_Name = "cdbLPU"

-Option Explicit

-

-Public Type tLPU_COMMON

-    lpu As tLPU

-    bdgt As tBUDGET

-    i_hir As Long

-    hir() As tHIRURGIA

-    i_ter As Long

-    ter() As tTERAPIA

-    i_ACS As Long

-    ACS() As tACS

-    bdgt_LPU As Long

-    sale_HIR As Long

-    sale_TER As Long

-    sale_CRD As Long

-    sale_ALL As Long

-    pat_HIR As Long

-    pat_TER As Long

-    pat_CRD As Long

-    pat_ALL As Long     ' Сумма всех пациентов на клексане

-    pat_LPU As Long     ' Число потенциальных пациентов для продаж клексана

-End Type

-

-Function Get_LPU_CommonQTR(ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    Get_LPU_CommonQTR = dbGet_LPU_CommonQTR(dbConnection, lcd, objQTR)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_CommonQTR(dbConnection As Object, ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    i = dbGetAll_LPU_byQTR(dbConnection, allLPU, objQTR.entry_date, objQTR.rep_id, objQTR.rm_id)

-    dbGet_LPU_CommonQTR = i

-    If i > 0 Then

-        ReDim lcd(i)

-        For i = 1 To UBound(allLPU)

-            dbGet_LPU_Common dbConnection, lcd(i), allLPU(i), objQTR

-        Next i

-    End If

-End Function

-

-Sub Get_LPU_Common(ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    dbGet_LPU_Common dbConnection, lcd, cLPU, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbGet_LPU_Common(dbConnection As Object, ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-

-    lcd.lpu = cLPU

-    lcd.bdgt = dbGet_BDGT_Record(dbConnection, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    lcd.i_hir = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, lcd.hir, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    lcd.i_ter = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, lcd.ter, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    lcd.i_ACS = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, lcd.ACS, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    With lcd

-        .bdgt_LPU = .bdgt.bdgt_NFG + .bdgt.bdgt_NMG

-        .pat_LPU = 0

-        If .i_hir > 0 Then

-            .pat_HIR = .hir(1).patients_ambulator_clexan + .hir(1).patients_stationar_clexan

-            .sale_HIR = objQTR.ClxnH20mg * (.hir(1).patients_ambulator_clexan_20mg + .hir(1).patients_stationar_clexan_20mg)

-            .sale_HIR = .sale_HIR + objQTR.ClxnH40mg * (.hir(1).patients_ambulator_clexan_40mg + .hir(1).patients_stationar_clexan_40mg)

-            .pat_LPU = .pat_LPU + .hir(1).operations_per_quarter

-        End If

-        If .i_ter > 0 Then

-            .pat_TER = .ter(1).patients_ambulator_clexan + .ter(1).patients_stationar_clexan

-            .sale_TER = .pat_TER * objQTR.ClxnT40mg

-            .pat_LPU = .pat_LPU + .ter(1).patients_per_quarter

-        End If

-        If .i_ACS > 0 Then

-            .pat_CRD = .ACS(1).patients_stationar_clexan

-            .sale_CRD = .pat_CRD * objQTR.ClxnC_ACS

-            .pat_LPU = .pat_LPU + .ACS(1).patients_per_quarter

-        End If

-        .pat_ALL = .pat_HIR + .pat_TER + .pat_CRD

-        .sale_ALL = .sale_HIR + .sale_TER + .sale_CRD

-    End With

-End Sub

-

-<<<<<<
-======================
-CHRT_PIE
->>>>>>
-Attribute VB_Name = "CHRT_PIE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Unprotect

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Доля продаж: " & Range("title")

-    

-    On Error Resume Next

-    Range("P5:Q24").Sort _

-        Key1:=Range("Q5"), _

-        Order1:=xlDescending, _

-        Header:=xlGuess, _

-        OrderCustom:=1, _

-        MatchCase:=False, _

-        Orientation:=xlTopToBottom

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PLN_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PLN_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Динамика продаж: " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_BDGT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_BDGT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Бюджеты ЛПУ: " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-dlg_LPU_delete
->>>>>>
-Attribute VB_Name = "dlg_LPU_delete"

-Attribute VB_Base = "0{9C81F4D2-4ECF-46F5-999B-9801D572A12F}{B382508B-7F3D-4747-8407-0F75F6F265F5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlg_Mail
->>>>>>
-Attribute VB_Name = "dlg_Mail"

-Attribute VB_Base = "0{EA8CE4CE-AC2E-45BC-BAF8-1429E6242097}{575F0762-04F4-4F86-B98A-8E87E3424B0D}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dbREP_id
->>>>>>
-Attribute VB_Name = "dbREP_id"

-Public Type tREPID

-    rep_id As Long

-    rm_id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function GetAll_REPID_Records_by_QTR(ByRef all_REPID() As tREPID, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_REPID_Records_by_QTR = dbGetAll_REPID_Records_by_QTR(dbConnection, all_REPID, ent_date, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function Get_REPID_Record(rep_id As Long, rm_id As Long) As tREPID

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REPID_Record = dbGet_REPID_Record(dbConnection, rep_id, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_REPID_Records(ByRef all_REPID() As tREPID) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_REPID_Records = dbGetAll_REPID_Records(dbConnection, all_REPID)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function dbGet_REPID_Record(dbConnection As Object, rep_id As Long, rm_id As Long) As tREPID

-    

-    Dim sql As String

-    Dim objREPID As tREPID

-    

-    objREPID.FirstName = ""

-    objREPID.LastName = ""

-    objREPID.Region = 0

-    objREPID.City = 0

-    sql = "SELECT * FROM " & _

-          "rep WHERE rep_id=" & rep_id & " AND rm_id=" & rm_id

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREPID.rep_id = dbRecordset("rep_id")

-        objREPID.rm_id = dbRecordset("rm_id")

-        objREPID.FirstName = dbRecordset("firstname")

-        objREPID.LastName = dbRecordset("lastname")

-        objREPID.Region = dbRecordset("region")

-        objREPID.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REPID_Record = objREPID

-        

-End Function

-

-Function dbGetAll_REPID_Records_by_QTR(dbConnection As Object, ByRef all_REPID() As tREPID, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    Dim Where As String

-    

-    REPID_Count = 0

-    

-    Where = " WHERE lpu_budget.entry_date like '" & ent_date & "' " & _

-        "AND rep.rep_id=lpu.rep_id AND lpu.id=lpu_budget.lpu_id"

-    If rm_id <> 0 Then

-        Where = Where & " AND rep.rm_id=" & rm_id

-    End If

-    

-    getAll_REPID_SQL = "SELECT distinct rep.* FROM rep, lpu, lpu_budget" & Where

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM (" & getAll_REPID_SQL & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records_by_QTR = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Function dbGetAll_REPID_Records(dbConnection As Object, ByRef all_REPID() As tREPID) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    REPID_Count = 0

-    

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM rep"

-    getAll_REPID_SQL = "SELECT * FROM rep"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-cdbExport
->>>>>>
-Attribute VB_Name = "cdbExport"

-Option Explicit

-

-Function GetDBSN() As String

-    Dim n As Long

-    Randomize Timer

-    n = Int((100000000 - 1000000 + 1) * Rnd + 1000000)

-    GetDBSN = Dec2ThirtySix(n)

-End Function

-

-Sub dbExport()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim old_file As String

-    

-    On Error GoTo ErrHandler

-    

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    old_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & "*.*"

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & GetDBSN() & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.DeleteFile old_file, True

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Данные экспортированы в файл:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для передачи", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-Exit Sub

-

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-<<<<<<
-======================
-mRegs
->>>>>>
-Attribute VB_Name = "mRegs"

-Option Explicit

-

-Function GetRegionName(idx As Integer) As String

-    GetRegionName = Worksheets(REGS_SHEET).Range("LST_REGIONS").Cells(idx + 1, 1).Text

-End Function

-

-Function GetCityName(idx_reg As Integer, idx_city As Integer) As String

-    GetCityName = Worksheets(REGS_SHEET).Range("CITY_TABLES").Offset(idx_city + 1, idx_reg * 2).Text

-End Function

-

-Sub testReg()

-    Dim r As Integer

-    Dim c As Integer

-    Dim s As String

-    

-    r = 3

-    c = 3

-    s = GetRegionName(r)

-    s = s & ", " & GetCityName(r, c)

-    MsgBox s

-End Sub

-

-<<<<<<
-======================
-RM_QTR
->>>>>>
-Attribute VB_Name = "RM_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CRGN_QT As Integer = 0

-Const CRGN_PLN As Integer = 2

-Const CRGN_FCT As Integer = 3

-Const CRGN_BDG As Integer = 4

-Const CRGN_LPU As Integer = 5

-Const CRGN_REP As Integer = 6

-Const CRGN_HIR As Integer = 7

-Const CRGN_TER As Integer = 8

-Const CRGN_CRD As Integer = 9

-Const CRGN_CLXN_BDG As Integer = 10

-Const CRGN_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Const LOCAL_ENT_DATE As String = "B11"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("RM_QTR")

-        s = .Range("D5") & " " & .Range("D4") & ", " & .Range("H4") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub update_history()

-    Dim objRGN() As tREGION

-    Dim i As Long

-    Dim r As Range

-    Dim cRMan As tREGMAN

-

-    cRMan = Get_REGMAN_Record(Range("RM_ID"))

-    

-    Range("D4") = cRMan.LastName

-    Range("D5") = cRMan.FirstName

-

-    Range("H4") = GetRegionName(cRMan.Region)

-    

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetRGN_COMM_DATA(objRGN, Range("RM_ID"))

-    

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objRGN)

-            r.Offset(i - 1, CRGN_QT) = objRGN(i).ent_date

-            r.Offset(i - 1, CRGN_FCT) = objRGN(i).total_SALE

-            r.Offset(i - 1, CRGN_PLN) = objRGN(i).sale_PLAN

-            r.Offset(i - 1, CRGN_BDG) = objRGN(i).total_BDGT

-            r.Offset(i - 1, CRGN_LPU) = objRGN(i).total_LPU

-            r.Offset(i - 1, CRGN_REP) = objRGN(i).total_REP

-            r.Offset(i - 1, CRGN_HIR) = objRGN(i).total_HIR

-            r.Offset(i - 1, CRGN_TER) = objRGN(i).total_TER

-            r.Offset(i - 1, CRGN_CRD) = objRGN(i).total_ACS

-            If objRGN(i).total_BDGT <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_BDG) = objRGN(i).total_SALE / objRGN(i).total_BDGT

-            End If

-            If objRGN(i).total_BDGT_NMG <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_NMG) = objRGN(i).total_SALE / objRGN(i).total_BDGT_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRGN_CRD + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-

-Sub Draw_PLN_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_FCT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PLN_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Draw_BDGT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_CLXN_NMG + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_BDGT_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Public Sub cbxRM_QtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR_RM

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR_RM

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR_RM

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = RM_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CRGN_QT + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    If r = "" Then

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = currRange.address

-    End If

-    Cancel = True

-    btRM_QTR_Do_IT

-End Sub

-

-<<<<<<
-======================
-dbREG_MAN
->>>>>>
-Attribute VB_Name = "dbREG_MAN"

-Option Explicit

-

-Public Type tREGMAN

-    rm_id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function Get_REGMAN_Record(rm_id As Long) As tREGMAN

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REGMAN_Record = dbGet_REGMAN_Record(dbConnection, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Sub Set_REGMAN_Record(cREGMAN As tREGMAN)

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbSet_REGMAN_Record dbConnection, cREGMAN

-'    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_REGMAN_Record(dbConnection As Object, rm_id As Long) As tREGMAN

-    

-    Dim sql As String

-    Dim objREGMAN As tREGMAN

-    

-    objREGMAN.FirstName = ""

-    objREGMAN.LastName = ""

-    objREGMAN.Region = 0

-    objREGMAN.City = 0

-    objREGMAN.rm_id = rm_id

-    sql = "SELECT * FROM " & _

-          "reg_man WHERE mgr_id=" & rm_id

-          

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREGMAN.FirstName = dbRecordset("firstname")

-        objREGMAN.LastName = dbRecordset("lastname")

-        objREGMAN.Region = dbRecordset("region")

-        objREGMAN.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REGMAN_Record = objREGMAN

-        

-End Function

-

-Public Sub dbSet_REGMAN_Record(dbConnection As Object, ByRef objREGMAN As tREGMAN)

-  

-'    Dim DeleteSQL As String

-'    Dim InsertSQL As String

-'

-'    DeleteSQL = "DELETE FROM reg_man"

-'    InsertSQL = "INSERT INTO reg_man (firstname, lastname, region, city) VALUES (" & _

-'    "'" & objREGMAN.FirstName & "', " & _

-'    "'" & objREGMAN.LastName & "', " & _

-'    objREGMAN.Region & ", " & _

-'    objREGMAN.City & ")"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-       

-End Sub

-

-

-

-<<<<<<
-======================
-dbDatabaseMerge
->>>>>>
-Attribute VB_Name = "dbDatabaseMerge"

-Option Explicit

-

-Public Type tDBFIELD

-    Name As String

-End Type

-

-Public Type tDBTABLE

-    Name As String

-    field() As tDBFIELD

-End Type

-

-

-Function dbGetConnection(dbAccessFileFullPath As String) As Object

-    Dim dbConnection As Object

-    Dim dbAccessFilePasswd As String

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFileFullPath & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    Set dbGetConnection = dbConnection

-End Function

-

-Sub dbCloseOpenedConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteOpenedSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-Function dbMergeREP(from_dbConnection As Object, to_dbConnection As Object) As Long

-

-    Dim getRecordset As Object

-    Dim getREPData_SQL As String

-    Dim REP_fn As String

-    Dim REP_ln As String

-    Dim REP_region As String

-    Dim REP_city As String

-

-

-    getREPData_SQL = "SELECT * FROM rep"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getREPData_SQL, from_dbConnection

-        

-        If Not getRecordset.BOF Then

-            REP_fn = getRecordset("firstname")

-            REP_ln = getRecordset("lastname")

-            REP_city = getRecordset("city")

-            REP_region = getRecordset("region")

-        Else

-            MsgBox "There is no information about rep! This database cannot be merged!!!"

-            dbMergeREP = -1

-            Exit Function

-        End If

-    

-    Dim insertRecordset As Object

-    Set insertRecordset = CreateObject("ADODB.Recordset")

-        

-    insertRecordset.Open "rep", to_dbConnection, 2, 2

-    insertRecordset.addnew

-        

-    insertRecordset("firstname") = REP_fn

-    insertRecordset("lastname") = REP_ln

-    insertRecordset("region") = REP_region

-    insertRecordset("city") = REP_city

-    insertRecordset.Update

-    insertRecordset.MoveLast

-    'new ID

-    

-    dbMergeREP = insertRecordset("rep_id")

-    

-End Function

-

-Sub dbMergeLPU(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getLPU_SQL As String

-    Dim getRecordset As Object

-    Dim idx As Long

-    idx = 1

-    

-    getLPU_SQL = "SELECT * FROM lpu"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getLPU_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            ReDim Preserve objLPU(1 To idx)

-            objLPU(idx).old_lpu_id = getRecordset("id")

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "lpu", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("name") = getRecordset("name")

-            insRS("address") = getRecordset("address")

-            insRS("beds") = getRecordset("beds")

-            insRS.Update

-            insRS.MoveLast

-            'new ID

-            

-            objLPU(idx).new_lpu_id = insRS("id")

-                        

-            idx = idx + 1

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about LPU! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-

-Sub dbMergeLPURelated(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object)

-

-    ' 6 tables to change

-    Dim tables(1 To 5) As tDBTABLE

-    

-    'lpu budget

-    tables(1).Name = "lpu_budget"

-    ReDim tables(1).field(1 To 4)

-    

-    tables(1).field(1).Name = "entry_date"

-    tables(1).field(2).Name = "bdgt_NMG"

-    tables(1).field(3).Name = "bdgt_NFG"

-    tables(1).field(4).Name = "sale_PLAN"

-    

-    'lpu hir

-    tables(2).Name = "lpu_hir"

-    ReDim tables(2).field(1 To 13)

-    

-    tables(2).field(1).Name = "entry_date"

-    tables(2).field(2).Name = "operations_per_quarter"

-    tables(2).field(3).Name = "risk_percent"

-    tables(2).field(4).Name = "patients_with_risk_ON"

-    tables(2).field(5).Name = "patients_ambulator"

-    tables(2).field(6).Name = "patients_ambulator_nmg"

-    tables(2).field(7).Name = "patients_ambulator_clexan"

-    tables(2).field(8).Name = "patients_ambulator_clexan_40mg"

-    tables(2).field(9).Name = "patients_ambulator_clexan_20mg"

-    tables(2).field(10).Name = "patients_stationar_nmg"

-    tables(2).field(11).Name = "patients_stationar_clexan"

-    tables(2).field(12).Name = "patients_stationar_clexan_40mg"

-    tables(2).field(13).Name = "patients_stationar_clexan_20mg"

-    

-    

-    'lpu acs

-    tables(3).Name = "lpu_acs"

-    ReDim tables(3).field(1 To 5)

-    

-    tables(3).field(1).Name = "entry_date"

-    tables(3).field(2).Name = "patients_with_geparins"

-    tables(3).field(3).Name = "patients_per_quarter"

-    tables(3).field(4).Name = "patients_stationar_nmg"

-    tables(3).field(5).Name = "patients_stationar_clexan"

-    

-    'lpu acs

-    tables(4).Name = "lpu_im"

-    ReDim tables(4).field(1 To 5)

-    

-    tables(4).field(1).Name = "entry_date"

-    tables(4).field(2).Name = "patients_with_geparins"

-    tables(4).field(3).Name = "patients_per_quarter"

-    tables(4).field(4).Name = "patients_stationar_nmg"

-    tables(4).field(5).Name = "patients_stationar_clexan"

-    

-    

-    'lpu acs

-    tables(5).Name = "lpu_ter"

-    ReDim tables(5).field(1 To 9)

-    

-    tables(5).field(1).Name = "entry_date"

-    tables(5).field(2).Name = "patients_per_quarter"

-    tables(5).field(3).Name = "risk_percent"

-    tables(5).field(4).Name = "patients_with_risk_ON"

-    tables(5).field(5).Name = "patients_ambulator"

-    tables(5).field(6).Name = "patients_ambulator_nmg"

-    tables(5).field(7).Name = "patients_ambulator_clexan"

-    tables(5).field(8).Name = "patients_stationar_nmg"

-    tables(5).field(9).Name = "patients_stationar_clexan"

-    

-    

-    

-    Dim tbl_idx As Integer

-    

-    For tbl_idx = 1 To UBound(tables)

-        

-        Dim getSQL As String

-        Dim getRS As Object

-        

-        

-        

-        Set getRS = CreateObject("ADODB.Recordset")

-        

-        getSQL = "SELECT * FROM " & tables(tbl_idx).Name

-        getRS.Open getSQL, from_db

-        

-        If Not getRS.BOF Then

-            Do While Not getRS.EOF

-                Dim insRS As Object

-                Set insRS = CreateObject("ADODB.Recordset")

-                

-                insRS.Open tables(tbl_idx).Name, to_db, 2, 2

-                insRS.addnew

-                Dim fld_idx As Integer

-    

-                    For fld_idx = 1 To UBound(tables(tbl_idx).field)

-                        insRS(tables(tbl_idx).field(fld_idx).Name) = getRS(tables(tbl_idx).field(fld_idx).Name)

-                        insRS("lpu_id") = findNewLPU_IDByOld(objLPU, getRS("lpu_id"))

-                    Next fld_idx

-                    

-                insRS.Update

-                insRS.MoveLast

-                getRS.MoveNext

-            Loop

-        End If

-        

-        

-    Next tbl_idx

-

-End Sub

-

-Function findNewLPU_IDByOld(objLPU() As tLPUCONVERTION, old_id As Long)

-

-Dim i As Integer

-For i = 1 To UBound(objLPU)

-    If objLPU(i).old_lpu_id = old_id Then

-        findNewLPU_IDByOld = objLPU(i).new_lpu_id

-        Exit Function

-    End If

-Next i

-

-findNewLPU_IDByOld = -1

-End Function

-

-

-

-

-

-Sub dbMergeQTR(from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getQTR_SQL As String

-    Dim getRecordset As Object

-    

-    getQTR_SQL = "SELECT * FROM quarter"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getQTR_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "quarter", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("entry_date") = getRecordset("entry_date")

-            insRS("sale_plan") = getRecordset("sale_plan")

-            insRS("ClxnH20mg") = getRecordset("ClxnH20mg")

-            insRS("ClxnH40mg") = getRecordset("ClxnH40mg")

-            insRS("ClxnT40mg") = getRecordset("ClxnT40mg")

-            insRS("ClxnC_IM") = getRecordset("ClxnC_IM")

-            insRS("ClxnC_ACS") = getRecordset("ClxnC_ACS")

-            

-            

-            insRS.Update

-            

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about quarter budget! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-dbMerge
->>>>>>
-Attribute VB_Name = "dbMerge"

-Option Explicit

-

-Public Type tLPUCONVERTION

-    old_lpu_id As Long

-    new_lpu_id As Long

-End Type

-

-Sub Merge_BackUp_All_Data()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim time_stump As String

-    

-    On Error GoTo ErrHandler

-    

-    time_stump = Format(Date, "yy-mm-dd_") & Format(Time, "hh-mm")

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_BACKUPNAME & time_stump & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Старые данные сохранены в файле:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для восстанеовления данных в случае утери", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-    Exit Sub

-    

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-

-Sub Merge_Clear_All_Data(access_file_full_path As String)

-    

-    Dim db As Object

-    Dim tables_to_clear() As String

-    On Error GoTo ErrHandler

-    

-    ReDim tables_to_clear(1 To 10)

-    tables_to_clear(1) = "rep"

-    tables_to_clear(2) = "lpu"

-    tables_to_clear(3) = "lpu_budget"

-    tables_to_clear(4) = "lpu_hir"

-    tables_to_clear(5) = "lpu_ter"

-    tables_to_clear(6) = "lpu_acs"

-    tables_to_clear(7) = "lpu_im"

-    tables_to_clear(8) = "quarter"

-    tables_to_clear(9) = "quarter_rm"

-    tables_to_clear(10) = "reg_man"

-    

-    Set db = dbGetConnection(access_file_full_path)

-

-    Dim i As Integer

-    

-    For i = 1 To UBound(tables_to_clear)

-        

-        If tables_to_clear(i) <> "" Then

-            Dim Clear_SQL As String

-            Clear_SQL = "DELETE FROM " & tables_to_clear(i)

-            dbExecuteOpenedSQL db, Clear_SQL

-        Else

-            'do nothing or show message

-        End If

-    Next i

-    

-    dbCloseOpenedConnection db

-    Set db = Nothing

-    

-Exit Sub

-

-ErrHandler:

-    MsgBox "something wrong: " & err.Description

-    Resume Next

-    

-End Sub

-

-Function MergeREP(from_file As String, to_file As String) As Long

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    Dim new_rep_id As Long

-

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    MergeREP = dbMergeREP(db1, db2)

-    'MsgBox "new rep ID is " & new_rep_id

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Function

-

-Sub MergeQTR(from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeQTR db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-

-Sub MergeLPU(objLPU() As tLPUCONVERTION, from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeLPU objLPU, db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-Sub MergeLPURelated(objLPU() As tLPUCONVERTION, from_file As String, to_file As String)

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    dbMergeLPURelated objLPU, db1, db2

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-

-End Sub

-

-Sub MergeGlobal(rep_files() As String, rm_file As String)

-

-    Dim i As Integer

-    'clear output file content

-    Merge_Clear_All_Data rm_file

-    

-    For i = 1 To UBound(rep_files)

-        

-        Dim rep_file As String

-        'setup input and output files

-        rep_file = rep_files(i)

-        

-        Dim new_rep_id As Long

-        ' insert REP data and get new rep_id

-        new_rep_id = MergeREP(rep_file, rm_file)

-        

-        Dim objLPU() As tLPUCONVERTION

-        'insert all LPU using new generated rep_id

-        'and populate objLPU old->new relation object

-        

-        MergeLPU objLPU, rep_file, rm_file, new_rep_id

-        'insert quarter data using new rep_id

-        MergeQTR rep_file, rm_file, new_rep_id

-        

-        

-        ' and.... insert all another data (5 tables excl version and hw)

-        'using objLPU old->new relation object

-        MergeLPURelated objLPU, rep_file, rm_file

-    

-    

-    Next i

-    

-End Sub

-

-Function GetDBList(MyPath() As String, ByRef dblist() As String) As Integer

-    Dim i As Integer

-    Dim MyName, MyMask

-    MyMask = MyPath(0) & MyPath(1) & PROGRAM_DATAEXT

-    i = 0

-    MyName = Dir(MyMask)      ' Retrieve the first entry.

-    Do While MyName <> ""    ' Start the loop.

-        ' Ignore the current directory and the encompassing directory.

-        If MyName <> "." And MyName <> ".." Then

-            ' Use bitwise comparison to make sure MyName is a directory.

-            i = i + 1

-            ReDim Preserve dblist(i)

-            dblist(i) = MyPath(0) & MyName

-        End If

-        MyName = Dir    ' Get next entry.

-    Loop

-    GetDBList = i

-End Function

-

-<<<<<<
-======================
-cdbPRJ
->>>>>>
-Attribute VB_Name = "cdbPRJ"

-Option Explicit

-

-Type tPROJECT

-    total_SALE  As Long ' общий объем продаж

-    total_BDGT  As Long ' бюджет всех ЛПУ

-    total_BDGT_NMG As Long ' бюджет всех ЛПУ на НМГ

-    total_LPU   As Long ' число ЛПУ

-    total_REP   As Long ' число репов

-    total_RM    As Long ' число репов

-    total_BEDS  As Long ' общее число коек

-    total_HIR   As Long '  общее число пациентов на клексане в хирургии

-    total_TER   As Long '  общее число пациентов на клексане в терапии

-    total_ACS   As Long '  общее число пациентов на клексане в кардиологии

-    sale_PLAN   As Long '  план продаж Авентиса

-    objRGN() As tREGION

-End Type

-

-Function GetPRJ_COMM_DATA(ByRef prj_data As tPROJECT) As Integer

-    Dim i As Integer

-    i = GetRGN_COMM_DATA(prj_data.objRGN, 0)

-    GetPRJ_COMM_DATA = i

-    If i > 0 Then

-        With prj_data

-            .sale_PLAN = 0

-            .total_ACS = 0

-            .total_BDGT = 0

-            .total_BDGT_NMG = 0

-            .total_BEDS = 0

-            .total_HIR = 0

-            .total_LPU = 0

-            .total_REP = 0

-            .total_RM = 0

-            .total_SALE = 0

-            .total_TER = 0

-            For i = 1 To UBound(prj_data.objRGN)

-                

-            Next i

-        End With

-    End If

-

-End Function

-

-<<<<<<
-======================
-dbQTR_RM
->>>>>>
-Attribute VB_Name = "dbQTR_RM"

-Option Explicit

-

-Public Type tQTRRM

-    id As Long

-    entry_date As String

-    rm_id As Long

-    sale_PLAN As Long

-End Type

-

-

-Sub Insert_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objQTRRM.id <> 0 Then

-        dbUpdate_QTRRM_Record dbConnection, objQTRRM

-    Else

-        dbInsert_QTRRM_Record dbConnection, objQTRRM

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-Function Get_QTRRM_Record(ent_date As String) As tQTRRM

-    Dim dbConnection As Object

-    Dim allQTRRM() As tQTRRM

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    i = dbGetAll_QTRRM_Records(dbConnection, allQTRRM, ent_date)

-    If i <> 0 Then

-        Get_QTRRM_Record = allQTRRM(1)

-    End If

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTRRM_Records(ByRef all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_QTRRM_Records = dbGetAll_QTRRM_Records(dbConnection, all_QTRRM, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_QTRRM_Record dbConnection, objQTRRM

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objQTRRM.ID <> 0 then updatre else insert

-Sub dbInsert_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "quarter_rm", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objQTRRM

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("sale_plan") = .sale_PLAN

-        dbRecordset("rm_id") = .rm_id

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objQTRRM.id = dbRecordset("id")

-

-End Sub

-

-Sub dbUpdate_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim Update_SQL As String

-    

-    With objQTRRM

-        Update_SQL = "UPDATE quarter_rm SET " & _

-            "entry_date='" & .entry_date & "'" & "," & _

-            "rm_id=" & .rm_id & "," & _

-            "sale_plan=" & .sale_PLAN & "," & _

-            " WHERE id=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if ent_date = % then all_records

-Function dbGetAll_QTRRM_Records(dbConnection As Object, all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    

-    Dim getCount_QTRRM_SQL As String

-    Dim getAll_QTRRM_SQL As String

-    Dim QTRRM_Count As Long

-    QTRRM_Count = 0

-    

-    getCount_QTRRM_SQL = "SELECT COUNT(*) AS QTRRM_TOTAL FROM quarter_rm WHERE entry_date like '" & ent_date & "'"

-    getAll_QTRRM_SQL = "SELECT * FROM quarter_rm WHERE entry_date like '" & ent_date & "' ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTRRM_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTRRM_Count = dbRecordset("QTRRM_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_QTRRM_Records = QTRRM_Count

-    

-    If QTRRM_Count > 0 Then

-        'we have records

-        ReDim all_QTRRM(1 To QTRRM_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTRRM_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTRRM As tQTRRM

-                 With tmp_QTRRM

-                    .entry_date = dbRecordset("entry_date")

-                    .rm_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .id = dbRecordset("id")

-                 End With

-                 

-                 all_QTRRM(index) = tmp_QTRRM

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM quarter_rm " & _

-    "WHERE id=" & objQTRRM.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-    

-    'delete related budget entries

-    MsgBox "remember delete related"

-'    dbDelete_BDGT_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Hir_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Ter_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_ACS_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-       

-End Sub

-

-

-<<<<<<
-======================
-REP_LIST
->>>>>>
-Attribute VB_Name = "REP_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Const LOCAL_ENT_DATE As String = "C10"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-

-Public Function getCurrentREP_ID() As Long

-    Dim r As Range

-

-    With Worksheets("REP_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CREP_ID)

-    End With

-

-    getCurrentREP_ID = r

-End Function

-

-Public Sub REP_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Rep_Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Rep_Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Rep_Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Rep_Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectREP_LPU(rep_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    Range("JUMP") = "LPU_LIST"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-        .Range("RM_ID") = rm_id

-        .setEnt_date (getEnt_date())

-    End With

-End Sub

-

-Public Sub SelectREP_QTR(rep_id As Long)

-    Dim vo As Boolean

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    Range("JUMP") = "REP_QTR"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("REP_QTR")

-        .Range("VIEW_ONLY") = vo

-        .Range("RM_ID") = rm_id

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateREPList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim rep_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CREP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CREP_AREA).row, CREP_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    rep_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CREP_AREA).Column

-    

-    If i < 4 Then

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 1

-    Else

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 2

-    End If

-    

-    If rep_id = 0 Then

-        Range("LAST_FOCUS") = Range(CREP_AREA).address

-    End If

-

-    If rep_id = 0 Then

-        i = CREP_NAME

-        Range("JUMP") = ""

-    Else

-        btREP_LIST_DO_IT

-    End If

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateREPList()

-    Dim rcd() As tREPID_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-

-    ent_date = getEnt_date

-

-    Dim rm_struc As tREGMAN

-    

-    i = Range("RM_ID")

-    rm_struc = Get_REGMAN_Record(i)

-    

-    Range("C4") = rm_struc.LastName

-    Range("C5") = rm_struc.FirstName

-

-    Range("G5") = GetRegionName(rm_struc.Region)

-    

-    i = Get_REP_CommonList_by_QTR(rcd, ent_date, Range("RM_ID"))

-

-    

-    With ThisWorkbook.Worksheets("REP_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(rcd)

-            r.Offset(i - 1, CREP_NAME) = rcd(i).rep.FirstName & " " & rcd(i).rep.LastName

-            r.Offset(i - 1, CREP_ID) = rcd(i).rep.rep_id

-            r.Offset(i - 1, CREP_BEDS) = rcd(i).qtrs(1).c_beds

-

-            r.Offset(i - 1, CREP_NFG) = rcd(i).qtrs(1).c_bdgt_NFG

-            r.Offset(i - 1, CREP_NMG) = rcd(i).qtrs(1).c_bdgt_NMG

-

-            r.Offset(i - 1, CREP_PLAN) = rcd(i).qtrs(1).qtr.sale_PLAN

-

-            r.Offset(i - 1, CREP_HIR) = rcd(i).qtrs(1).c_pat_HIR

-            r.Offset(i - 1, CREP_TER) = rcd(i).qtrs(1).c_pat_TER

-            r.Offset(i - 1, CREP_CAR) = rcd(i).qtrs(1).c_pat_CRD

-            r.Offset(i - 1, CREP_FACT) = rcd(i).qtrs(1).c_sale_ALL

-            r.Offset(i - 1, CREP_PAT_LPU) = rcd(i).qtrs(1).c_pat_LPU

-            r.Offset(i - 1, CREP_BDGT) = rcd(i).qtrs(1).c_bdgt_LPU

-            If rcd(i).qtrs(1).c_bdgt_LPU > 0 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = rcd(i).qtrs(1).c_sale_ALL / rcd(i).qtrs(1).c_bdgt_LPU

-            End If

-            If r.Offset(i - 1, CREP_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-

-

-<<<<<<
-======================
-mREP_LIST
->>>>>>
-Attribute VB_Name = "mREP_LIST"

-Option Explicit

-

-Public Const CREP_AREA As String = "B12"

-Public Const CREP_NAME As Integer = 0

-Public Const CREP_NAME1 As Integer = 1

-Public Const CREP_NAME2 As Integer = 2

-Public Const CREP_ID As Integer = 3

-Public Const CREP_BEDS As Integer = 4

-Public Const CREP_NFG As Integer = 5

-Public Const CREP_NMG As Integer = 6

-Public Const CREP_HIR As Integer = 7

-Public Const CREP_TER As Integer = 8

-Public Const CREP_CAR As Integer = 9

-Public Const CREP_FACT As Integer = 10

-Public Const CREP_PLAN As Integer = 11

-Public Const CREP_PAT_LPU As Integer = 16

-Public Const CREP_BDGT As Integer = 17

-

-

-Const LOCAL_ENT_DATE As String = "C10"

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Sub EditREP(cRep As tREPID, ent_date As String)

-    NoFunc

-End Sub

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("REP_LIST")

-        s = .Range("C5") & " " & .Range("C4") & ", " & .Range("G5") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub Rep_Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_LPU_BBL").Range("title") = MakeChartTitle

-End Sub

-

-Sub Rep_Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CREP_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CREP_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CREP_FACT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PIE").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rep_Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CREP_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CREP_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CREP_HIR + 1)

-            psum = psum + src.Cells(i, CREP_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CREP_TER + 1)

-            psum = psum + src.Cells(i, CREP_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CREP_CAR + 1)

-            psum = psum + src.Cells(i, CREP_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CREP_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rep_Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CREP_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CREP_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CREP_HIR + 1)

-            psum = psum + src.Cells(i, CREP_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CREP_TER + 1)

-            psum = psum + src.Cells(i, CREP_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CREP_CAR + 1)

-            psum = psum + src.Cells(i, CREP_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CREP_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU_A").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub btREP_RET_IT()

-    With Worksheets("REP_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = "RM_QTR"

-    End With

-    Dim str As String

-    str = Range("ret_addr")

-    ThisWorkbook.Worksheets(str).Activate

-End Sub

-

-

-Sub btREP_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim rep_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("REP_LST_DETALS")

-    With Worksheets("REP_LIST")

-        rep_id = .getCurrentREP_ID

-        

-        Select Case i

-            Case 1:

-                .SelectREP_QTR rep_id

-            Case 2:

-                ent_date = .getEnt_date()

-                .SelectREP_LPU rep_id, ent_date

-        End Select

-    End With

-    

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-

-

-

-<<<<<<
-======================
-cdbREP
->>>>>>
-Attribute VB_Name = "cdbREP"

-Option Explicit

-

-Public Type tREPID_COMMON

-    rep As tREPID

-    i_qtrs As Integer

-    qtrs() As tQTR_COMMON

-End Type

-

-Function Get_REP_CommonList_by_QTR(ByRef rcd() As tREPID_COMMON, ent_date As String, rm_id As Long) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_REP_CommonList_by_QTR = dbGet_REP_CommonList_by_QTR(dbConnection, rcd, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_REP_CommonList_by_QTR(dbConnection As Object, ByRef rcd() As tREPID_COMMON, ent_date As String, rm_id As Long) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim k As Long

-    Dim allREPID() As tREPID

-    

-    i = dbGetAll_REPID_Records_by_QTR(dbConnection, allREPID, ent_date, rm_id)

-    dbGet_REP_CommonList_by_QTR = i

-    If i > 0 Then

-        ReDim rcd(i)

-        For i = 1 To UBound(allREPID)

-            rcd(i).rep = allREPID(i)

-            rcd(i).i_qtrs = Get_QTR_CommonList_by_REP(rcd(i).qtrs, ent_date, allREPID(i).rep_id, allREPID(i).rm_id)

-        Next i

-    End If

-End Function

-

-

-

-<<<<<<
-======================
-CHRT_PAT_LPU_A
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU_A"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Пациенты на Клексане(чел.): " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-cdbRegion
->>>>>>
-Attribute VB_Name = "cdbRegion"

-Option Explicit

-

-Type tREGION

-    ent_date As String

-    rm_id As Long

-    total_SALE As Long ' общий объем продаж

-    total_BDGT As Long ' бюджет всех ЛПУ

-    total_BDGT_NMG As Long ' бюджет всех ЛПУ на НМГ

-    total_LPU As Long ' число ЛПУ

-    total_REP   As Long ' число репов

-    total_BEDS As Long ' общее число коек

-    total_HIR As Long '  общее число пациентов на клексане в хирургии

-    total_TER As Long '  общее число пациентов на клексане в терапии

-    total_ACS As Long '  общее число пациентов на клексане в кардиологии

-    sale_PLAN As Long '  план продаж Авентиса

-End Type

-

-Function GetRGN_COMM_DATA(ByRef reg_data() As tREGION, rm_id As Long) As Integer

-    Dim q_date() As String

-    Dim q_count As Integer, i As Integer

-    

-    q_count = getAllQTRNames(q_date, rm_id)

-    If q_count > 0 Then

-        ReDim reg_data(q_count)

-        For i = 1 To q_count

-            Dim current_REP_count As Integer

-            reg_data(i).rm_id = rm_id

-            reg_data(i).ent_date = q_date(i)

-            current_REP_count = getREGION_by_QTR(q_date(i), reg_data(i), rm_id)

-        Next i

-    End If

-    

-    GetRGN_COMM_DATA = q_count

-End Function

-

-' if rm_id = 0 then gets all records

-Function getAllQTRNames(ByRef qtr_lst() As String, rm_id As Long) As Integer

-    

-    Dim sql As String

-    Dim i As Integer

-    Dim db As Object, rs As Object

-    

-    sql = "SELECT DISTINCT entry_date FROM lpu_budget"

-    

-    If rm_id <> 0 Then

-        sql = sql & " WHERE rm_id=" & rm_id

-    End If

-    

-    i = 0

-    

-    dbOpenConnection db

-    Set rs = CreateObject("ADODB.Recordset")

-    

-    rs.Open sql, db

-        

-        If Not rs.BOF Then

-            Do While Not rs.EOF

-                i = i + 1

-                ReDim Preserve qtr_lst(i)

-                qtr_lst(i) = rs("entry_date")

-                rs.MoveNext

-            Loop

-        Else

-            getAllQTRNames = 0

-            Exit Function

-        End If

-    getAllQTRNames = i

-    dbCloseConnection db

-End Function

-

-Function getREGION_by_QTR(ent_date As String, treg As tREGION, rm_id As Long) As Integer

-    Dim rep_count As Integer

-    rep_count = 0

-    

-    Dim reps() As tQTR_COMMON

-    rep_count = Get_QTR_CommonList_by_REP(reps, ent_date, 0, rm_id)

-    

-    treg.ent_date = ent_date

-    treg.total_BDGT = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.total_BDGT_NMG = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.sale_PLAN = 0 ' quarter.sale_plan

-    treg.total_SALE = 0 'summ of

-    ' hir = (amb40+st40)*pr40 + (amb20+st20)*pr20

-    'ter (amb_clx+stat_clx)*price

-    ' acs xxx

-    'price per rep

-    treg.total_HIR = 0 'patiens clxn

-    treg.total_TER = 0 'patiens clxn

-    treg.total_ACS = 0 'patiens clxn

-    treg.total_LPU = 0 'lpu

-    treg.total_BEDS = 0 'lpu.beds

-    treg.total_REP = 0 '

-    

-    If rep_count > 0 Then

-        Dim i As Integer

-        

-        For i = 1 To UBound(reps)

-            ' current rep is reps(i)

-            With reps(i)

-                treg.total_BDGT = treg.total_BDGT + .c_bdgt_NFG + .c_bdgt_NMG

-                treg.total_BDGT_NMG = treg.total_BDGT_NMG + .c_bdgt_NMG

-                treg.sale_PLAN = treg.sale_PLAN + .qtr.sale_PLAN

-                treg.total_SALE = treg.total_SALE + .c_sale_ALL

-                treg.total_HIR = treg.total_HIR + .c_pat_HIR

-                treg.total_TER = treg.total_TER + .c_pat_TER

-                treg.total_ACS = treg.total_ACS + .c_pat_CRD

-                treg.total_LPU = treg.total_LPU + .i_lcd

-                treg.total_BEDS = treg.total_BEDS + .c_beds

-                treg.total_REP = treg.total_REP + 1

-            End With

-            

-        Next i

-        

-    End If

-    

-    getREGION_by_QTR = treg.total_REP

-End Function

-

-<<<<<<
-======================
-mRM_QTR
->>>>>>
-Attribute VB_Name = "mRM_QTR"

-Option Explicit

-

-Sub btRM_QTR_Do_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    Dim i As Integer

-    Dim def_dir As String

-    Dim flist() As String

-    

-    idx = Worksheets(VAR_SHEET).Range("RM_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-'            def_dir = GetWBPath(ThisWorkbook.FullName)

-'            If GetImportDirectory(def_dir, flist) Then

-'                Dim db_list() As String

-'                i = GetDBList(flist, db_list)

-'                If i > 0 Then

-'                    ImportFromRegionalManagers db_list, GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-'                End If

-'            End If

-'            Worksheets(RM_QTR_SHEET).update_history

-        Case 2

-            Worksheets("REP_LIST").Range("ret_addr") = "RM_QTR"

-            Worksheets("REP_LIST").setEnt_date (Worksheets(RM_QTR_SHEET).getEnt_date())

-            Worksheets("REP_LIST").Range("RM_ID") = Worksheets(RM_QTR_SHEET).Range("RM_ID")

-            Worksheets("REP_LIST").Range("VIEW_ONLY") = True

-

-            Worksheets("REP_LIST").Select

-        Case 3

-            MsgBox "Функция не доступна", vbOKOnly, PROGRAM_NAME

-    End Select

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-End Sub

-

-Sub btRM_QTR_RET_IT()

-    Dim str As String

-    str = Range("ret_addr")

-    ThisWorkbook.Worksheets(str).Activate

-End Sub

-

-<<<<<<
-======================
-mImport
->>>>>>
-Attribute VB_Name = "mImport"

-    Option Explicit

-

-Const OFN_ALLOWMULTISELECT As Long = 512

-Const OFN_EXPLORER As Long = 524288

-Const OFN_HIDEREADONLY As Long = 4

-Const OFN_NONETWORKBUTTON As Long = 131072

-Const OFN_READONLY As Long = 1

-       

-Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _

-    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

-

-Private Type OPENFILENAME

-    lStructSize As Long

-    hWndOwner As Long

-    hInstance As Long

-    lpstrFilter As String

-    lpstrCustomFilter As String

-    nMaxCustFilter As Long

-    nFilterIndex As Long

-    lpstrFile As String

-    nMaxFile As Long

-    lpstrFileTitle As String

-    nMaxFileTitle As Long

-    lpstrInitialDir As String

-    lpstrTitle As String

-    flags As Long

-    nFileOffset As Integer

-    nFileExtension As Integer

-    lpstrDefExt As String

-    lCustData As Long

-    lpfnHook As Long

-    lpTemplateName As String

-End Type

-

-Function GetImportDirectory(DB_dir As String, flist() As String) As Boolean

-    Dim OpenFile As OPENFILENAME

-    Dim lReturn As Long

-    Dim sFilter As String

-    

-    OpenFile.lStructSize = Len(OpenFile)

-    '         OpenFile.hwndOwner = Form1.hWnd

-    '         OpenFile.hInstance = App.hInstance

-    sFilter = "Clexane Data Files" & Chr(0) & PROGRAM_IMPORTNAME & PROGRAM_DATAEXT & Chr(0)

-    OpenFile.lpstrFilter = sFilter

-    OpenFile.nFilterIndex = 1

-    OpenFile.lpstrFile = String(257, 0)

-    OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1

-    OpenFile.lpstrFileTitle = OpenFile.lpstrFile

-    OpenFile.nMaxFileTitle = OpenFile.nMaxFile

-    OpenFile.lpstrInitialDir = DB_dir

-    OpenFile.lpstrTitle = "Импорт данных"

-    OpenFile.flags = OFN_HIDEREADONLY + OFN_EXPLORER

-    lReturn = GetOpenFileName(OpenFile)

-    If lReturn = 0 Then

-        GetImportDirectory = False

-    Else

-        GetImportDirectory = True

- 

-        flist = Split(OpenFile.lpstrFile, Chr(0), Compare:=vbBinaryCompare)

-        Dim i As Integer

-        i = 0

-        Do While flist(i) <> ""

-            i = i + 1

-        Loop

-        If i = 1 Then

-            flist(1) = flist(0)

-            flist(0) = GetWBPath(flist(1))

-            flist(1) = GetWBName(flist(1))

-        Else

-            flist(0) = flist(0) & "\"

-        End If

-    End If

-End Function

-<<<<<<
-======================
-cPPReport
->>>>>>
-Attribute VB_Name = "cPPReport"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Const PPR_NON As Integer = 0

-Const PPR_NEW As Integer = 1

-Const PPR_OLD As Integer = 2

-

-Dim ReportApp As PowerPoint.Application

-Dim ReportDoc As PowerPoint.Presentation

-Dim ReportState As Integer

-Dim PowerPointPath As String

-

-Private Sub Class_Initialize()

-    Set ReportApp = CreateObject("PowerPoint.Application")

-    PowerPointPath = ReportApp.Path & "\PowerPNT.EXE"

-    ReportState = PPR_NON

-End Sub

-

-Sub OpenReport(FileName As String)

-    If ReportState <> PPR_NON Then

-        SaveReport

-    End If

-    Set ReportDoc = GetObject(FileName)

-    ReportState = PPR_OLD

-End Sub

-

-Sub CreateReport()

-    If ReportState <> PPR_NON Then

-        SaveReport

-    End If

-    Set ReportDoc = ReportApp.Presentations.Add

-    ReportState = PPR_NEW

-End Sub

-

-Sub SaveReport()

-    Select Case ReportState

-        Case PPR_NEW

-            ReportDoc.SaveAs GetWBPath(ThisWorkbook.FullName) + PROGRAM_FILENAME

-        Case PPR_OLD

-            ReportDoc.Save

-    End Select

-    ReportState = PPR_NON

-End Sub

-

-Sub ReportView()

-    Dim CmdName As String

-    CmdName = GetWBPath(ThisWorkbook.FullName) + PROGRAM_FILENAME + ".PPT"

-    CmdName = PowerPointPath & " " & CmdName

-    Shell CmdName, 1

-End Sub

-

-Sub InsertSlide()

-    Dim ReportPage As PowerPoint.Slide

-    Set ReportPage = ReportDoc.Slides.Add(ReportDoc.Slides.count + 1, ppLayoutBlank)

-    

-    ReportPage.Shapes.Paste

-    ReportPage.Shapes.AddLabel(msoTextOrientationHorizontal, 20, 20, 640, 40) _

-      .TextFrame.TextRange.Text = "Slide #" & Format(ReportDoc.Slides.count)

-End Sub

-

-

-Private Sub Class_Terminate()

-    SaveReport

-    ReportApp.Quit

-End Sub

-<<<<<<
-======================
-dlgImprtDB
->>>>>>
-Attribute VB_Name = "dlgImprtDB"

-Attribute VB_Base = "0{36355920-F7A4-44A8-96EF-5D79CF26137D}{F852BDF2-AB3E-468E-89DF-EC5DC0C7C88B}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Private Sub btSelAll_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = True

-    Next i

-End Sub

-

-Private Sub btUnselect_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = False

-    Next i

-End Sub

-<<<<<<
-======================
-rmImport
->>>>>>
-Attribute VB_Name = "rmImport"

-Option Explicit

-

-Public Type dbDESCRIPTION

-    Name As String

-    Fields() As String

-End Type

-

-Sub ImportFromRegionalManagers(rm_files() As String, fm_file As String)

-    Dim db(9) As dbDESCRIPTION

-    

-    '''''data

-    db(1).Name = "rep"

-    

-    db(2).Name = "lpu"

-    db(3).Name = "lpu_acs"

-    db(4).Name = "lpu_budget"

-    db(5).Name = "lpu_hir"

-    db(6).Name = "lpu_im"

-    db(7).Name = "lpu_ter"

-    db(8).Name = "quarter"

-    db(9).Name = "quarter_rm"

-    

-    ReDim db(1).Fields(5)

-    With db(1)

-        .Fields(1) = "rep_id"

-        .Fields(2) = "firstname"

-        .Fields(3) = "lastname"

-        .Fields(4) = "region"

-        .Fields(5) = "city"

-    End With

-    

-    ReDim db(2).Fields(5)

-    With db(2)

-        .Fields(1) = "id"

-        .Fields(2) = "rep_id"

-        .Fields(3) = "name"

-        .Fields(4) = "address"

-        .Fields(5) = "beds"

-    End With

-    

-    ReDim db(3).Fields(7)

-    With db(3)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "patients_with_geparins"

-        .Fields(5) = "patients_per_quarter"

-        .Fields(6) = "patients_stationar_nmg"

-        .Fields(7) = "patients_stationar_clexan"

-    End With

-    

-    ReDim db(4).Fields(6)

-    With db(4)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "bdgt_NMG"

-        .Fields(5) = "bdgt_NFG"

-        .Fields(6) = "sale_PLAN"

-    End With

-    

-    ReDim db(5).Fields(15)

-    With db(5)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "operations_per_quarter"

-        .Fields(5) = "risk_percent"

-        .Fields(6) = "patients_with_risk_ON"

-        .Fields(7) = "patients_ambulator"

-        .Fields(8) = "patients_ambulator_nmg"

-        .Fields(9) = "patients_ambulator_clexan"

-        .Fields(10) = "patients_ambulator_clexan_40mg"

-        .Fields(11) = "patients_ambulator_clexan_20mg"

-        .Fields(12) = "patients_stationar_nmg"

-        .Fields(13) = "patients_stationar_clexan"

-        .Fields(14) = "patients_stationar_clexan_40mg"

-        .Fields(15) = "patients_stationar_clexan_20mg"

-    End With

-    

-    

-    ReDim db(6).Fields(7)

-    With db(6)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "patients_with_geparins"

-        .Fields(5) = "patients_per_quarter"

-        .Fields(6) = "patients_stationar_nmg"

-        .Fields(7) = "patients_stationar_clexan"

-    End With

-    

-    ReDim db(7).Fields(11)

-    With db(7)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "patients_per_quarter"

-        .Fields(5) = "risk_percent"

-        .Fields(6) = "patients_with_risk_ON"

-        .Fields(7) = "patients_ambulator"

-        .Fields(8) = "patients_ambulator_nmg"

-        .Fields(9) = "patients_ambulator_clexan"

-        .Fields(10) = "patients_stationar_nmg"

-        .Fields(11) = "patients_stationar_clexan"

-    End With

-    

-    ReDim db(8).Fields(9)

-    With db(8)

-        .Fields(1) = "ID"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "rep_id"

-        .Fields(4) = "sale_plan"

-        .Fields(5) = "ClxnH20mg"

-        .Fields(6) = "ClxnH40mg"

-        .Fields(7) = "ClxnT40mg"

-        .Fields(8) = "ClxnC_IM"

-        .Fields(9) = "ClxnC_ACS"

-    End With

-    

-    ReDim db(9).Fields(3)

-    With db(9)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "sale_plan"

-    End With

-    

-    Dim rm_idx As Integer

-    Dim to_db As Object

-    'back uo

-    Merge_BackUp_All_Data

-    

-    'clean up

-    Merge_Clear_All_Data fm_file

-    

-    Set to_db = dbGetConnection(fm_file)

-    

-    For rm_idx = 1 To UBound(rm_files)

-        Dim from_db As Object

-        

-        Set from_db = dbGetConnection(rm_files(rm_idx))

-        

-        Dim new_rm_id As Long

-        new_rm_id = dbMergeRM(from_db, to_db)

-

-        Dim i As Integer

-

-        For i = 1 To UBound(db)

-            Dim get_sql As String

-            Dim getRS As Object

-            Dim insRS As Object

-            Dim field_idx As Integer

-                        

-            get_sql = "SELECT * FROM " & db(i).Name

-            Set getRS = CreateObject("ADODB.Recordset")

-            Set insRS = CreateObject("ADODB.Recordset")

-            insRS.Open db(i).Name, to_db, 2, 2

-

-            getRS.Open get_sql, from_db

-            

-            If Not getRS.BOF Then

-                Do While Not getRS.EOF

-                    insRS.addnew

-                    Dim fld_name As String

-                    

-                    For field_idx = 1 To UBound(db(i).Fields)

-                        fld_name = db(i).Fields(field_idx)

-                        insRS(fld_name) = getRS(fld_name)

-                    Next field_idx

-                    

-                    insRS("rm_id") = new_rm_id

-                    insRS.Update

-                    getRS.MoveNext

-                Loop

-            

-            Else

-                'empty table

-                ' do nothing

-            End If

-            

-            

-        Next i

-        

-        dbCloseOpenedConnection from_db

-    Next rm_idx

-    

-    dbCloseOpenedConnection to_db

-End Sub

-

-Function dbMergeRM(from_dbConnection As Object, to_dbConnection As Object) As Long

-

-    Dim getRecordset As Object

-    Dim getREPData_SQL As String

-    Dim REP_fn As String

-    Dim REP_ln As String

-    Dim REP_region As String

-    Dim REP_city As String

-

-

-    getREPData_SQL = "SELECT * FROM reg_man"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getREPData_SQL, from_dbConnection

-        

-        If Not getRecordset.BOF Then

-            REP_fn = getRecordset("firstname")

-            REP_ln = getRecordset("lastname")

-            REP_city = getRecordset("city")

-            REP_region = getRecordset("region")

-        Else

-            MsgBox "There is no information about Regional Manager! This database cannot be merged!!!"

-            dbMergeRM = -1

-            Exit Function

-        End If

-    

-    Dim insertRecordset As Object

-    Set insertRecordset = CreateObject("ADODB.Recordset")

-        

-    insertRecordset.Open "reg_man", to_dbConnection, 2, 2

-    insertRecordset.addnew

-        

-    insertRecordset("firstname") = REP_fn

-    insertRecordset("lastname") = REP_ln

-    insertRecordset("region") = REP_region

-    insertRecordset("city") = REP_city

-    insertRecordset.Update

-    insertRecordset.MoveLast

-    'new ID

-    dbMergeRM = insertRecordset("mgr_id")

-    

-End Function

-

-Sub cmDataImport()

-    Dim def_dir As String

-    Dim flist() As String

-    Dim i As Integer

-

-    def_dir = GetWBPath(ThisWorkbook.FullName)

-    If GetImportDirectory(def_dir, flist) Then

-        Dim ImpMask() As String

-        ImpMask = Split(flist(1), Chr(95), Compare:=vbBinaryCompare)

-        flist(1) = ImpMask(0) & "*"

-        Dim db_list() As String

-        i = GetDBList(flist(), db_list)

-        

-        If i > 0 Then

-            ImportFromRegionalManagers db_list, GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-        End If

-    End If

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).Select

-End Sub

-

-

-<<<<<<
-======================
-PRJ_QTR
->>>>>>
-Attribute VB_Name = "PRJ_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CPRJ_QT As Integer = 0

-Const CPRJ_ID As Integer = 1

-Const CPRJ_PLN As Integer = 2

-Const CPRJ_FCT As Integer = 3

-Const CPRJ_BDG As Integer = 4

-Const CPRJ_CNT As Integer = 5

-Const CPRJ_BEDS As Integer = 6

-Const CPRJ_HIR As Integer = 7

-Const CPRJ_TER As Integer = 8

-Const CPRJ_CRD As Integer = 9

-Const CPRJ_CLXN_BDG As Integer = 10

-Const CPRJ_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Const LOCAL_ENT_DATE As String = "B11"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("PRJ_QTR")

-        s = "Все регионы, " & .getEnt_date()

-    End With

-    

-    MakeChartTitle = s

-End Function

-

-Sub update_history()

-    Dim objQTR() As tREGION

-    Dim i As Long

-    Dim r As Range

-

-

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetRGN_COMM_DATA(objQTR(), 0)

-    

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CPRJ_QT) = objQTR(i).ent_date

-            r.Offset(i - 1, CPRJ_ID) = ""

-            r.Offset(i - 1, CPRJ_PLN) = objQTR(i).sale_PLAN

-            r.Offset(i - 1, CPRJ_FCT) = objQTR(i).total_SALE

-            r.Offset(i - 1, CPRJ_BDG) = objQTR(i).total_BDGT

-            r.Offset(i - 1, CPRJ_CNT) = objQTR(i).total_LPU

-            r.Offset(i - 1, CPRJ_BEDS) = objQTR(i).total_REP

-            r.Offset(i - 1, CPRJ_HIR) = objQTR(i).total_HIR

-            r.Offset(i - 1, CPRJ_TER) = objQTR(i).total_TER

-            r.Offset(i - 1, CPRJ_CRD) = objQTR(i).total_ACS

-            If objQTR(i).total_BDGT <> 0 Then

-                r.Offset(i - 1, CPRJ_CLXN_BDG) = objQTR(i).total_SALE / objQTR(i).total_BDGT

-            End If

-            If objQTR(i).total_BDGT_NMG <> 0 Then

-                r.Offset(i - 1, CPRJ_CLXN_NMG) = objQTR(i).total_SALE / objQTR(i).total_BDGT_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR_PRJ()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(PRJ_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CPRJ_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CPRJ_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CPRJ_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CPRJ_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CPRJ_CRD + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-

-Sub Draw_PLN_QTR_PRJ()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(PRJ_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CPRJ_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CPRJ_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CPRJ_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CPRJ_FCT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PLN_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Draw_BDGT_QTR_PRJ()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(PRJ_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CPRJ_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CPRJ_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CPRJ_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CPRJ_CLXN_NMG + 1)

-        End If

-    Next i

-    Worksheets("CHRT_BDGT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-Public Sub cbxPRJ_QtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR_PRJ

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR_PRJ

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR_PRJ

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = PRJ_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    Protect UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CPRJ_QT + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    If r = "" Then

-        Worksheets(VAR_SHEET).Range("PRJ_ACTION") = 2

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        Worksheets(VAR_SHEET).Range("PRJ_ACTION") = 2

-        Range("LAST_FOCUS") = currRange.address

-        With Worksheets("REP_LIST")

-            .Range("ret_addr") = "PRJ_QTR"

-            .Range("ent_date") = r

-            .Range("VIEW_ONLY") = True

-        End With

-    End If

-    Cancel = True

-    btPRJ_QTR_Do_IT ' old btRM_OTR_DO_IT

-End Sub

-

-<<<<<<
-======================
-RM_LIST
->>>>>>
-Attribute VB_Name = "RM_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Const LOCAL_ENT_DATE As String = "C10"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-

-Public Function getCurrentRM_ID() As Long

-    Dim r As Range

-

-    With Worksheets("RM_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CRM_ID)

-    End With

-

-    getCurrentRM_ID = r

-End Function

-

-Public Sub RM_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("PM_CHR_IDX")

-        Case 1

-            Rm_Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Rm_Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Rm_Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-

-        Case 4

-            Rm_Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectRM_QTR(rm_id As Long)

-    Dim vo As Boolean

-

-    Range("JUMP") = "RM_QTR"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("RM_QTR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "RM_LIST"

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Public Sub SelectREP_LIST(rm_id As Long)

-    Dim vo As Boolean

-

-    Range("JUMP") = "REP_LIST"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("REP_LIST")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "RM_LIST"

-        .setEnt_date (getEnt_date())

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateRMList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Sub UpdateRMList()

-    Dim rmcd() As tRMID_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-

-    ent_date = getEnt_date

-

-    i = Get_RM_CommonList_by_QTR(rmcd(), ent_date)

-

-    With ThisWorkbook.Worksheets("RM_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(rmcd)

-            r.Offset(i - 1, CRM_NAME) = GetRegionName(rmcd(i).rm.Region)

-            r.Offset(i - 1, CRM_ID) = rmcd(i).rm.rm_id

-            r.Offset(i - 1, CRM_BEDS) = rmcd(i).rgcd(1).total_BEDS

-            r.Offset(i - 1, CRM_BDGT) = rmcd(i).rgcd(1).total_BDGT

-            r.Offset(i - 1, CRM_NMG) = rmcd(i).rgcd(1).total_BDGT_NMG

-            r.Offset(i - 1, CRM_HIR) = rmcd(i).rgcd(1).total_HIR

-            r.Offset(i - 1, CRM_TER) = rmcd(i).rgcd(1).total_TER

-            r.Offset(i - 1, CRM_CAR) = rmcd(i).rgcd(1).total_ACS

-            r.Offset(i - 1, CRM_FACT) = rmcd(i).rgcd(1).total_SALE

-            r.Offset(i - 1, CRM_PLAN) = rmcd(i).rgcd(1).sale_PLAN

-            

-            With rmcd(i).rgcd(1)

-                r.Offset(i - 1, CRM_PAT_LPU) = .total_HIR + .total_TER + .total_ACS

-            End With

-            

-            r.Offset(i - 1, CRM_BDGT_1) = rmcd(i).rgcd(1).total_BDGT

-            If rmcd(i).rgcd(1).total_BDGT > 0 Then

-                r.Offset(i - 1, CRM_BDGT_1 + 1) = rmcd(i).rgcd(1).total_SALE / rmcd(i).rgcd(1).total_BDGT

-            End If

-            If r.Offset(i - 1, CRM_BDGT_1 + 1) > 1 Then

-                r.Offset(i - 1, CRM_BDGT_1 + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim rep_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CRM_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CRM_AREA).row, CRM_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    rep_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CRM_AREA).Column

-

-    If i < 4 Then

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 1

-    Else

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 2

-    End If

-

-    If rep_id = 0 Then

-        Range("LAST_FOCUS") = Range(CRM_AREA).address

-    End If

-

-    If rep_id = 0 Then

-        i = CRM_NAME

-        Range("JUMP") = ""

-    Else

-        btRM_LIST_DO_IT

-    End If

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-<<<<<<
-======================
-mPRJ_QTR
->>>>>>
-Attribute VB_Name = "mPRJ_QTR"

-Sub btPRJ_QTR_Do_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    

-    idx = Worksheets(VAR_SHEET).Range("PRJ_ACTION")

-    ent_date = Worksheets(PRJ_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            cmDataImport

-        Case 2

-            Worksheets("RM_LIST").setEnt_date (Worksheets("PRJ_QTR").getEnt_date())

-            Worksheets("RM_LIST").Range("ret_addr") = "PRJ_QTR"

-            Worksheets("RM_LIST").Select

-        Case 3

-            cmNewReport

-    End Select

-    Worksheets(VAR_SHEET).Range("PRJ_ACTION") = 2

-End Sub

-

-

-<<<<<<
-======================
-mRM_LIST
->>>>>>
-Attribute VB_Name = "mRM_LIST"

-Option Explicit

-

-Public Const CRM_AREA As String = "B12"

-Public Const CRM_NAME As Integer = 0

-Public Const CRM_NAME1 As Integer = 1

-Public Const CRM_NAME2 As Integer = 2

-Public Const CRM_ID As Integer = 3

-Public Const CRM_BEDS As Integer = 4

-Public Const CRM_BDGT As Integer = 5

-Public Const CRM_NMG As Integer = 6

-Public Const CRM_HIR As Integer = 7

-Public Const CRM_TER As Integer = 8

-Public Const CRM_CAR As Integer = 9

-Public Const CRM_FACT As Integer = 10

-Public Const CRM_PLAN As Integer = 11

-Public Const CRM_PAT_LPU As Integer = 16

-Public Const CRM_BDGT_1 As Integer = 17

-

-

-Const LOCAL_ENT_DATE As String = "C10"

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Sub EditREP(CRM As tREPID, ent_date As String)

-    NoFunc

-End Sub

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("RM_LIST")

-        s = "Регионы, " & .getEnt_date()

-    End With

-    

-    MakeChartTitle = s

-End Function

-

-Sub Rm_Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_LPU_BBL").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rm_Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRM_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRM_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRM_FACT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PIE").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rm_Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CRM_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRM_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRM_HIR + 1)

-            psum = psum + src.Cells(i, CRM_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRM_TER + 1)

-            psum = psum + src.Cells(i, CRM_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRM_CAR + 1)

-            psum = psum + src.Cells(i, CRM_CAR + 1)

-            dst.Cells(i, 5) = psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU").Range("title") = MakeChartTitle

-    

-End Sub

-

-Sub Rm_Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CRM_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRM_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRM_HIR + 1)

-            psum = psum + src.Cells(i, CRM_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRM_TER + 1)

-            psum = psum + src.Cells(i, CRM_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRM_CAR + 1)

-            psum = psum + src.Cells(i, CRM_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CRM_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU_A").Range("title") = MakeChartTitle

-    

-End Sub

-

-Sub btRM_LIST_RET_IT()

-    With Worksheets("RM_LIST")

-        .setEnt_date ("")

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = "PRJ_QTR"

-    End With

-    ThisWorkbook.Worksheets("PRJ_QTR").Activate

-End Sub

-

-

-Sub btRM_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim rm_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("RM_LIST_ACTION")

-    With Worksheets("RM_LIST")

-        rm_id = .getCurrentRM_ID()

-        

-        Select Case i

-            Case 1:

-                .SelectRM_QTR rm_id

-            Case 2:

-                .SelectREP_LIST rm_id

-            End Select

-    End With

-    

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-

-

-

-

-<<<<<<
-Project Name : 'ClexaneMR'
-Quirk - duff tag length======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).ClearRepName

-    

-    Application.EnableEvents = True

-    Set MyAppEvents.app = Application

-    

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    

-    MyAppEvents.CheckWorkBooksArround ThisWorkbook

-    

-    cmSetStandaloneMode

-    

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-    

-    Application.ScreenUpdating = True

-    

-    If CheckUser Then

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-        ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-        ThisWorkbook.Worksheets(REP_QTR_SHEET).update_history

-        Application.Calculate

-    End If

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    

-    Dim RestMode As Boolean

-    RestMode = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE")

-    

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-'        If RestMode Then

-            ThisWorkbook.Saved = True

-'        Else

-'            ThisWorkbook.Save

-'        End If

-    End If

-    If RestMode Then

-        xlRestoreView

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    End If

-    Application.Caption = Empty

-    Application.CommandBars(STDBAR_NAME).Reset

-    

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-    Dim MaxX, MaxY As Integer

-    With ThisWorkbook.Worksheets(REP_QTR_SHEET)

-        MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-        MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-    End With

-

-    With ThisWorkbook.Application

-        .ScreenUpdating = False

-        .WindowState = xlNormal

-        .Height = MaxY

-        .Width = MaxX

-    End With

-End Sub

-

-

-

-

-

-<<<<<<
-======================
-REP_QTR
->>>>>>
-Attribute VB_Name = "REP_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CQTR_QT As Integer = 0

-Const CQTR_ID As Integer = 1

-Const CQTR_PLN As Integer = 2

-Const CQTR_FCT As Integer = 3

-Const CQTR_BDG As Integer = 4

-Const CQTR_CNT As Integer = 5

-Const CQTR_BEDS As Integer = 6

-Const CQTR_HIR As Integer = 7

-Const CQTR_TER As Integer = 8

-Const CQTR_CRD As Integer = 9

-Const CQTR_CLXN_BDG As Integer = 10

-Const CQTR_CLXN_NMG As Integer = 11

-Const CQTR_PAT_ALL As Integer = 16

-Const CQTR_BDGT_ALL As Integer = 17

-

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub ClearRepName()

-    Unprotect

-    Range("D4") = ""

-    Range("D5") = ""

-    Range("H4") = ""

-    Range("H5") = ""

-End Sub

-

-Sub update_history()

-    Dim objQTR() As tQTR

-    Dim i As Long

-    Dim r As Range

-    Dim cRep As tREP

-    

-    cRep = GetREPRecord

-    Range("D4") = cRep.LastName

-    Range("D5") = cRep.FirstName

-    

-    Range("H4") = GetRegionName(cRep.Region)

-    Range("H5") = GetCityName(cRep.Region, cRep.City)

-    

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    i = GetAll_QTR_Records(objQTR, "%")

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CQTR_QT) = objQTR(i).entry_date

-        Next i

-    End If

-    Dim qcd() As tQTR_COMMON

-    i = Get_QTR_CommonList(qcd)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(qcd)

-            r.Offset(i - 1, CQTR_QT) = qcd(i).qtr.entry_date

-            r.Offset(i - 1, CQTR_ID) = qcd(i).qtr.id

-            r.Offset(i - 1, CQTR_PLN) = qcd(i).qtr.sale_plan

-            r.Offset(i - 1, CQTR_FCT) = qcd(i).c_sale_ALL

-            r.Offset(i - 1, CQTR_BDG) = qcd(i).c_bdgt_LPU

-            r.Offset(i - 1, CQTR_CNT) = qcd(i).i_lcd

-            r.Offset(i - 1, CQTR_BEDS) = qcd(i).c_beds

-            r.Offset(i - 1, CQTR_HIR) = qcd(i).c_pat_HIR

-            r.Offset(i - 1, CQTR_TER) = qcd(i).c_pat_TER

-            r.Offset(i - 1, CQTR_CRD) = qcd(i).c_pat_CRD

-            If qcd(i).c_bdgt_LPU <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_BDG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_LPU

-            End If

-            If qcd(i).c_bdgt_NMG <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_NMG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_BBL_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-

-End Sub

-

-Sub Draw_PAT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CQTR_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRepQtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-

-Private Sub Worksheet_Activate()

-  

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-    

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.Count > 1 And r_sel.Columns.Count < CRow_Width Or r_sel.Rows.Count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.Count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.Count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.Count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CQTR_ID + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    i = currRange.Column - Range(CINP_AREA).Column

-    

-    QTR_ID = r

-

-    If QTR_ID = 0 Then

-        Worksheets(VAR_SHEET).Range("USER_ACTION") = 1

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        If i > CQTR_FCT Then

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-            Range("LAST_FOCUS") = currRange.address

-        Else

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 3

-            Range("LAST_FOCUS") = currRange.address

-        End If

-    End If

-    Cancel = True

-    btHomeDo_IT

-End Sub

-

-<<<<<<
-======================
-mRep_QTR
->>>>>>
-Attribute VB_Name = "mRep_QTR"

-Option Explicit

-

-Sub DO_New_qtr()

-    Dim res As Variant

-    Dim objQTR As tQTR

-    Dim s As String

-    s = GetLastQtr

-    objQTR.entry_date = GetNextQTR(s)

-    

-    If objQTR.entry_date = "" Then

-        Exit Sub

-    End If

-    

-    DO_Price_qtr objQTR.entry_date

-

-End Sub

-

-Sub DO_Price_qtr(ent_date As String)

-    If ent_date = "" Then

-        DO_New_qtr

-    Else

-        Dim qtr As tQTR

-        Dim res As Integer

-        

-        qtr = Get_QTR_Record(ent_date)

-        

-        If qtr.id = 0 Then

-            qtr.entry_date = ent_date

-    

-            With Worksheets(VAR_SHEET)

-                qtr.ClxnH20mg = .Range("ClxnH20mg")

-                qtr.ClxnH40mg = .Range("ClxnH40mg")

-                qtr.ClxnT40mg = .Range("ClxnT40mg")

-                qtr.ClxnC_ACS = .Range("ClxnC_ACS")

-                qtr.ClxnC_IM = .Range("ClxnC_IM")

-            End With

-        End If

-        

-        Dim dlg_nq As dlg_nextQTR

-        Set dlg_nq = New dlg_nextQTR

-        

-        With dlg_nq

-            .tb_qtr_name = qtr.entry_date

-            .tb_bdgt_avts = qtr.sale_plan

-            .tb_qtr_name = qtr.entry_date

-            .tb_ClxnH20mg = qtr.ClxnH20mg

-            .tb_ClxnH40mg = qtr.ClxnH40mg

-            .tb_ClxnT40mg = qtr.ClxnT40mg

-            .tb_ClxnC_ACS = qtr.ClxnC_ACS

-            .tb_ClxnC_IM = qtr.ClxnC_IM

-        End With

-        

-        dlg_nq.Show

-        res = dlg_nq.Tag

-        

-        If res = vbOK Then

-            With dlg_nq

-                If Not IsNumeric(.tb_bdgt_avts) Then

-                    MsgBox "Введите план продаж", vbOK, PROGRAM_NAME

-                Else

-                    If .tb_bdgt_avts = 0 Then

-                        MsgBox "Введите план продаж", vbOK, PROGRAM_NAME

-                        Exit Sub

-                    End If

-                End If

-                Dim bool As Boolean

-                bool = IsNumeric(.tb_ClxnH20mg) _

-                    And IsNumeric(.tb_ClxnH40mg) _

-                    And IsNumeric(.tb_ClxnT40mg) _

-                    And IsNumeric(.tb_ClxnC_ACS) _

-                    And IsNumeric(.tb_ClxnC_IM)

-                If Not bool Then

-                    MsgBox "Вводите правильно цыфры", vbOK, PROGRAM_NAME

-                    Exit Sub

-                End If

-                qtr.sale_plan = .tb_bdgt_avts

-                qtr.entry_date = .tb_qtr_name

-                qtr.ClxnH20mg = .tb_ClxnH20mg

-                qtr.ClxnH40mg = .tb_ClxnH40mg

-                qtr.ClxnT40mg = .tb_ClxnT40mg

-                qtr.ClxnC_ACS = .tb_ClxnC_ACS

-                qtr.ClxnC_IM = .tb_ClxnC_IM

-            End With

-            Insert_QTR_Record qtr

-        End If

-    End If

-End Sub

-

-Sub DO_Edit_qtr(ent_date As String)

-    If ent_date = "" Then

-        DO_New_qtr

-    Else

-        With ThisWorkbook.Worksheets("LPU_LIST")

-            .Range("VIEW_ONLY") = False

-            .Range("ent_date") = ent_date

-            .Select

-        End With

-    End If

-End Sub

-

-Sub DO_Delete_qtr(ent_date As String)

-    If ent_date <> "" Then

-        Dim i As Integer

-        i = MsgBox("Удалить данные за период [" & ent_date & "]?", vbDefaultButton2 + vbOKCancel, PROGRAM_NAME)

-        If i = vbOK Then

-            Dim objQTR As tQTR

-            If ent_date <> "" Then

-                objQTR.entry_date = ent_date

-                objQTR = Get_QTR_Record(ent_date)

-                Delete_QTR_Record objQTR

-                Worksheets(TITLE_SHEET).Select

-                Worksheets(REP_QTR_SHEET).Select

-            End If

-        End If

-    End If

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-

-Sub btHomeDo_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    idx = Worksheets(VAR_SHEET).Range("USER_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            DO_New_qtr

-            ' Обновляем экран

-        Case 2

-            DO_Edit_qtr ent_date

-        Case 3

-            DO_Price_qtr ent_date

-        Case 4

-            dbExport

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    End Select

-    If idx <> 2 Then

-        With ThisWorkbook

-            .Worksheets(TITLE_SHEET).Select

-            .Worksheets(REP_QTR_SHEET).Select

-        End With

-    End If

-End Sub

-

-Sub Delete_qtr()

-    Dim ent_date As String

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    DO_Delete_qtr ent_date

-End Sub

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane[MR]"

-Public Const PROGRAM_VERSION As String = "version 1.6"

-Public Const PROGRAM_FILENAME As String = "clexane-mr"

-Public Const PROGRAM_EXPORTNAME As String = "mr-ex-"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20030329

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "O40"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-End Sub

-

-Function Double2Str(ByVal d As Double, ByVal precision As Integer, Optional Delim As String = ".") As String

-    Dim s As String

-    If Not precision > 0 Then

-        s = Round(d)

-    Else

-        Dim i As Integer

-        i = Fix(d)

-        s = i & Delim

-        d = Abs(d - i)

-        Do

-            precision = precision - 1

-            d = d * 10

-            If precision > 0 Then

-                i = Fix(d)

-            Else

-                i = Round(d)

-            End If

-            If i < 1 Then

-                s = s & "0"

-            Else

-                s = s & i

-                d = d - i

-            End If

-        Loop While precision > 0

-    End If

-    Double2Str = s

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.Count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.name = VAR_SHEET Or sh.name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-<<<<<<
-======================
-Var
->>>>>>
-Attribute VB_Name = "Var"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-title
->>>>>>
-Attribute VB_Name = "title"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LPU_LIST
->>>>>>
-Attribute VB_Name = "LPU_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentLPU_ID() As Long

-    Dim r As Range

-    

-    With Worksheets("LPU_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CLPU_ID)

-    End With

-    

-    getCurrentLPU_ID = r

-End Function

-

-Public Sub LPU_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectLPU_NAME(lpu_id As Long, ent_date As String)

-    If Range("VIEW_ONLY") = True Then

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    Dim cLPU As tLPU

-    If lpu_id = 0 Then

-        cLPU.id = 0

-        cLPU.rep_id = 0

-        cLPU.address = ""

-        cLPU.name = ""

-    Else

-        cLPU = Get_LPU_Record(lpu_id)

-    End If

-    EditLPU cLPU, getEnt_date

-    Worksheet_Activate

-End Sub

-        

-Sub SelectLPU_BDGT(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    If lpu_id = 0 Then

-        SelectLPU_NAME lpu_id, ent_date

-    Else

-        With ThisWorkbook.Worksheets("LPU_BDGT")

-            .Range("VIEW_ONLY") = vo

-            .Range("ret_addr") = "LPU_LIST"

-            .Range("ent_date") = ent_date

-            .Range("lpu_id") = lpu_id

-        End With

-    End If

-End Sub

-

-Sub SelectLPU_HIR(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_CLSN_HIR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-                   

-Sub SelectLPU_TER(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_CLSN_TER")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-       

-Sub SelectLPU_C_ACS(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_CLSN_C_ACS")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateLPUList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.Count > 1 And r_sel.Columns.Count < CINP_WIDTH Or r_sel.Rows.Count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.Count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.Count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.Count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim lpu_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-    

-    ent_date = getEnt_date

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-    

-    Set r = Range(CINP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CINP_AREA).row, CLPU_ID)

-        

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-    

-    lpu_id = r

-    

-    i = Range(Range("LAST_FOCUS")).Column - Range(CINP_AREA).Column

-    

-    If lpu_id = 0 Then

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    End If

-    

-    If lpu_id = 0 Then

-        i = CLPU_NAME

-        Range("JUMP") = ""

-    End If

-    Select Case i

-        Case CLPU_NAME, CLPU_NAME1, CLPU_NAME2, CLPU_BEDS

-            SelectLPU_NAME lpu_id, ent_date

-            Range("JUMP") = ""

-

-        Case CLPU_NMG, CLPU_NFG, CLPU_PLAN, CLPU_FACT

-            SelectLPU_BDGT lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-            

-        Case CLPU_HIR

-            SelectLPU_HIR lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_HIR"

-        

-        Case CLPU_TER

-            SelectLPU_TER lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_TER"

-        

-        Case CLPU_CAR

-            SelectLPU_C_ACS lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_C_ACS"

-        

-        Case Else

-            Range("JUMP") = ""

-    End Select

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-    

-    is_input_range = INPUT_NO

-    

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateLPUList()

-    Dim lcd() As tLPU_COMMON

-    

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-    Dim objQTR As tQTR

-    Dim cRep As tREP

-    

-    ' ent_date = "%" ' % - all records

-    ent_date = getEnt_date

-    

-    objQTR = Get_QTR_Record(ent_date)

-    i = Get_LPU_CommonQTR(lcd, objQTR)

-     

-    ' стираем ФИО

-    Range("C3:C4").ClearContents

-    cRep = GetREPRecord

-    

-    Range("C3") = cRep.LastName

-    Range("C4") = cRep.FirstName

-    Range("G3") = GetRegionName(cRep.Region)

-    Range("G4") = GetCityName(cRep.Region, cRep.City)

-    Range("G5") = objQTR.sale_plan

-    

-

-    

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-        

-        For i = 1 To UBound(lcd)

-            r.Offset(i - 1, CLPU_NAME) = lcd(i).lpu.name

-            r.Offset(i - 1, CLPU_ID) = lcd(i).lpu.id

-            r.Offset(i - 1, CLPU_BEDS) = lcd(i).lpu.beds

-            

-         

-            r.Offset(i - 1, CLPU_NFG) = lcd(i).bdgt.bdgt_NFG

-            r.Offset(i - 1, CLPU_NMG) = lcd(i).bdgt.bdgt_NMG

-            r.Offset(i - 1, CLPU_PLAN) = lcd(i).bdgt.sale_plan

-            

-            r.Offset(i - 1, CLPU_HIR) = lcd(i).pat_HIR

-            r.Offset(i - 1, CLPU_TER) = lcd(i).pat_TER

-            r.Offset(i - 1, CLPU_CAR) = lcd(i).pat_CRD

-            r.Offset(i - 1, CLPU_FACT) = lcd(i).sale_ALL

-            r.Offset(i - 1, CLPU_PAT_LPU) = lcd(i).pat_LPU

-            r.Offset(i - 1, CLPU_BDGT) = lcd(i).bdgt_LPU

-            If lcd(i).bdgt_LPU > 0 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = lcd(i).sale_ALL / lcd(i).bdgt_LPU

-            End If

-            If r.Offset(i - 1, CLPU_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = 1

-            End If

-            

-        Next i

-    End If

-End Sub

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{566B33D6-957A-43E4-8444-D8EA3889700C}{42EE65B8-F8C6-4F95-9F52-7738BF6FCEAD}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-dbACS
->>>>>>
-Attribute VB_Name = "dbACS"

-Option Explicit

-

-Public Type tACS

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    patients_with_geparins As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objACS.ID <> 0 then updatre else insert

-Sub Insert_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objACS.id <> 0 Then

-        dbUpdate_ACS_Record dbConnection, objACS

-    Else

-        dbInsert_ACS_Record dbConnection, objACS

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_ACS_RecordsByLPU_ID(ByRef all_ACS_() As tACS, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_ACS_RecordsByLPU_ID = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, all_ACS_, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_ACS_Record dbConnection, objACS

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub dbInsert_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_acs", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objACS

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("patients_with_geparins") = .patients_with_geparins

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objACS.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim Update_SQL As String

-    

-    With objACS

-        Update_SQL = "UPDATE lpu_acs SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "patients_with_geparins=" & .patients_with_geparins & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_ACS_RecordsbyLPU_ID(dbConnection As Object, all_ACS() As tACS, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_ACS_SQL As String

-    Dim getAll_ACS_SQL As String

-    Dim ACS_Count As Long

-    ACS_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_ACS_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        ACS_Count = dbRecordset("ACS_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_ACS_RecordsbyLPU_ID = ACS_Count

-    

-    If ACS_Count > 0 Then

-        'we have records

-        ReDim all_ACS(1 To ACS_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_ACS_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_ACS As tACS

-                 With tmp_ACS

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .patients_with_geparins = dbRecordset("patients_with_geparins")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 all_ACS(index) = tmp_ACS

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE ID=" & objACS.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_ACS_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_HIR
->>>>>>
-Attribute VB_Name = "LPU_CLSN_HIR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-    

-        Dim objHir As tHIRURGIA

-        

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objHir

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .operations_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L9")

-                .patients_ambulator_clexan_20mg = Range("L10")

-                .patients_ambulator_clexan_40mg = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L19")

-                .patients_stationar_clexan_20mg = Range("L20")

-                .patients_stationar_clexan_40mg = Range("L21")

-            End With

-            Insert_Hir_Record objHir

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objHir.id = Range("rec_id")

-                    If objHir.id <> 0 Then

-                        Delete_Hir_Record objHir

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objHir As tHIRURGIA)

-    Dim qtr As tQTR

-    Dim formula As String

-

-    With objHir

-        Range("rec_id") = .id

-        Range("F6") = .operations_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L9") = .patients_ambulator_clexan

-        Range("L10") = .patients_ambulator_clexan_20mg

-        Range("I21") = .patients_stationar_nmg

-        Range("L19") = .patients_stationar_clexan

-        Range("L20") = .patients_stationar_clexan_20mg

-        

-        qtr = Get_QTR_Record(.entry_date)

-        formula = "=" & qtr.ClxnH20mg & "*($L$10+$L$20)+" & qtr.ClxnH40mg & "*($L$11+$L$21)"

-        Range("F11").formula = formula

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-    

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Range("h_DepFlag") = False

-    

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objHir() As tHIRURGIA

-        Dim i As Integer

-        i = GetAll_Hir_RecordsByLPU_ID(objHir, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.3

-        Else

-            SetupData objHir(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-mSapes
->>>>>>
-Attribute VB_Name = "mSapes"

-Option Explicit

-

-Const SHAPE_COLOR As Integer = 1

-Const SHAPE_NAME As Integer = 2

-

-

-Sub ShapeView(r_sh_finite_state As Range)

-    Dim chk As Range

-    Dim s As String

-    Dim c, idx As Integer

-    For Each chk In r_sh_finite_state

-        idx = 0

-        If chk = "+" Then

-            c = chk.Offset(0, idx + SHAPE_COLOR)

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While c <> 0

-                ShapeFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s)), c

-                idx = idx + 2

-                c = chk.Offset(0, idx + SHAPE_COLOR)

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        Else

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While s <> ""

-                ShapeUnFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s))

-                idx = idx + 2

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        End If

-    Next chk

-End Sub

-

-Sub ShapeFill(sh As ShapeRange, ByVal color As Integer)

-    sh.Fill.Visible = msoTrue

-    sh.Fill.Solid

-    sh.Fill.ForeColor.SchemeColor = color

-    sh.Fill.Transparency = 0#

-End Sub

-

-Sub ShapeUnFill(sh As ShapeRange)

-    sh.Fill.Visible = msoFalse

-    sh.Fill.Transparency = 0#

-End Sub

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Public Const INPUT_NO = 0

-Public Const INPUT_NUMBER = 1

-Public Const INPUT_PERCENT = 2

-Public Const INPUT_STRING = 3

-Public Const INPUT_CHECK = 4

-

-Public Const INP_IDX_TYPE = 1

-Public Const INP_IDX_NEXT = 2

-Public Const INP_IDX_MIN = 3

-Public Const INP_IDX_MAX = 4

-Public Const INP_IDX_DEP = 5

-Public Const INP_IDX_ALT = 7

-

-

-Public Type tInputSet

-    vType As Integer

-    vMin As Long

-    vMax As Long

-    rChk As String

-End Type

-

-Function is_input_cell(ByVal Target As Range, inputs As Range) As tInputSet

-    Dim t As Range

-    Dim iset As tInputSet

-    Dim test As Range

-    iset.vType = INPUT_NO

-    iset.vMin = 0

-    iset.vMax = 0

-    iset.rChk = ""

-    is_input_cell = iset

-

-' Закоментировать следующую сточку для работы

-'  Exit Function

-

-    Set test = Target.Cells(1, 1)

-    For Each t In inputs

-        If Range(t).Column = test.Column And Range(t).row = test.row Then

-            iset.vType = t.Offset(0, INP_IDX_TYPE).Value

-            Select Case iset.vType

-                Case INPUT_CHECK

-                    iset.rChk = t.Offset(0, INP_IDX_ALT)

-                Case INPUT_NUMBER, INPUT_PERCENT

-                    iset.vMin = t.Offset(0, INP_IDX_MIN).Value

-                    iset.vMax = t.Offset(0, INP_IDX_MAX).Value

-            End Select

-            is_input_cell = iset

-            Exit Function

-        End If

-    Next t

-End Function

-

-Function GetFocusAddress(ByVal r As Range, f_next As Range) As String

-    Dim chk, t As Range

-    

-    For Each chk In f_next

-        For Each t In r

-            If t.address = chk Then

-                GetFocusAddress = chk

-                Exit Function

-            End If

-            If Range(chk).Column = t.Column - 1 And Range(chk).row = t.row _

-            Or Range(chk).Column = t.Column And Range(chk).row = t.row - 1 _

-            Then

-                If Range(chk) <> "" Then

-                    If Range(chk) = 0 Then

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_ALT)).address

-                    Else

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_NEXT)).address

-                    End If

-                Else

-                    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-                End If

-                Exit Function

-            End If

-        Next t

-    Next chk

-    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-End Function

-

-Sub SetDependet(r As Range, inputs As Range)

-    Dim chk As Range

-    Dim s, serr As String

-    Dim idx As Integer

-    Dim iset As tInputSet

-    Dim err_found As Boolean

-    

-    If r.Count > 1 Then

-        Exit Sub

-    End If

-    

-    err_found = False

-    For Each chk In inputs

-        idx = INP_IDX_DEP

-        

-        

-        iset.vType = chk.Offset(0, INP_IDX_TYPE).Value

-        Select Case iset.vType

-            Case INPUT_NUMBER, INPUT_PERCENT

-                iset.vMin = chk.Offset(0, INP_IDX_MIN).Value

-                iset.vMax = chk.Offset(0, INP_IDX_MAX).Value

-                

-                If Range(chk) > iset.vMax Then

-                    err_found = True

-                    Range(chk) = iset.vMax

-                    serr = "Выход за дозволенный диапазон [" & iset.vMin & ".." & iset.vMax & "]! Данные скорректированы."

-                End If

-                

-                If Range(chk) = "" Then

-                    s = chk.Offset(0, idx)

-                    Do While s <> ""

-                        Range(s) = ""

-                        idx = idx + 1

-                        s = chk.Offset(0, idx)

-                    Loop

-                End If

-        End Select

-    Next chk

-    If err_found Then

-        MsgBox serr, vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Function CheckInputData(inputs As Range) As Boolean

-    Dim r As Range

-    

-    CheckInputData = True

-    For Each r In inputs

-        If Range(r) = "" Then

-            CheckInputData = False

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100.", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Sub Check_Int_Number(Target As Range, Def_Val As Long)

-    Dim err As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    err = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                err = True

-            End If

-        End If

-    Next r

-    If err Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_TER
->>>>>>
-Attribute VB_Name = "LPU_CLSN_TER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim objTer As tTERAPIA

-        

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objTer

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .patients_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L20")

-            End With

-            Insert_Ter_Record objTer

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objTer.id = Range("rec_id")

-                    If objTer.id <> 0 Then

-                        Delete_Ter_Record objTer

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objTer As tTERAPIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    With objTer

-        Range("rec_id") = .id

-        Range("F6") = .patients_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L11") = .patients_ambulator_clexan

-        Range("I21") = .patients_stationar_nmg

-        Range("L20") = .patients_stationar_clexan

-        

-        qtr = Get_QTR_Record(.entry_date)

-        formula = "=" & qtr.ClxnT40mg & "*($L$12+$L$20)"

-        Range("F11").formula = formula

-        

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-    

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Range("h_DepFlag") = False

-    

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objTer() As tTERAPIA

-        Dim i As Integer

-        i = GetAll_Ter_RecordsByLPU_ID(objTer, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.25

-        Else

-            SetupData objTer(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-    

-    Dim s As String

-    Dim iset As tInputSet

-    

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    

-    Select Case iset.vType

-        Case INPUT_NO

-        

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-            

-            Application.ScreenUpdating = False

-            

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-            

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-        

-        Case INPUT_STRING

-        

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{EBA94131-180E-4709-A2A3-B60D48987620}{47A860A1-BF92-4EBB-A333-AB7E83FAB868}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-LPU_BDGT
->>>>>>
-Attribute VB_Name = "LPU_BDGT"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub SetDefFocus()

-    Range(Range("DEF_FOCUS")).Select

-End Sub

-

-Public Sub ClearData()

-    ClearSheetData

-End Sub

-

-Sub ClearSheetData()

-    If Range("F10") = 0 And Range("F13") = 0 Then

-        Range("F11:F18") = ""

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("F11:F13") = ""

-    End If

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim bdgt As tBUDGET

-        Dim sum As Long

-        Dim test As Boolean

-        With bdgt

-            .lpu_id = Range("lpu_id")

-            .id = Range("rec_id")

-            .entry_date = Range("ent_date")

-            .bdgt_NMG = Round(Range("F11").Value, 0)

-            .bdgt_NFG = Round(Range("F12").Value, 0)

-            .sale_plan = Round(Range("F13").Value, 0)

-            

-            sum = .bdgt_NFG + .bdgt_NMG - .sale_plan

-            test = .bdgt_NFG <> 0 Or .bdgt_NMG <> 0 Or .sale_plan <> 0

-        End With

-        If test Then

-            If sum < 0 Then

-                MsgBox _

-                    "Ваш план превышает выделенный на гепарины бюджет. Сохранить данные?", _

-                    vbOKOnly, PROGRAM_NAME

-            End If

-            If test Then

-                Insert_BDGT_Record bdgt

-            End If

-        Else

-            If bdgt.id <> 0 Then

-                If vbYes = MsgBox("Сохранить нулевые значения?", vbYesNo, PROGRAM_NAME) Then

-                    Insert_BDGT_Record bdgt

-                End If

-                ret_back Range("DEF_FOCUS").Worksheet

-                Exit Sub

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-    End If

-    

-   ClearData

-   ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(cLPU As tLPU_COMMON)

-    Dim t_sum As Long

-    t_sum = 0

-' Setup budget data

-    Range("F11") = cLPU.bdgt.bdgt_NMG

-    Range("F12") = cLPU.bdgt.bdgt_NFG

-    Range("F13") = cLPU.bdgt.sale_plan

-    

-    With cLPU

-        Range("F14") = .pat_ALL

-        Range("F15") = .pat_HIR

-        Range("F16") = .pat_TER

-        Range("F17") = .pat_CRD

-        Range("F18") = .sale_ALL

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    ws_activate

-End Sub

-

-

-Sub ws_activate()

-    Dim cLPU As tLPU_COMMON

-    Dim objQTR As tQTR

-    Dim objLPU As tLPU

-    Dim ent_date As String

-    Dim id As Long

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    id = Range("lpu_id").Value

-    ent_date = Range("ent_date")

-    objQTR = Get_QTR_Record(ent_date)

-    objLPU = Get_LPU_Record(id)

-    Get_LPU_Common cLPU, objLPU, objQTR

-    

-    If cLPU.lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = cLPU.lpu.beds

-        Range("lpu_name") = cLPU.lpu.name

-        Range("lpu_addr") = cLPU.lpu.address

-        Range("rec_id") = cLPU.bdgt.id

-        

-        SetupData cLPU

-        

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-'    MsgBox Target.address

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Dim s As String

-    Dim iset As tInputSet

-    

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    

-    Select Case iset.vType

-        Case INPUT_NO

-        

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-            

-        Case INPUT_PERCENT

-        

-        Case INPUT_STRING

-        

-        Case INPUT_CHECK

-            

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{E3F10C5A-A4B4-42FF-A2C9-6F8198210A07}{563D0F3D-F79D-48F1-AFE4-A2136809B982}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mSheets
->>>>>>
-Attribute VB_Name = "mSheets"

-Option Explicit

-

-Function am_load_now() As Boolean

-    am_load_now = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE")

-End Function

-

-Sub Wks_select(RetSheet As String)

-    Dim sheet As Worksheet

-    For Each sheet In ThisWorkbook.Worksheets

-        If sheet.name = RetSheet Then

-            ThisWorkbook.Worksheets(RetSheet).Select

-            Exit Sub

-        End If

-    Next sheet

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub ret_back(sh As Worksheet)

-    Dim RetSheet As String

-    RetSheet = sh.Range("ret_addr")

-    sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    sh.Range("ret_addr") = ""

-    sh.Range("rec_id") = ""

-    sh.Range("lpu_id") = ""

-    sh.Range("ent_date") = ""

-    sh.Range("lpu_name") = ""

-    sh.Range("lpu_addr") = ""

-    sh.Range("lpu_beds") = ""

-    Wks_select RetSheet

-End Sub

-

-Sub ClearSheetData(r_start As Range)

-    If r_start <> "" Then

-        r_start.Worksheet.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        r_start = ""

-    Else

-        ret_back r_start.Worksheet

-    End If

-End Sub

-

-Sub wks_sel_chng(iset As tInputSet, ByVal Target As Range, sh As Worksheet)

-    Dim DebugMode As Boolean

-    Dim in_range As Range

-    

-    DebugMode = Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-

-    If DebugMode Then

-        sh.Unprotect

-    Else

-        sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    End If

-

-    If iset.vType = INPUT_CHECK Then

-        Set in_range = Target.Worksheet.Range(iset.rChk)

-    Else

-        Set in_range = Target

-    End If

-    

-    Dim str As String

-    str = GetFocusAddress(in_range, sh.Range("h_inputs"))

-

-'    MsgBox Target.Address & "; " & str

-    If str <> Target.address Then

-        sh.Range(str).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-Dlg_lpu_card
->>>>>>
-Attribute VB_Name = "Dlg_lpu_card"

-Attribute VB_Base = "0{137EDDE5-3DB4-4BAD-A245-324DC31ABB36}{3BD7159A-BF6C-403F-B3DF-4834FA9E4D92}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbLPU_List_Change()

-    Dim src As Range

-    Dim idx_src As Integer

-    

-    Set src = Worksheets(VAR_SHEET).Range(Me.cbLPU_List.RowSource)

-    idx_src = Me.cbLPU_List.ListIndex + 1

-    Me.tb_lpu_name.Text = src.Cells(idx_src, 1)

-    Me.tb_lpu_address.Text = src.Cells(idx_src, 2)

-    Me.tbBedsCount.Text = src.Cells(idx_src, 3)

-End Sub

-

-

-Private Sub cbxLPU_List_Enable_Click()

-    

-    If Me.cbxLPU_List_Enable Then

-        

-        Me.tb_lpu_name.Text = ""

-        Me.tb_lpu_name.Enabled = False

-        

-        Me.tb_lpu_address.Text = ""

-        Me.tb_lpu_address.Enabled = False

-        

-        Me.tbBedsCount.Text = ""

-        Me.tbBedsCount.Enabled = False

-        

-        Me.cbLPU_List.Enabled = True

-        cbLPU_List_Change

-    Else

-        Me.tb_lpu_name.Enabled = True

-        Me.tb_lpu_name.Text = ""

-        

-        Me.tb_lpu_address.Enabled = True

-        Me.tb_lpu_address.Text = ""

-        

-        Me.tbBedsCount.Enabled = True

-        Me.tbBedsCount.Text = ""

-        

-        Me.cbLPU_List.Enabled = False

-    End If

-End Sub

-

-<<<<<<
-======================
-UserInfo
->>>>>>
-Attribute VB_Name = "UserInfo"

-Attribute VB_Base = "0{8EB80D4C-3476-421A-A370-6332A07DE509}{A7542905-C9F8-4F39-AD67-B62A88F8F4E6}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Tag = vbOK

-End Sub

-

-Private Sub cbCity_Change()

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_CITY") = Me.cbCity.ListIndex

-        .Calculate

-    End With

-End Sub

-

-Private Sub cbRegion_Change()

-    Dim LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        NewRangeOffsetCol = cbRegion.Value * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).address

-        NewSumRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).address

-        .Calculate

-        .Range("IDX_CITY") = 0

-        cbCity.RowSource = NewCbxRange

-

-    End With

-    cbCity.ListIndex = 0

-End Sub

-

-<<<<<<
-======================
-mREP
->>>>>>
-Attribute VB_Name = "mREP"

-Option Explicit

-

-Sub hwnew()

-    Dim rs As Range

-    Dim re As Object

-    

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    HWReset

-    ReSetREPRecord

-    With Worksheets("REP_QTR")

-        .ClearRepName

-        .Range("REP_QTR_INPUT_DATA").ClearContents

-        .Range("QTR_SEL") = ""

-    End With

-    Worksheets(TITLE_SHEET).Select

-    With Application

-        .DisplayAlerts = False

-        .ThisWorkbook.Save

-        .Quit

-    End With

-End Sub

-

-Function CheckUser() As Boolean

-    Dim objHW() As Long

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    

-    GetHWInfo objHW()

-    i = GetHWRecords(objHW_DB)

-    

-    If i = 0 Then ' First time

-        StoreHWInfo objHW()

-        Worksheets("REP_QTR").Range("QTR_SEL") = ""

-    End If

-    If CheckHWInfo(objHW()) <> True Then

-        CheckUser = False

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    Else

-        CheckUser = SetupUser

-    End If

-End Function

-

-Function SetupUser() As Boolean

-    Dim cUser As tREP

-    Dim idx As Integer

-    Dim dlg_ui As UserInfo

-    

-    Set dlg_ui = New UserInfo

-    

-    cUser = GetREPRecord()

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_REGION") = cUser.Region

-        .Range("IDX_CITY") = cUser.City

-    End With

-        

-    With dlg_ui

-        .cbRegion = cUser.Region

-        .cbCity = cUser.City

-        .tbFName = cUser.FirstName

-        .tbLName = cUser.LastName

-    End With

-    

-    Worksheets(REGS_SHEET).Calculate

-    

-    Dim test_Ok As Boolean

-    test_Ok = False

-    

-    On Error GoTo l1

-

-    Do

-        dlg_ui.Show

-        If dlg_ui.Tag = vbOK Then

-            test_Ok = dlg_ui.tbFName.Value <> "" And dlg_ui.tbLName <> ""

-            If test_Ok Then

-                Exit Do

-            Else

-                MsgBox "Введите имя и фамилию", vbOKOnly, PROGRAM_NAME

-            End If

-        Else

-            Exit Do

-        End If

-    Loop Until False

-l1:

-    If test_Ok Then

-        With cUser

-            .Region = dlg_ui.cbRegion.Value

-            .City = dlg_ui.cbCity.Value

-            .FirstName = dlg_ui.tbFName.Value

-            .LastName = dlg_ui.tbLName.Value

-        End With

-        SetREPRecord cUser

-    Else

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .ThisWorkbook.Saved = True

-            .Quit

-        End With

-    End If

-    SetupUser = test_Ok

-End Function

-

-Sub GetHWInfo(objHW() As Long)

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    i = 1

-    For Each d In dc

-        If d.drivetype = 2 Then ' 2 - HardDisk

-            ReDim Preserve objHW(i)

-            objHW(i) = d.SerialNumber

-            i = i + 1

-        End If

-    Next

-    SortHW objHW

-End Sub

-

-Sub StoreHWInfo(objHW() As Long)

-    UpdateHWRecords objHW

-End Sub

-

-Sub SortHW(objHW() As Long)

-    Dim r As Range

-    Dim rs As Range

-    Dim re As Object

-    Dim i As Integer

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    For i = 1 To UBound(objHW)

-        r = objHW(i)

-        Set r = r.Offset(1, 0)

-    Next i

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).Sort _

-            Key1:=.Range("HW_Number"), _

-            Order1:=xlDescending, _

-            Header:=xlGuess, _

-            OrderCustom:=1, _

-            MatchCase:=False, _

-            Orientation:=xlTopToBottom

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    i = 1

-    Do While r <> ""

-        objHW(i) = r

-        Set r = r.Offset(1, 0)

-        i = i + 1

-    Loop

-End Sub

-

-Function CheckHWInfo(objHW() As Long)

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    CheckHWInfo = False

-        

-    i = GetHWRecords(objHW_DB)

-    If i > 0 Then

-        SortHW objHW_DB

-    End If

-    If UBound(objHW) = UBound(objHW_DB) Then

-        For i = 1 To UBound(objHW)

-            If objHW(i) <> objHW_DB(i) Then

-                Exit Function

-            End If

-        Next i

-        CheckHWInfo = True

-    End If

-End Function

-<<<<<<
-======================
-dbBudget
->>>>>>
-Attribute VB_Name = "dbBudget"

-Option Explicit

-

-Public Type tBUDGET

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    bdgt_NMG As Long

-    bdgt_NFG As Long

-    sale_plan As Long

-End Type

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function GetAll_BDGT_RecordsByLPU_ID(ByRef allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_BDGT_RecordsByLPU_ID = dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection, allBDGT, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function Get_BDGT_Record(ByVal lpu_id As Long, ByVal ent_date As String) As tBUDGET

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    Get_BDGT_Record = dbGet_BDGT_Record(dbConnection, lpu_id, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objBDGT.ID <> 0 then updatre else insert

-Public Sub Insert_BDGT_Record(objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    If objBDGT.id <> 0 Then

-        dbUpdate_BDGT_Record dbConnection, objBDGT

-    Else

-        dbInsert_BDGT_Record dbConnection, objBDGT

-    End If

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Public Sub Delete_BDGT_Record(ByRef objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    dbDelete_BDGT_Record dbConnection, objBDGT

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_BDGT_Record(dbConnection As Object, ByVal lpu_id As Long, ent_date As String) As tBUDGET

-    

-    Dim SQL As String

-    Dim objBDGT As tBUDGET

-    

-    With objBDGT

-        .id = 0

-        .lpu_id = lpu_id

-        .entry_date = ent_date

-        .bdgt_NMG = 0

-        .bdgt_NFG = 0

-        .sale_plan = 0

-    End With

-        

-    

-    SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        With objBDGT

-            .entry_date = dbRecordset("entry_date")

-            .id = dbRecordset("id")

-            .lpu_id = dbRecordset("lpu_id")

-            .bdgt_NFG = dbRecordset("bdgt_NFG")

-            .bdgt_NMG = dbRecordset("bdgt_NMG")

-            .sale_plan = dbRecordset("sale_PLAN")

-        End With

-    End If

-    

-    dbGet_BDGT_Record = objBDGT

-End Function

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection As Object, allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_BDGT_SQL As String

-    Dim getAll_BDGT_SQL As String

-    Dim BDGT_Count As Long

-    BDGT_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_BDGT_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        BDGT_Count = dbRecordset("BDGT_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_BDGT_RecordsbyLPU_ID = BDGT_Count

-    

-    If BDGT_Count > 0 Then

-        'we have records

-        ReDim allBDGT(1 To BDGT_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_BDGT_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpBDGT As tBUDGET

-                 With tmpBDGT

-                    .entry_date = dbRecordset("entry_date")

-                    .id = dbRecordset("id")

-                    .lpu_id = dbRecordset("lpu_id")

-                    .bdgt_NFG = dbRecordset("bdgt_NFG")

-                    .bdgt_NMG = dbRecordset("bdgt_NMG")

-                    .sale_plan = dbRecordset("sale_PLAN")

-                 End With

-                 

-                 allBDGT(index) = tmpBDGT

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbInsert_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "lpu_budget", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    dbRecordset("entry_date") = objBDGT.entry_date

-    dbRecordset("lpu_id") = objBDGT.lpu_id

-    dbRecordset("bdgt_NMG") = objBDGT.bdgt_NMG

-    dbRecordset("bdgt_NFG") = objBDGT.bdgt_NFG

-    dbRecordset("sale_PLAN") = objBDGT.sale_plan

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objBDGT.id = dbRecordset("id")

-  

-End Sub

-

-Public Sub dbUpdate_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu_budget SET " & _

-    "entry_date='" & objBDGT.entry_date & "'," & _

-    "lpu_id=" & objBDGT.lpu_id & "," & _

-    "bdgt_NMG=" & objBDGT.bdgt_NMG & "," & _

-    "bdgt_NFG=" & objBDGT.bdgt_NFG & "," & _

-    "sale_PLAN=" & objBDGT.sale_plan & _

-    " WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-Public Sub dbDelete_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_BDGT_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbDatabase
->>>>>>
-Attribute VB_Name = "dbDatabase"

-Option Explicit

-

-

-Sub dbOpenConnection(dbConnection As Object)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, SQL As String)

-    dbConnection.Execute (SQL)

-End Sub

-

-<<<<<<
-======================
-dbLPU
->>>>>>
-Attribute VB_Name = "dbLPU"

-Option Explicit

-

-Public Type tLPU

-    id As Long

-    rep_id As Long

-    name As String

-    address As String

-    beds As Integer

-End Type

-

-Function Get_LPU_Record(ByVal lpu_id As Long) As tLPU

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_LPU_Record = dbGet_LPU_Record(dbConnection, lpu_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAllLPU(allLPU() As tLPU) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAllLPU = dbGetAllLPU(dbConnection, allLPU)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAllLPUbyQTR(allLPU() As tLPU, ent_date As String) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAllLPUbyQTR = dbGetAllLPUbyQTR(dbConnection, allLPU, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objLPU.id = 0 then insert else update

-Sub Insert_LPU_Record(ByRef objLPU As tLPU)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    If objLPU.id = 0 Then

-        dbInsert_LPU_Record dbConnection, objLPU

-    Else

-        dbUpdate_LPU_Record dbConnection, objLPU

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub Delete_LPU_Record(ByRef objLPU As tLPU)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDelete_LPU_Record dbConnection, objLPU

-    dbCloseConnection dbConnection

-End Sub

-

-Sub Delete_LPU_RecordQTR(ByRef objLPU As tLPU, ent_date As String)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Hir_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Ter_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_ACS_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    

-    dbCloseConnection dbConnection

-    

-End Sub

-

-Function dbGet_LPU_Record(dbConnection As Object, ByVal lpu_id As Long) As tLPU

-    

-    Dim SQL As String

-    Dim objLPU As tLPU

-    

-    objLPU.id = lpu_id

-    objLPU.name = ""

-    objLPU.address = ""

-    

-    SQL = "SELECT * FROM lpu WHERE id=" & lpu_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objLPU.name = dbRecordset("name")

-        objLPU.address = dbRecordset("address")

-        objLPU.rep_id = dbRecordset("rep_id")

-        objLPU.beds = dbRecordset("beds")

-    End If

-    

-    dbGet_LPU_Record = objLPU

-

-End Function

-

-Sub dbInsert_LPU_Record(dbConnection As Object, ByRef objLPU As tLPU)

-  

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu", dbConnection, 2, 2

-    dbRecordset.addnew

-    dbRecordset("name") = objLPU.name

-    dbRecordset("address") = objLPU.address

-    dbRecordset("rep_id") = objLPU.rep_id

-    dbRecordset("beds") = objLPU.beds

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objLPU.id = dbRecordset("id")

-  

-End Sub

-

-Sub dbUpdate_LPU_Record(dbConnection As Object, ByRef objLPU As tLPU)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu SET " & _

-    "name='" & objLPU.name & "'," & _

-    "address='" & objLPU.address & "'," & _

-    "beds=" & objLPU.beds & "," & _

-    "rep_id=" & objLPU.rep_id& & _

-    " WHERE id=" & objLPU.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-

-Function dbGetAllLPU(dbConnection As Object, allLPU() As tLPU) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu"

-    getAll_LPU_SQL = "SELECT * FROM lpu"

-

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAllLPU = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-Function dbGetAllLPUbyQTR(dbConnection As Object, allLPU() As tLPU, ent_date As String) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    Dim where As String

-    where = "WHERE lpu_budget.entry_date like '" & ent_date & "'"

-    

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu_budget " & where

-    

-    getAll_LPU_SQL = "SELECT lpu.id as id, lpu.rep_id as rep_id, lpu.name as name, lpu.address as address, lpu.beds AS beds " & _

-    "FROM lpu, lpu_budget " & where & " AND lpu.id=lpu_budget.lpu_id"

-    

-

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAllLPUbyQTR = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-Sub dbDelete_LPU_Record(dbConnection As Object, ByRef objLPU As tLPU)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu " & _

-    "WHERE id=" & objLPU.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByLPU_ID dbConnection, objLPU.id

-    dbDelete_Hir_RecordsByLPU_ID dbConnection, objLPU.id

-    dbDelete_Ter_RecordsByLPU_ID dbConnection, objLPU.id

-    dbDelete_ACS_RecordsByLPU_ID dbConnection, objLPU.id

-    

-End Sub

-

-Sub dbDelete_LPU_RecordQTR(dbConnection As Object, ByRef objLPU As tLPU, ent_date As String)

-    

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Hir_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Ter_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_ACS_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    

-End Sub

-

-<<<<<<
-======================
-dbREP
->>>>>>
-Attribute VB_Name = "dbREP"

-Option Explicit

-

-Public Type tREP

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function GetREPRecord() As tREP

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetREPRecord = dbGetREPRecord(dbConnection)

-    dbCloseConnection dbConnection

-End Function

-

-Sub SetREPRecord(cUser As tREP)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbSetREPRecord dbConnection, cUser

-    dbCloseConnection dbConnection

-End Sub

-

-Sub ReSetREPRecord()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbReSetREPRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGetREPRecord(dbConnection As Object) As tREP

-    

-    Dim SQL As String

-    Dim objREP As tREP

-    

-    objREP.FirstName = ""

-    objREP.LastName = ""

-    objREP.Region = 0

-    objREP.City = 0

-    SQL = "SELECT firstname, lastname, region, city FROM " & _

-          "rep"

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open SQL, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREP.FirstName = dbRecordset("firstname")

-        objREP.LastName = dbRecordset("lastname")

-        objREP.Region = dbRecordset("region")

-        objREP.City = dbRecordset("city")

-        

-    End If

-    

-    dbGetREPRecord = objREP

-        

-End Function

-

-Public Sub dbSetREPRecord(dbConnection As Object, ByRef objREP As tREP)

-  

-    Dim DeleteSQL As String

-    Dim InsertSQL As String

-    

-    DeleteSQL = "DELETE FROM rep"

-    InsertSQL = "INSERT INTO rep (firstname, lastname, region, city) VALUES (" & _

-    "'" & objREP.FirstName & "', " & _

-    "'" & objREP.LastName & "', " & _

-    objREP.Region & ", " & _

-    objREP.City & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    dbRecordset.Open InsertSQL, dbConnection

-End Sub

-

-Public Sub dbReSetREPRecord(dbConnection As Object)

-  

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM rep"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    CheckWorkBooksArround Wb

-End Sub

-

-

-Sub CheckWorkBooksArround(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If app.Workbooks.Count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKOnly, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-        Exit Sub

-    End If

-

-End Sub

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub SaveExcelState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-        ActiveWorkbook.DisplayDrawingObjects = xlDisplayShapes

-        

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.Count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars(STDBAR_NAME).Visible = False

-End Sub

-

-

-Public Sub RestoreExcelState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars(STDBAR_NAME).Visible = True

-End Sub

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Public Const STDBAR_NAME = "Worksheet Menu Bar"

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Export"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 620

-                        .OnAction = "cmExport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Exit && Restore Excel"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 548

-                        .OnAction = "cmExitRestore"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(flag As Boolean)

-    If flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars(STDBAR_NAME)

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmExport()

-    dbExport

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    Dim dlg As dlgAbout

-    Set dlg = New dlgAbout

-    

-    dlg.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlg.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlg.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlg.Show

-End Sub

-

-Sub cmMail2Support()

-    Dim err_description As String

-    Dim dlg_msg As dlg_Mail

-    Set dlg_msg = New dlg_Mail

-    With dlg_msg

-        .Show

-        If .Tag = vbOK Then

-            ThisWorkbook.Worksheets(VAR_SHEET).Range("ERR_MESSAGE") _

-                = .tbMessage.Text

-            ThisWorkbook.Save

-            ThisWorkbook.SendMail Recipients:="infra@i-rs.ru", Subject:=PROGRAM_NAME & " ver.:" & PROGRAM_VERSION

-            MsgBox "Сообщение об ошибке отправлено. Перезагрузите программу.", vbOKOnly, PROGRAM_NAME

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-    End With

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-'        helppath = "hh.exe " & .Path & "\Telfast.chm"

-'        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub set_work_mode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetupEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-End Sub

-

-Sub cmSetStandaloneMode()

-    set_work_mode

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    Dim dlg As dlgGetPwd

-    rp = common_pwd

-    

-    Set dlg = New dlgGetPwd

-    dlg.edPwd = ""

-    dlg.Show

-    

-    If dlg.edPwd = rp Then

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmHomePage()

-    ThisWorkbook.Worksheets("REP_QTR").Select

-End Sub

-

-Sub cmExitRestore()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = True

-    Application.Quit

-End Sub

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    Dim dlg_prn As dlgPrint

-    

-    Set dlg_prn = New dlgPrint

-    

-    With dlg_prn

-        .cbMainReport = True

-        .cbMainBudget = False

-        .cbSrcData = False

-        .cbAllSheets = False

-    

-        .Show

-    

-        If .Tag = vbCancel Then

-            Exit Sub

-        End If

-    End With

-    

-    Dim PrnIdx As Integer

-    

-    With dlg_prn

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("REP_QTR", "budget", "Final")

-    Case 1111

-        plist = Array("REP_QTR", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("REP_QTR")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Clexane bar"

-Public Const common_pwd As String = "crdjhxtyjr"

-

-

-Sub SetupEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    Wb.Worksheets(TITLE_SHEET).Select

-    With Application

-        .Caption = PROGRAM_NAME & " " & PROGRAM_VERSION

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .SaveExcelState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = False

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Wb.Worksheets(TITLE_SHEET).Select

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-'                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    If cWindow.Type = xlWorkbook Then

-                        cWindow.DisplayHeadings = True

-                    End If

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu True

-        End If

-        With mobjAppState

-            .RestoreExcelState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Worksheets(TITLE_SHEET).Select

-'        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Option Explicit

-

-Sub UpdateHWRecords(objHW() As Long)

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    dbUpdateHWRecords dbConnection, objHW

-    dbCloseConnection dbConnection

-End Sub

-

-Function GetHWRecords(objHW() As Long) As Integer

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    GetHWRecords = dbGetHWRecords(dbConnection, objHW)

-    dbCloseConnection dbConnection

-End Function

-

-Sub HWReset()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbInsertHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    

-    Dim dbRecordset As Object

-    Dim i As Long

-    

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "hw", dbConnection, 2, 2

-    

-    For i = 1 To UBound(objHW)

-        dbRecordset.addnew

-        dbRecordset("num") = objHW(i)

-        dbRecordset.Update

-    Next i

-    

-End Sub

-

-Sub dbUpdateHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    dbDeleteHWRecord dbConnection

-    dbInsertHWRecords dbConnection, objHW

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-dbHir
->>>>>>
-Attribute VB_Name = "dbHir"

-Option Explicit

-

-Public Type tHIRURGIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    operations_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_ambulator_clexan_40mg As Integer

-    patients_ambulator_clexan_20mg As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-    patients_stationar_clexan_40mg As Integer

-    patients_stationar_clexan_20mg As Integer

-End Type

-

-' if objHir.ID <> 0 then updatre else insert

-Sub Insert_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objHir.id <> 0 Then

-        dbUpdate_Hir_Record dbConnection, objHir

-    Else

-        dbInsert_Hir_Record dbConnection, objHir

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Hir_RecordsByLPU_ID(ByRef allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Hir_RecordsByLPU_ID = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, allHir, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Hir_Record dbConnection, objHir

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objHir.ID <> 0 then updatre else insert

-

-Sub dbInsert_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_hir", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objHir

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("operations_per_quarter") = .operations_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_ambulator_clexan_20mg") = .patients_ambulator_clexan_20mg

-        dbRecordset("patients_ambulator_clexan_40mg") = .patients_ambulator_clexan_40mg

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-        dbRecordset("patients_stationar_clexan_20mg") = .patients_stationar_clexan_20mg

-        dbRecordset("patients_stationar_clexan_40mg") = .patients_stationar_clexan_40mg

-        

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objHir.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim UpdateSQL As String

-    

-    With objHir

-        UpdateSQL = "UPDATE lpu_hir SET " & _

-            "entry_date='" & objHir.entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "operations_per_quarter=" & .operations_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_ambulator_clexan_20mg=" & .patients_ambulator_clexan_20mg & "," & _

-            "patients_ambulator_clexan_40mg=" & .patients_ambulator_clexan_40mg & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & "," & _

-            "patients_stationar_clexan_20mg=" & .patients_stationar_clexan_20mg & "," & _

-            "patients_stationar_clexan_40mg=" & .patients_stationar_clexan_40mg & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_Hir_RecordsbyLPU_ID(dbConnection As Object, allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Hir_SQL As String

-    Dim getAll_Hir_SQL As String

-    Dim Hir_Count As Long

-    Hir_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Hir_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Hir_Count = dbRecordset("HIR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Hir_RecordsbyLPU_ID = Hir_Count

-    

-    If Hir_Count > 0 Then

-        'we have records

-        ReDim allHir(1 To Hir_Count)

-        Dim index As Integer

-        index = 1

-        dbRecordset.Open getAll_Hir_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpHir As tHIRURGIA

-                 With tmpHir

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .operations_per_quarter = dbRecordset("operations_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_ambulator_clexan_20mg = dbRecordset("patients_ambulator_clexan_20mg")

-                    .patients_ambulator_clexan_40mg = dbRecordset("patients_ambulator_clexan_40mg")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                    .patients_stationar_clexan_20mg = dbRecordset("patients_stationar_clexan_20mg")

-                    .patients_stationar_clexan_40mg = dbRecordset("patients_stationar_clexan_40mg")

-                 End With

-                 

-                 allHir(index) = tmpHir

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE ID=" & objHir.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Hir_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbTer
->>>>>>
-Attribute VB_Name = "dbTer"

-Option Explicit

-

-Public Type tTERAPIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objTer.ID <> 0 then updatre else insert

-Sub Insert_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objTer.id <> 0 Then

-        dbUpdate_Ter_Record dbConnection, objTer

-    Else

-        dbInsert_Ter_Record dbConnection, objTer

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Ter_RecordsByLPU_ID(ByRef allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Ter_RecordsByLPU_ID = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, allTer, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Ter_Record dbConnection, objTer

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objTer.ID <> 0 then updatre else insert

-

-Sub dbInsert_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_ter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objTer

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("risk_percent") = Double2Str(.risk_percent, 3)

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objTer.id = dbRecordset("ID")

-

-End Sub

-

-Sub test()

-    Dim s As String

-    Dim d As Single

-    d = 1235.6789

-    s = Format(d, "####0,00")

-    MsgBox s

-End Sub

-

-Sub dbUpdate_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim Update_SQL As String

-    

-    With objTer

-        Update_SQL = "UPDATE lpu_ter SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_Ter_RecordsbyLPU_ID(dbConnection As Object, allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Ter_SQL As String

-    Dim getAll_Ter_SQL As String

-    Dim Ter_Count As Long

-    Ter_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Ter_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Ter_Count = dbRecordset("TER_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Ter_RecordsbyLPU_ID = Ter_Count

-    

-    If Ter_Count > 0 Then

-        'we have records

-        ReDim allTer(1 To Ter_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_Ter_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpTer As tTERAPIA

-                 With tmpTer

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 allTer(index) = tmpTer

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE ID=" & objTer.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Ter_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-mLPU_LIST
->>>>>>
-Attribute VB_Name = "mLPU_LIST"

-Option Explicit

-

-Public Const CINP_AREA As String = "B12"

-Public Const CLPU_NAME As Integer = 0

-Public Const CLPU_NAME1 As Integer = 1

-Public Const CLPU_NAME2 As Integer = 2

-Public Const CLPU_ID As Integer = 3

-Public Const CLPU_BEDS As Integer = 4

-Public Const CLPU_NFG As Integer = 5

-Public Const CLPU_NMG As Integer = 6

-Public Const CLPU_HIR As Integer = 7

-Public Const CLPU_TER As Integer = 8

-Public Const CLPU_CAR As Integer = 9

-Public Const CLPU_FACT As Integer = 10

-Public Const CLPU_PLAN As Integer = 11

-Public Const CLPU_PAT_LPU As Integer = 16

-Public Const CLPU_BDGT As Integer = 17

-Public Const CLPU_PAT_ALL As Integer = 16

-

-

-

-Sub EditLPU(cLPU As tLPU, ent_date As String)

-    Dim del_request As Integer

-    Dim allLPU() As tLPU

-    Dim lpu_count As Integer

-    Dim i As Integer

-    Dim tmp_LPU_List As Range

-    Dim tmp_LPU_List_Addr As String

-    Dim r_end As Range

-    Dim dlg As Dlg_lpu_card

-    

-    Set dlg = New Dlg_lpu_card

-    

-    lpu_count = GetAllLPU(allLPU)

-    With Worksheets(VAR_SHEET)

-        Set tmp_LPU_List = .Range("tmp_LPU_List")

-        Set r_end = .Range(tmp_LPU_List, tmp_LPU_List.End(xlDown))

-        Set r_end = .Range(r_end, r_end.End(xlToRight))

-        .Range(tmp_LPU_List, r_end).ClearContents

-    End With

-        

-    If lpu_count <> 0 Then

-        dlg.cbxLPU_List_Enable.Enabled = True

-        For i = 1 To UBound(allLPU)

-            tmp_LPU_List.Cells(i, 1) = allLPU(i).name

-            tmp_LPU_List.Cells(i, 2) = allLPU(i).address

-            tmp_LPU_List.Cells(i, 3) = allLPU(i).beds

-            tmp_LPU_List.Cells(i, 4) = allLPU(i).id

-        Next i

-    Else

-        dlg.cbxLPU_List_Enable.Enabled = False

-    End If

-    

-    tmp_LPU_List_Addr = Worksheets(VAR_SHEET).name & "!" & _

-            Worksheets(VAR_SHEET).Range(tmp_LPU_List, tmp_LPU_List.End(xlDown)).address

-

-    With dlg

-        .cbLPU_List.RowSource = tmp_LPU_List_Addr

-        .cbLPU_List.ListIndex = 0

-        .cbxLPU_List_Enable = False

-        .cbLPU_List.Enabled = False

-        If cLPU.id <> 0 Then

-            .cbxLPU_List_Enable.Enabled = False

-        Else

-            If lpu_count <> 0 Then

-                .cbxLPU_List_Enable.Enabled = True

-            Else

-                .cbxLPU_List_Enable.Enabled = False

-            End If

-        End If

-        .tb_lpu_name.Text = cLPU.name

-        .tb_lpu_address.Text = cLPU.address

-        .tbBedsCount = cLPU.beds

-

-        .Tag = vbCancel

-    End With

-    

-    dlg.Show

-    

-    If Not IsNumeric(dlg.Tag) Then

-        Exit Sub

-    End If

-    

-    If dlg.Tag = vbOK Then

-        Dim n As Variant

-        Dim test As Integer

-        test = 0

-        n = dlg.tbBedsCount.Value

-        If Not IsNumeric(n) Then

-            test = 1

-        Else

-            If n = 0 Then

-                test = 1

-            End If

-        End If

-        If test = 0 Then

-            

-            cLPU.name = dlg.tb_lpu_name.Text

-            cLPU.address = dlg.tb_lpu_address.Text

-            cLPU.beds = dlg.tbBedsCount.Value

-                                    

-            If cLPU.name = "" Or cLPU.address = "" Then

-                test = 2

-            End If

-        End If

-        Select Case test

-            Case 0

-                If dlg.cbxLPU_List_Enable.Value = True Then

-                    cLPU.id = tmp_LPU_List.Cells(dlg.cbLPU_List.ListIndex + 1, 4)

-                End If

-                Insert_LPU_Record cLPU

-                ' Проверить наличие данных для ЛПУ в квартале

-                Dim bdgt As tBUDGET

-                bdgt = Get_BDGT_Record(cLPU.id, ent_date)

-                ' Записи нет: создать пустую запись в lpu_budget

-                If bdgt.id = 0 Then

-                    bdgt.lpu_id = cLPU.id

-                    bdgt.entry_date = ent_date

-                    Insert_BDGT_Record bdgt

-                End If

-            Case 1

-                MsgBox "Коечная мощьность измеряется числом более чем 1!", vbOKOnly, PROGRAM_NAME

-            Case 2

-                MsgBox "Наименование и адрес ЛПУ не должны быть пустыми!", vbOKOnly, PROGRAM_NAME

-        End Select

-    End If

-End Sub

-

-Sub Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-

-End Sub

-

-Sub Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btLPU_DEL_IT()

-    Dim cLPU As tLPU

-    Dim ent_date As String

-    Dim delete_all As Integer

-    Dim dlg_del As dlg_LPU_delete

-    

-    With Worksheets("LPU_LIST")

-        ent_date = .Range("ent_date")

-        cLPU.id = .getCurrentLPU_ID()

-    End With

-    

-    If cLPU.id = 0 Then

-        MsgBox "Укажите удаляемый объект", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    cLPU = Get_LPU_Record(cLPU.id)

-    

-    Set dlg_del = New dlg_LPU_delete

-    With dlg_del

-        .chbDeleteQTR.Value = True

-        .chbDeleteAll.Value = False

-        .lComment = ent_date & ": Удаление ЛПУ '" _

-        & cLPU.name & "', расположенного по адресу:" _

-        & cLPU.address & "."

-        .Show

-        

-        If .Tag = vbOK Then

-            If .chbDeleteAll.Value Then

-                delete_all = _

-                    MsgBox("Все записи об ЛПУ с именем '" & cLPU.name & _

-                    "' будут удалены навсегда.", vbOK, PROGRAM_NAME)

-                If delete_all = vbOK Then

-                    Delete_LPU_Record cLPU

-                End If

-            Else

-                Delete_LPU_RecordQTR cLPU, ent_date

-            End If

-        End If

-    End With

-    

-    With ThisWorkbook

-        .Worksheets(TITLE_SHEET).Select

-        .Worksheets("LPU_LIST").Select

-    End With

-End Sub

-

-Sub btLPU_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Activate

-End Sub

-

-

-Sub btLPU_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim lpu_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("QTR_ACTION").Value

-    With Worksheets("LPU_LIST")

-        ent_date = .getEnt_date()

-        

-    

-        lpu_id = .getCurrentLPU_ID

-        If lpu_id <> 0 And i = 1 Then

-            lpu_id = 0

-        End If

-        If lpu_id = 0 Then

-            i = 1

-        End If

-        Select Case i

-            Case 1, 6

-                .SelectLPU_NAME lpu_id, ent_date

-                .Range("JUMP") = ""

-            Case 2

-                If lpu_id <> 0 Then

-                    .SelectLPU_BDGT lpu_id, ent_date

-                    .Range("JUMP") = "LPU_BDGT"

-                End If

-            Case 3

-                If lpu_id <> 0 Then

-                    .SelectLPU_HIR lpu_id, ent_date

-                    .Range("JUMP") = "LPU_CLSN_HIR"

-                End If

-            Case 4

-                If lpu_id <> 0 Then

-                    .SelectLPU_TER lpu_id, ent_date

-                    .Range("JUMP") = "LPU_CLSN_TER"

-                End If

-            Case 5

-                If lpu_id <> 0 Then

-                    .SelectLPU_C_ACS lpu_id, ent_date

-                    .Range("JUMP") = "LPU_CLSN_C_ACS"

-                End If

-        End Select

-    End With

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-dbQTR
->>>>>>
-Attribute VB_Name = "dbQTR"

-Option Explicit

-

-Public Type tQTR

-    id As Long

-    entry_date As String

-    rep_id As Long

-    sale_plan As Long

-    ClxnH20mg As Long

-    ClxnH40mg As Long

-    ClxnT40mg As Long

-    ClxnC_IM As Long

-    ClxnC_ACS As Long

-End Type

-

-

-Function GetLastQTR_fromDB() As String

-    Dim dbConnection As Object

-    Dim getCount_QTR_SQL As String

-    Dim getLast_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter"

-    getLast_QTR_SQL = "SELECT MAX(entry_date) as ent_date FROM quarter"

-    

-    dbOpenConnection dbConnection

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    If QTR_Count > 0 Then

-        'we have records

-        dbRecordset.Open getLast_QTR_SQL, dbConnection

-        getLast_QTR_SQL = dbRecordset("ent_date")

-    Else

-        getLast_QTR_SQL = ""

-    End If

-    

-    GetLastQTR_fromDB = getLast_QTR_SQL

-    dbCloseConnection dbConnection

-End Function

-

-Sub Insert_QTR_Record(ByRef objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objQTR.id <> 0 Then

-        dbUpdate_QTR_Record dbConnection, objQTR

-    Else

-        dbInsert_QTR_Record dbConnection, objQTR

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-Function Get_QTR_Record(ent_date As String) As tQTR

-    Dim dbConnection As Object

-    Dim allQTR() As tQTR

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    i = dbGetAll_QTR_Records(dbConnection, allQTR, ent_date)

-    If i <> 0 Then

-        Get_QTR_Record = allQTR(1)

-    End If

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTR_Records(ByRef All_QTR() As tQTR, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_QTR_Records = dbGetAll_QTR_Records(dbConnection, All_QTR, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_QTR_Record(ByRef objQTR As tQTR)

-    Dim dbConnection As Object

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_QTR_Record dbConnection, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objQTR.ID <> 0 then updatre else insert

-Sub dbInsert_QTR_Record(dbConnection As Object, ByRef objQTR As tQTR)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "quarter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objQTR

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("sale_plan") = .sale_plan

-        dbRecordset("rep_id") = .rep_id

-        dbRecordset("ClxnH20mg") = .ClxnH20mg

-        dbRecordset("ClxnH40mg") = .ClxnH40mg

-        dbRecordset("ClxnT40mg") = .ClxnT40mg

-        dbRecordset("ClxnC_IM") = .ClxnC_IM

-        dbRecordset("ClxnC_ACS") = .ClxnC_ACS

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objQTR.id = dbRecordset("id")

-

-End Sub

-

-Sub dbUpdate_QTR_Record(dbConnection As Object, ByRef objQTR As tQTR)

-    Dim Update_SQL As String

-    

-    With objQTR

-        Update_SQL = "UPDATE quarter SET " & _

-            "entry_date='" & .entry_date & "'" & "," & _

-            "rep_id=" & .rep_id & "," & _

-            "sale_plan=" & .sale_plan & "," & _

-            "ClxnH20mg=" & .ClxnH20mg & "," & _

-            "ClxnH40mg=" & .ClxnH40mg & "," & _

-            "ClxnT40mg=" & .ClxnT40mg & "," & _

-            "ClxnC_IM=" & .ClxnC_IM & "," & _

-            "ClxnC_ACS=" & .ClxnC_ACS & _

-            " WHERE id=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if ent_date = % then all_records

-Function dbGetAll_QTR_Records(dbConnection As Object, All_QTR() As tQTR, ent_date As String) As Integer

-    

-    Dim getCount_QTR_SQL As String

-    Dim getAll_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter WHERE entry_date like '" & ent_date & "'"

-    getAll_QTR_SQL = "SELECT * FROM quarter WHERE entry_date like '" & ent_date & "' ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_QTR_Records = QTR_Count

-    

-    If QTR_Count > 0 Then

-        'we have records

-        ReDim All_QTR(1 To QTR_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTR_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTR As tQTR

-                 With tmp_QTR

-                    .entry_date = dbRecordset("entry_date")

-                    .rep_id = dbRecordset("rep_id")

-                    .sale_plan = dbRecordset("sale_plan")

-                    .ClxnH20mg = dbRecordset("ClxnH20mg")

-                    .ClxnH40mg = dbRecordset("ClxnH40mg")

-                    .ClxnT40mg = dbRecordset("ClxnT40mg")

-                    .ClxnC_IM = dbRecordset("ClxnC_IM")

-                    .ClxnC_ACS = dbRecordset("ClxnC_ACS")

-                    .id = dbRecordset("id")

-                 End With

-                 

-                 All_QTR(index) = tmp_QTR

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_QTR_Record(dbConnection As Object, ByRef objQTR As tQTR)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM quarter " & _

-    "WHERE id=" & objQTR.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByQTR dbConnection, objQTR.entry_date

-    dbDelete_Hir_RecordsByQTR dbConnection, objQTR.entry_date

-    dbDelete_Ter_RecordsByQTR dbConnection, objQTR.entry_date

-    dbDelete_ACS_RecordsByQTR dbConnection, objQTR.entry_date

-       

-End Sub

-<<<<<<
-======================
-cdbQTR
->>>>>>
-Attribute VB_Name = "cdbQTR"

-Option Explicit

-

-Public Type tQTR_COMMON

-    qtr As tQTR

-    i_lcd As Long           ' число ЛПУ в СПИСКЕ

-    lcd() As tLPU_COMMON    ' список ЛПУ

-    c_beds As Long          ' сумма коек

-    c_bdgt_NFG As Long      ' общий бюджет на НФГ

-    c_bdgt_NMG As Long      ' общий бюджет на НМГ

-    c_bdgt_LPU As Long      ' общий бюджет на гепарины

-    c_sale_PLAN As Long     ' план продаж репа

-    c_sale_ALL As Long      ' продажи

-    c_sale_HIR As Long      ' в хирургии

-    c_sale_TER  As Long     ' в терапии

-    c_sale_CRD  As Long     ' в кардиологии

-    c_pat_HIR   As Long     ' пациенты

-    c_pat_TER   As Long     '

-    c_pat_CRD   As Long     '

-    c_pat_ALL   As Long     '

-    c_pat_LPU   As Long     ' Всего операций

-End Type

-

-Function Get_QTR_CommonList(ByRef qcd() As tQTR_COMMON) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_QTR_CommonList = dbGet_QTR_CommonList(dbConnection, qcd)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_CommonList(dbConnection As Object, ByRef qcd() As tQTR_COMMON) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim allQTR() As tQTR

-    i = dbGetAll_QTR_Records(dbConnection, allQTR, "%")

-    dbGet_QTR_CommonList = i

-    If i > 0 Then

-        ReDim qcd(i)

-        For i = 1 To UBound(allQTR)

-            With qcd(i)

-                .qtr = allQTR(i)

-                .c_beds = 0

-                .c_bdgt_NFG = 0

-                .c_bdgt_NMG = 0

-                .c_bdgt_LPU = 0

-                .c_sale_PLAN = 0

-                .c_pat_HIR = 0

-                .c_pat_TER = 0

-                .c_pat_CRD = 0

-                .c_pat_ALL = 0

-                .c_sale_HIR = 0

-                .c_sale_TER = 0

-                .c_sale_CRD = 0

-                .c_sale_ALL = 0

-                .c_pat_LPU = 0

-                

-                j = dbGet_LPU_CommonQTR(dbConnection, .lcd, .qtr)

-                .i_lcd = j

-                If j > 0 Then

-                    For j = 1 To UBound(.lcd)

-                        .c_beds = .c_beds + .lcd(j).lpu.beds

-                        .c_bdgt_NFG = .c_bdgt_NFG + .lcd(j).bdgt.bdgt_NFG

-                        .c_bdgt_NMG = .c_bdgt_NMG + .lcd(j).bdgt.bdgt_NMG

-                        .c_bdgt_LPU = .c_bdgt_LPU + .lcd(j).bdgt_LPU

-                        .c_sale_PLAN = .c_sale_PLAN + .lcd(j).bdgt.sale_plan

-                        .c_pat_HIR = .c_pat_HIR + .lcd(j).pat_HIR

-                        .c_pat_TER = .c_pat_TER + .lcd(j).pat_TER

-                        .c_pat_CRD = .c_pat_CRD + .lcd(j).pat_CRD

-                        .c_pat_ALL = .c_pat_ALL + .lcd(j).pat_ALL

-                        .c_sale_HIR = .c_sale_HIR + .lcd(j).sale_HIR

-                        .c_sale_TER = .c_sale_TER + .lcd(j).sale_TER

-                        .c_sale_CRD = .c_sale_CRD + .lcd(j).sale_CRD

-                        .c_sale_ALL = .c_sale_ALL + .lcd(j).sale_ALL

-                        .c_pat_LPU = .c_pat_LPU + .lcd(j).pat_LPU

-                    Next j

-                    

-                End If

-            End With

-        Next i

-    End If

-End Function

-

-Function GetLastQtr() As String

-    Dim s As String

-    Dim r As Range

-    Set r = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Do While r.Cells(1, 1) <> ""

-        s = r.Cells(1, 1)

-        Set r = r.Cells.Offset(1, 0)

-    Loop

-    GetLastQtr = s

-End Function

-

-Function GetNextQTR(ent_date As String) As String

-    Dim rd As Range

-    Dim idx As Integer

-    Dim b As Variant

-    Dim dlg As dlg_newQTR

-    Set dlg = New dlg_newQTR

-    

-    On Error GoTo l_exit

-    If ent_date = "" Then

-        Dim ir As Variant

-        idx = 0

-        dlg.Show

-        b = dlg.Tag

-            

-        If IsNumeric(b) Then

-            GetNextQTR = dlg.cbQTR

-        Else

-            GetNextQTR = ""

-        End If

-    Else

-        Set rd = Worksheets(VAR_SHEET).Range("Date_Lst")

-        idx = WorksheetFunction.Match(ent_date, rd, 0)

-        GetNextQTR = WorksheetFunction.index(rd, idx + 1, 1)

-    End If

-l_exit:

-End Function

-<<<<<<
-======================
-mRestView
->>>>>>
-Attribute VB_Name = "mRestView"

-Option Explicit

-

-Sub xlRestoreView()

-Attribute xlRestoreView.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute xlRestoreView.VB_ProcData.VB_Invoke_Func = " \n14"

-    With Application

-        .CommandBars("Standard").Visible = True

-        .CommandBars("Formatting").Visible = True

-        .DisplayFormulaBar = True

-        .DisplayStatusBar = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = True

-        .EditDirectlyInCell = True

-    End With

-End Sub

-<<<<<<
-======================
-dlg_newQTR
->>>>>>
-Attribute VB_Name = "dlg_newQTR"

-Attribute VB_Base = "0{2FC04B4C-EB99-433E-ACDB-A920D02B9B5B}{777B85CC-ADE3-4188-94C8-9E07DA8B5076}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mDec2TS
->>>>>>
-Attribute VB_Name = "mDec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-CHRT_LPU_BBL
->>>>>>
-Attribute VB_Name = "CHRT_LPU_BBL"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Unprotect

-    Range("view_key") = True

-    On Error Resume Next

-    ChangeLabels

-    Range("A1").Select

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Unprotect

-    Dim s As String

-    s = Range("ret_addr")

-    Protect UserInterfaceOnly:=True

-    Wks_select (s)

-End Sub

-

-Sub BCLabelChng_Click()

-    Unprotect

-    If Range("view_key") Then

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать названия"

-    Else

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать объемы"

-    End If

-    Range("view_key") = Not Range("view_key")

-    ChangeLabels

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub ChangeLabels()

-    Dim i As Integer

-    Dim offset_text As Integer

-    Dim src As Range

-    Set src = Range("CHRT_BBL_DATA")

-    

-    offset_text = 3

-    If Range("view_key") Then

-        offset_text = 4

-    End If

-    

-    On Error GoTo ExitLabel

-    

-    With ChartObjects(1).Chart

-        With .SeriesCollection(1)

-            For i = 1 To .Points.Count

-                On Error Resume Next

-                .Points(i).DataLabel.Characters.Text = Format(src.Cells(i, offset_text))

-            Next i

-        End With

-    End With

-ExitLabel:

-End Sub

-

-<<<<<<
-======================
-CHRT_PAT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PAT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-<<<<<<
-======================
-CHRT_PAT_LPU
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_nextQTR
->>>>>>
-Attribute VB_Name = "dlg_nextQTR"

-Attribute VB_Base = "0{3F7D7D75-90F6-4829-9E24-CA5391BB2A03}{A1A0F296-0D28-4123-8E38-82FA6EE6F2EF}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-

-<<<<<<
-======================
-cdbLPU
->>>>>>
-Attribute VB_Name = "cdbLPU"

-Option Explicit

-

-Public Type tLPU_COMMON

-    lpu As tLPU

-    bdgt As tBUDGET

-    i_hir As Long

-    hir() As tHIRURGIA

-    i_ter As Long

-    ter() As tTERAPIA

-    i_ACS As Long

-    ACS() As tACS

-    bdgt_LPU As Long

-    sale_HIR As Long

-    sale_TER As Long

-    sale_CRD As Long

-    sale_ALL As Long

-    pat_HIR As Long

-    pat_TER As Long

-    pat_CRD As Long

-    pat_ALL As Long     ' Сумма всех пациентов на клексане

-    pat_LPU As Long     ' Число потенциальных пациентов для продаж клексана

-End Type

-

-Function Get_LPU_CommonQTR(ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    Get_LPU_CommonQTR = dbGet_LPU_CommonQTR(dbConnection, lcd, objQTR)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_CommonQTR(dbConnection As Object, ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    i = dbGetAllLPUbyQTR(dbConnection, allLPU, objQTR.entry_date)

-    dbGet_LPU_CommonQTR = i

-    If i > 0 Then

-        ReDim lcd(i)

-        For i = 1 To UBound(allLPU)

-            dbGet_LPU_Common dbConnection, lcd(i), allLPU(i), objQTR

-        Next i

-    End If

-End Function

-

-Sub Get_LPU_Common(ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    dbGet_LPU_Common dbConnection, lcd, cLPU, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbGet_LPU_Common(dbConnection As Object, ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-

-    lcd.lpu = cLPU

-    lcd.bdgt = dbGet_BDGT_Record(dbConnection, cLPU.id, objQTR.entry_date)

-    lcd.i_hir = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, lcd.hir, cLPU.id, objQTR.entry_date)

-    lcd.i_ter = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, lcd.ter, cLPU.id, objQTR.entry_date)

-    lcd.i_ACS = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, lcd.ACS, cLPU.id, objQTR.entry_date)

-    With lcd

-        .bdgt_LPU = .bdgt.bdgt_NFG + .bdgt.bdgt_NMG

-        .pat_LPU = 0

-        If .i_hir > 0 Then

-            .pat_HIR = .hir(1).patients_ambulator_clexan + .hir(1).patients_stationar_clexan

-            .sale_HIR = objQTR.ClxnH20mg * (.hir(1).patients_ambulator_clexan_20mg + .hir(1).patients_stationar_clexan_20mg)

-            .sale_HIR = .sale_HIR + objQTR.ClxnH40mg * (.hir(1).patients_ambulator_clexan_40mg + .hir(1).patients_stationar_clexan_40mg)

-            .pat_LPU = .pat_LPU + .hir(1).operations_per_quarter

-        End If

-        If .i_ter > 0 Then

-            .pat_TER = .ter(1).patients_ambulator_clexan + .ter(1).patients_stationar_clexan

-            .sale_TER = .pat_TER * objQTR.ClxnT40mg

-            .pat_LPU = .pat_LPU + .ter(1).patients_per_quarter

-        End If

-        If .i_ACS > 0 Then

-            .pat_CRD = .ACS(1).patients_stationar_clexan

-            .sale_CRD = .pat_CRD * objQTR.ClxnC_ACS

-            .pat_LPU = .pat_LPU + .ACS(1).patients_per_quarter

-        End If

-        .pat_ALL = .pat_HIR + .pat_TER + .pat_CRD

-        .sale_ALL = .sale_HIR + .sale_TER + .sale_CRD

-    End With

-End Sub

-

-<<<<<<
-======================
-CHRT_PIE
->>>>>>
-Attribute VB_Name = "CHRT_PIE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-   

-    Unprotect

-    On Error Resume Next

-    Range("P5:Q24").Sort _

-        Key1:=Range("Q5"), _

-        Order1:=xlDescending, _

-        Header:=xlGuess, _

-        OrderCustom:=1, _

-        MatchCase:=False, _

-        Orientation:=xlTopToBottom

-        

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PLN_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PLN_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_BDGT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_BDGT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_LPU_delete
->>>>>>
-Attribute VB_Name = "dlg_LPU_delete"

-Attribute VB_Base = "0{91AE5FA0-01C7-4C10-9E5F-D1D2DDF29401}{5726592A-BC0A-4E79-A963-35D354045716}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlg_Mail
->>>>>>
-Attribute VB_Name = "dlg_Mail"

-Attribute VB_Base = "0{FB055133-927F-41FF-BC90-442833A40591}{11BCAB43-1EDD-440B-AB0E-20CD6E42E11A}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dbREP_id
->>>>>>
-Attribute VB_Name = "dbREP_id"

-Public Type tID_REP

-    id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Public Type tID_REP_COMMON

-    id_rep As tID_REP

-    i_qtr As Long

-    qtrs As tQTR_COMMON

-End Type

-<<<<<<
-======================
-cdbExport
->>>>>>
-Attribute VB_Name = "cdbExport"

-Option Explicit

-

-Function GetDBSN() As String

-    Dim n As Long

-    Randomize Timer

-    n = Int((100000000 - 1000000 + 1) * Rnd + 1000000)

-    GetDBSN = Dec2ThirtySix(n)

-End Function

-

-Sub dbExport()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim last_qtr As String

-    

-    On Error GoTo ErrHandler

-    

-    last_qtr = GetLastQTR_fromDB

-    If last_qtr = "" Then

-        MsgBox "Нет записей в базе данных. Экспорт невозможен.", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & last_qtr & "_" & GetDBSN() & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Данные экспортированы в файл:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для передачи", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-Exit Sub

-

-ErrHandler:

-    If err.number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-<<<<<<
-======================
-mRegs
->>>>>>
-Attribute VB_Name = "mRegs"

-Option Explicit

-

-Function GetRegionName(idx As Integer) As String

-    GetRegionName = Worksheets(REGS_SHEET).Range("LST_REGIONS").Cells(idx + 1, 1).Text

-End Function

-

-Function GetCityName(idx_reg As Integer, idx_city As Integer) As String

-    GetCityName = Worksheets(REGS_SHEET).Range("CITY_TABLES").Offset(idx_city + 1, idx_reg * 2).Text

-End Function

-

-Sub t()

-    Dim r As Integer

-    Dim c As Integer

-    Dim s As String

-    

-    r = 3

-    c = 3

-    s = GetRegionName(r)

-    s = s & ", " & GetCityName(r, c)

-    MsgBox s

-End Sub

-

-<<<<<<
-Project Name : 'ClexanePM'
-Quirk - duff tag length======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-

-    Application.EnableEvents = True

-    Set MyAppEvents.app = Application

-    

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    

-    MyAppEvents.CheckWorkBooksArround ThisWorkbook

-    

-    cmSetStandaloneMode

-    

-    Application.ScreenUpdating = True

-'    CheckUser

-

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).Select

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).update_history

-    Application.Calculate

-

-End Sub

-

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    

-    Dim RestMode As Boolean

-    RestMode = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE")

-    

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-'        If RestMode Then

-            ThisWorkbook.Saved = True

-'        Else

-'            ThisWorkbook.Save

-'        End If

-    End If

-    If RestMode Then

-        xlRestoreView

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    End If

-    Application.Caption = Empty

-    Application.CommandBars(STDBAR_NAME).Reset

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-    Dim MaxX, MaxY As Integer

-    With ThisWorkbook.Worksheets(TITLE_SHEET)

-        MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-        MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-    End With

-

-    With ThisWorkbook.Application

-        .ScreenUpdating = False

-        .WindowState = xlNormal

-        .Height = MaxY

-        .Width = MaxX

-    End With

-End Sub

-

-

-

-

-

-<<<<<<
-======================
-REP_QTR
->>>>>>
-Attribute VB_Name = "REP_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CQTR_QT As Integer = 0

-Const CQTR_ID As Integer = 1

-Const CQTR_PLN As Integer = 2

-Const CQTR_FCT As Integer = 3

-Const CQTR_BDG As Integer = 4

-Const CQTR_CNT As Integer = 5

-Const CQTR_BEDS As Integer = 6

-Const CQTR_HIR As Integer = 7

-Const CQTR_TER As Integer = 8

-Const CQTR_CRD As Integer = 9

-Const CQTR_CLXN_BDG As Integer = 10

-Const CQTR_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Const LOCAL_ENT_DATE As String = "QTR_SEL"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("REP_QTR")

-        s = .Range("D5") & " " & .Range("D4") & ", " & .Range("H5") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub update_history()

-    Dim objQTR() As tQTR

-    Dim i As Long

-    Dim r As Range

-    Dim cRep As tREPID

-    Dim rm_id As Long

-

-    rm_id = Range("RM_ID")

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    Range("D4") = cRep.LastName

-    Range("D5") = cRep.FirstName

-

-    Range("H4") = GetRegionName(cRep.Region)

-    Range("H5") = GetCityName(cRep.Region, cRep.City)

-

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetAll_QTR_Records_by_REP(objQTR, "%", cRep.rep_id, rm_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CQTR_QT) = objQTR(i).entry_date

-        Next i

-    End If

-    Dim qcd() As tQTR_COMMON

-    i = Get_QTR_CommonList_by_REP(qcd, "%", cRep.rep_id, rm_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(qcd)

-            r.Offset(i - 1, CQTR_QT) = qcd(i).qtr.entry_date

-            r.Offset(i - 1, CQTR_ID) = qcd(i).qtr.id

-            r.Offset(i - 1, CQTR_PLN) = qcd(i).qtr.sale_PLAN

-            r.Offset(i - 1, CQTR_FCT) = qcd(i).c_sale_ALL

-            r.Offset(i - 1, CQTR_BDG) = qcd(i).c_bdgt_LPU

-            r.Offset(i - 1, CQTR_CNT) = qcd(i).i_lcd

-            r.Offset(i - 1, CQTR_BEDS) = qcd(i).c_beds

-            r.Offset(i - 1, CQTR_HIR) = qcd(i).c_pat_HIR

-            r.Offset(i - 1, CQTR_TER) = qcd(i).c_pat_TER

-            r.Offset(i - 1, CQTR_CRD) = qcd(i).c_pat_CRD

-            If qcd(i).c_bdgt_LPU <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_BDG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_LPU

-            End If

-            If qcd(i).c_bdgt_NMG <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_NMG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CQTR_CRD + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-

-Sub Draw_PLN_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_FCT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PLN_QTR").Range("title") = MakeChartTitle

-End Sub

-

-Sub Draw_BDGT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_CLXN_NMG + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_BDGT_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Public Sub cbxRepQtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CQTR_ID + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    i = currRange.Column - Range(CINP_AREA).Column

-

-    QTR_ID = r

-

-    If QTR_ID = 0 Then

-        Worksheets(VAR_SHEET).Range("USER_ACTION") = 1

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        If i > CQTR_FCT Then

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-            Range("LAST_FOCUS") = currRange.address

-        Else

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 3

-            Range("LAST_FOCUS") = currRange.address

-        End If

-    End If

-    Cancel = True

-    btHomeDo_IT

-End Sub

-

-<<<<<<
-======================
-mRep_QTR
->>>>>>
-Attribute VB_Name = "mRep_QTR"

-Option Explicit

-

-Sub NoFunc()

-    MsgBox "Функция не доступна", vbOKOnly, PROGRAM_NAME

-End Sub

-

-Sub DO_Price_qtr(ent_date As String)

-    Dim qtr As tQTR

-    Dim res As Integer

-    Dim cRep As tREPID

-    Dim rm_id As Long

-

-    rm_id = Worksheets(REP_QTR_SHEET).Range("RM_ID")

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    qtr = Get_QTR_Record_by_REP(ent_date, cRep.rep_id, cRep.rm_id)

-

-    If qtr.id = 0 Then

-        qtr.entry_date = ent_date

-

-        With Worksheets(VAR_SHEET)

-            qtr.ClxnH20mg = .Range("ClxnH20mg")

-            qtr.ClxnH40mg = .Range("ClxnH40mg")

-            qtr.ClxnT40mg = .Range("ClxnT40mg")

-            qtr.ClxnC_ACS = .Range("ClxnC_ACS")

-            qtr.ClxnC_IM = .Range("ClxnC_IM")

-        End With

-    End If

-

-    Dim dlg_nq As dlg_nextQTR

-    Set dlg_nq = New dlg_nextQTR

-

-    With dlg_nq

-        .tb_qtr_name = qtr.entry_date

-        .tb_bdgt_avts = qtr.sale_PLAN

-        .tb_qtr_name = qtr.entry_date

-        .tb_ClxnH20mg = qtr.ClxnH20mg

-        .tb_ClxnH40mg = qtr.ClxnH40mg

-        .tb_ClxnT40mg = qtr.ClxnT40mg

-        .tb_ClxnC_ACS = qtr.ClxnC_ACS

-        .tb_ClxnC_IM = qtr.ClxnC_IM

-    End With

-

-    dlg_nq.Show

-End Sub

-

-Sub DO_Edit_qtr(ent_date As String)

-    If ent_date = "" Then

-        NoFunc

-    Else

-        Dim rep_id As Long

-        rep_id = Worksheets(REP_QTR_SHEET).Range("REP_ID")

-        With ThisWorkbook.Worksheets("LPU_LIST")

-            .Range("VIEW_ONLY") = True

-            .setEnt_date (ent_date)

-            .Range("REP_ID") = rep_id

-            .Select

-        End With

-    End If

-End Sub

-

-Sub DO_Delete_qtr(ent_date As String)

-    If ent_date <> "" Then

-        MsgBox "Удалить данные за период [" & ent_date & "] нельзя ", vbOKOnly, PROGRAM_NAME

-    End If

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-

-Sub btHomeDo_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    idx = Worksheets(VAR_SHEET).Range("USER_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).getEnt_date()

-    Select Case idx

-        Case 1

-            NoFunc

-            ' Обновляем экран

-        Case 2

-            DO_Edit_qtr ent_date

-        Case 3

-            DO_Price_qtr ent_date

-        Case 4

-            NoFunc

-    End Select

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-Sub Delete_qtr()

-'    Dim ent_date As String

-'    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-'    DO_Delete_qtr ent_date

-End Sub

-

-Sub btREP_QTR_RET_IT()

-    Dim s As String

-    With Worksheets("REP_QTR")

-        .Range("LAST_FOCUS") = ""

-        s = .Range("ret_addr")

-        .Range("ret_addr") = ""

-    End With

-    If s <> "" Then

-        ThisWorkbook.Worksheets(s).Select

-    Else

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public ppReport As New cPPReport

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane[PM]"

-Public Const PROGRAM_VERSION As String = "Clexane[PM] ver 1.1"

-Public Const PROGRAM_FILENAME As String = "clexane-pm"

-Public Const PROGRAM_BACKUPNAME As String = "pm-backup-"

-Public Const PROGRAM_EXPORTNAME As String = "pm-ex-"

-Public Const PROGRAM_IMPORTNAME As String = "rm-ex*"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-Public Const CHART_DEF_TITLE As String = "* * *"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20031207

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "O41"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-Public Const RM_QTR_SHEET As String = "RM_QTR"

-Public Const PRJ_QTR_SHEET As String = "PRJ_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-Function time_correct(end_date As Long, ByVal theDate As Date) As Boolean

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-    If end_date = NO_ESTIMATION_DATE Then

-        time_correct = True

-        Exit Function

-    End If

-    

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    

-    time_correct = CurDate <= end_date

-    

-End Function

-

-Sub EnableRun(end_date As Long)

-    If Not time_correct(end_date, Now) Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-Sub t()

-    EnableRun ESTIMATION_DATE

-End Sub

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Sub OpenPPT()

-    ppReport.ReportView

-End Sub

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-

-End Sub

-

-Function Double2Str(ByVal d As Double, ByVal precision As Integer, Optional Delim As String = ".") As String

-    Dim s As String

-    If Not precision > 0 Then

-        s = Round(d)

-    Else

-        Dim i As Integer

-        i = Fix(d)

-        s = i & Delim

-        d = Abs(d - i)

-        Do

-            precision = precision - 1

-            d = d * 10

-            If precision > 0 Then

-                i = Fix(d)

-            Else

-                i = Round(d)

-            End If

-            If i < 1 Then

-                s = s & "0"

-            Else

-                s = s & i

-                d = d - i

-            End If

-        Loop While precision > 0

-    End If

-    Double2Str = s

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetWBName(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBName = Right(FullName, s_len - pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.Name = VAR_SHEET Or sh.Name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-<<<<<<
-======================
-Var
->>>>>>
-Attribute VB_Name = "Var"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-title
->>>>>>
-Attribute VB_Name = "title"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LPU_LIST
->>>>>>
-Attribute VB_Name = "LPU_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Const LOCAL_ENT_DATE As String = "C10"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Function getCurrentLPU_ID() As Long

-    Dim r As Range

-

-    With Worksheets("LPU_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CLPU_ID)

-    End With

-

-    getCurrentLPU_ID = r

-End Function

-

-Public Sub LPU_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectLPU_NAME(lpu_id As Long, ent_date As String)

-    SelectLPU_BDGT lpu_id, ent_date

-End Sub

-

-Sub SelectLPU_BDGT(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    If lpu_id = 0 Then

-        SelectLPU_NAME lpu_id, ent_date

-    Else

-        With ThisWorkbook.Worksheets("LPU_BDGT")

-            .Range("VIEW_ONLY") = vo

-            .Range("ret_addr") = "LPU_LIST"

-            .setEnt_date (ent_date)

-            .Range("lpu_id") = lpu_id

-            .Range("REP_ID") = rep_id

-            .Range("RM_ID") = rm_id

-        End With

-    End If

-End Sub

-

-Sub SelectLPU_HIR(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_HIR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .setEnt_date (ent_date)

-        .Range("lpu_id") = lpu_id

-        .Range("REP_ID") = rep_id

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Sub SelectLPU_TER(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_TER")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .setEnt_date (ent_date)

-        .Range("lpu_id") = lpu_id

-        .Range("REP_ID") = rep_id

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Sub SelectLPU_C_ACS(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_C_ACS")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .setEnt_date (ent_date)

-        .Range("RM_ID") = rm_id

-        .Range("REP_ID") = rep_id

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateLPUList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim lpu_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CINP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CINP_AREA).row, CLPU_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    lpu_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CINP_AREA).Column

-

-    If lpu_id = 0 Then

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    End If

-

-    If lpu_id = 0 Then

-        i = CLPU_NAME

-        Range("JUMP") = ""

-    End If

-    Select Case i

-        Case CLPU_NAME, CLPU_NAME1, CLPU_NAME2, CLPU_BEDS

-            SelectLPU_NAME lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-

-        Case CLPU_NMG, CLPU_NFG, CLPU_PLAN, CLPU_FACT

-            SelectLPU_BDGT lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-

-        Case CLPU_HIR

-            SelectLPU_HIR lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_HIR"

-

-        Case CLPU_TER

-            SelectLPU_TER lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_TER"

-

-        Case CLPU_CAR

-            SelectLPU_C_ACS lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        Case Else

-            Range("JUMP") = ""

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateLPUList()

-    Dim lcd() As tLPU_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-    Dim objQTR As tQTR

-    Dim cRep As tREPID

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    ent_date = getEnt_date

-

-'     ent_date = "%" ' % - all records

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id, cRep.rm_id)

-    i = Get_LPU_CommonQTR(lcd, objQTR)

-

-'     стираем ФИО

-    Range("C3:C4").ClearContents

-

-    Range("C3") = cRep.LastName

-    Range("C4") = cRep.FirstName

-    Range("G3") = GetRegionName(cRep.Region)

-    Range("G4") = GetCityName(cRep.Region, cRep.City)

-    Range("G5") = objQTR.sale_PLAN

-

-

-

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(lcd)

-            r.Offset(i - 1, CLPU_NAME) = lcd(i).lpu.Name

-            r.Offset(i - 1, CLPU_ID) = lcd(i).lpu.id

-            r.Offset(i - 1, CLPU_BEDS) = lcd(i).lpu.beds

-

-

-            r.Offset(i - 1, CLPU_NFG) = lcd(i).bdgt.bdgt_NFG

-            r.Offset(i - 1, CLPU_NMG) = lcd(i).bdgt.bdgt_NMG

-            r.Offset(i - 1, CLPU_PLAN) = lcd(i).bdgt.sale_PLAN

-

-            r.Offset(i - 1, CLPU_HIR) = lcd(i).pat_HIR

-            r.Offset(i - 1, CLPU_TER) = lcd(i).pat_TER

-            r.Offset(i - 1, CLPU_CAR) = lcd(i).pat_CRD

-            r.Offset(i - 1, CLPU_FACT) = lcd(i).sale_ALL

-            r.Offset(i - 1, CLPU_PAT_LPU) = lcd(i).pat_LPU

-            r.Offset(i - 1, CLPU_BDGT) = lcd(i).bdgt_LPU

-            If lcd(i).bdgt_LPU > 0 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = lcd(i).sale_ALL / lcd(i).bdgt_LPU

-            End If

-            If r.Offset(i - 1, CLPU_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{32FB0F3D-6884-41DC-99DB-E2C55B2257C4}{DED79A66-DA60-4CCC-9003-082480235D55}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-dbACS
->>>>>>
-Attribute VB_Name = "dbACS"

-Option Explicit

-

-Public Type tACS

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    patients_with_geparins As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objACS.ID <> 0 then updatre else insert

-Sub Insert_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objACS.id <> 0 Then

-        dbUpdate_ACS_Record dbConnection, objACS

-    Else

-        dbInsert_ACS_Record dbConnection, objACS

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_ACS_RecordsByLPU_ID(ByRef all_ACS_() As tACS, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_ACS_RecordsByLPU_ID = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, all_ACS_, lpu_id, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_ACS_Record dbConnection, objACS

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub dbInsert_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_acs", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objACS

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("patients_with_geparins") = .patients_with_geparins

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objACS.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim Update_SQL As String

-    

-    With objACS

-        Update_SQL = "UPDATE lpu_acs SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "patients_with_geparins=" & .patients_with_geparins & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_ACS_RecordsbyLPU_ID(dbConnection As Object, all_ACS() As tACS, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_ACS_SQL As String

-    Dim getAll_ACS_SQL As String

-    Dim ACS_Count As Long

-    ACS_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    Else

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_ACS_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        ACS_Count = dbRecordset("ACS_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_ACS_RecordsbyLPU_ID = ACS_Count

-    

-    If ACS_Count > 0 Then

-        'we have records

-        ReDim all_ACS(1 To ACS_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_ACS_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_ACS As tACS

-                 With tmp_ACS

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .patients_with_geparins = dbRecordset("patients_with_geparins")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 all_ACS(index) = tmp_ACS

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE ID=" & objACS.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_ACS_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_HIR
->>>>>>
-Attribute VB_Name = "LPU_CLSN_HIR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const LOCAL_ENT_DATE As String = "S38"

-

-Sub PrintCopy()

-    Range("A1:M26").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-

-        Dim objHir As tHIRURGIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objHir

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .operations_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L9")

-                .patients_ambulator_clexan_20mg = Range("L10")

-                .patients_ambulator_clexan_40mg = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L19")

-                .patients_stationar_clexan_20mg = Range("L20")

-                .patients_stationar_clexan_40mg = Range("L21")

-            End With

-            Insert_Hir_Record objHir

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objHir.id = Range("rec_id")

-                    If objHir.id <> 0 Then

-                        Delete_Hir_Record objHir

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-End Sub

-

-Sub SetupData(objHir As tHIRURGIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    With objHir

-        Range("rec_id") = .id

-        Range("F6") = .operations_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L9") = .patients_ambulator_clexan

-        Range("L10") = .patients_ambulator_clexan_20mg

-        Range("I21") = .patients_stationar_nmg

-        Range("L19") = .patients_stationar_clexan

-        Range("L20") = .patients_stationar_clexan_20mg

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id, cRep.rm_id)

-

-        formula = "=" & qtr.ClxnH20mg & "*($L$10+$L$20)+" & qtr.ClxnH40mg & "*($L$11+$L$21)"

-        Range("F11").formula = formula

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id, Range("RM_ID"))

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.Name

-        Range("lpu_addr") = lpu.address

-

-        Dim objHir() As tHIRURGIA

-        Dim i As Integer

-        i = GetAll_Hir_RecordsByLPU_ID(objHir, id, Range("ent_date"), Range("RM_ID"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.3

-        Else

-            SetupData objHir(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-mSapes
->>>>>>
-Attribute VB_Name = "mSapes"

-Option Explicit

-

-Const SHAPE_COLOR As Integer = 1

-Const SHAPE_NAME As Integer = 2

-

-

-Sub ShapeView(r_sh_finite_state As Range)

-    Dim chk As Range

-    Dim s As String

-    Dim c, idx As Integer

-    For Each chk In r_sh_finite_state

-        idx = 0

-        If chk = "+" Then

-            c = chk.Offset(0, idx + SHAPE_COLOR)

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While c <> 0

-                ShapeFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s)), c

-                idx = idx + 2

-                c = chk.Offset(0, idx + SHAPE_COLOR)

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        Else

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While s <> ""

-                ShapeUnFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s))

-                idx = idx + 2

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        End If

-    Next chk

-End Sub

-

-Sub ShapeFill(sh As ShapeRange, ByVal color As Integer)

-    sh.Fill.Visible = msoTrue

-    sh.Fill.Solid

-    sh.Fill.ForeColor.SchemeColor = color

-    sh.Fill.Transparency = 0#

-End Sub

-

-Sub ShapeUnFill(sh As ShapeRange)

-    sh.Fill.Visible = msoFalse

-    sh.Fill.Transparency = 0#

-End Sub

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Public Const INPUT_NO = 0

-Public Const INPUT_NUMBER = 1

-Public Const INPUT_PERCENT = 2

-Public Const INPUT_STRING = 3

-Public Const INPUT_CHECK = 4

-

-Public Const INP_IDX_TYPE = 1

-Public Const INP_IDX_NEXT = 2

-Public Const INP_IDX_MIN = 3

-Public Const INP_IDX_MAX = 4

-Public Const INP_IDX_DEP = 5

-Public Const INP_IDX_ALT = 7

-

-

-Public Type tInputSet

-    vType As Integer

-    vMin As Long

-    vMax As Long

-    rChk As String

-End Type

-

-Function is_input_cell(ByVal Target As Range, inputs As Range) As tInputSet

-    Dim t As Range

-    Dim iset As tInputSet

-    Dim test As Range

-    iset.vType = INPUT_NO

-    iset.vMin = 0

-    iset.vMax = 0

-    iset.rChk = ""

-    is_input_cell = iset

-

-' Закоментировать следующую сточку для работы

-'  Exit Function

-

-    Set test = Target.Cells(1, 1)

-    For Each t In inputs

-        If Range(t).Column = test.Column And Range(t).row = test.row Then

-            iset.vType = t.Offset(0, INP_IDX_TYPE).Value

-            Select Case iset.vType

-                Case INPUT_CHECK

-                    iset.rChk = t.Offset(0, INP_IDX_ALT)

-                Case INPUT_NUMBER, INPUT_PERCENT

-                    iset.vMin = t.Offset(0, INP_IDX_MIN).Value

-                    iset.vMax = t.Offset(0, INP_IDX_MAX).Value

-            End Select

-            is_input_cell = iset

-            Exit Function

-        End If

-    Next t

-End Function

-

-Function GetFocusAddress(ByVal r As Range, f_next As Range) As String

-    Dim chk, t As Range

-    

-    For Each chk In f_next

-        For Each t In r

-            If t.address = chk Then

-                GetFocusAddress = chk

-                Exit Function

-            End If

-            If Range(chk).Column = t.Column - 1 And Range(chk).row = t.row _

-            Or Range(chk).Column = t.Column And Range(chk).row = t.row - 1 _

-            Then

-                If Range(chk) <> "" Then

-                    If Range(chk) = 0 Then

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_ALT)).address

-                    Else

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_NEXT)).address

-                    End If

-                Else

-                    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-                End If

-                Exit Function

-            End If

-        Next t

-    Next chk

-    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-End Function

-

-Sub SetDependet(r As Range, inputs As Range)

-    Dim chk As Range

-    Dim s, serr As String

-    Dim idx As Integer

-    Dim iset As tInputSet

-    Dim err_found As Boolean

-    

-    If r.count > 1 Then

-        Exit Sub

-    End If

-    

-    err_found = False

-    For Each chk In inputs

-        idx = INP_IDX_DEP

-        

-        

-        iset.vType = chk.Offset(0, INP_IDX_TYPE).Value

-        Select Case iset.vType

-            Case INPUT_NUMBER, INPUT_PERCENT

-                iset.vMin = chk.Offset(0, INP_IDX_MIN).Value

-                iset.vMax = chk.Offset(0, INP_IDX_MAX).Value

-                

-                If Range(chk) > iset.vMax Then

-                    err_found = True

-                    Range(chk) = iset.vMax

-                    serr = "Выход за дозволенный диапазон [" & iset.vMin & ".." & iset.vMax & "]! Данные скорректированы."

-                End If

-                

-                If Range(chk) = "" Then

-                    s = chk.Offset(0, idx)

-                    Do While s <> ""

-                        Range(s) = ""

-                        idx = idx + 1

-                        s = chk.Offset(0, idx)

-                    Loop

-                End If

-        End Select

-    Next chk

-    If err_found Then

-        MsgBox serr, vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Function CheckInputData(inputs As Range) As Boolean

-    Dim r As Range

-    

-    CheckInputData = True

-    For Each r In inputs

-        If Range(r) = "" Then

-            CheckInputData = False

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100.", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Sub Check_Int_Number(Target As Range, Def_Val As Long)

-    Dim err As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    err = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                err = True

-            End If

-        End If

-    Next r

-    If err Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_TER
->>>>>>
-Attribute VB_Name = "LPU_CLSN_TER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const LOCAL_ENT_DATE As String = "S38"

-

-Sub PrintCopy()

-    Range("A1:M26").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim objTer As tTERAPIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objTer

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .patients_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L20")

-            End With

-            Insert_Ter_Record objTer

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objTer.id = Range("rec_id")

-                    If objTer.id <> 0 Then

-                        Delete_Ter_Record objTer

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-

-End Sub

-

-Sub SetupData(objTer As tTERAPIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    With objTer

-        Range("rec_id") = .id

-        Range("F6") = .patients_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L11") = .patients_ambulator_clexan

-        Range("I21") = .patients_stationar_nmg

-        Range("L20") = .patients_stationar_clexan

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id, cRep.rm_id)

-        formula = "=" & qtr.ClxnT40mg & "*($L$12+$L$20)"

-        Range("F11").formula = formula

-

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id, Range("RM_ID"))

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.Name

-        Range("lpu_addr") = lpu.address

-

-        Dim objTer() As tTERAPIA

-        Dim i As Integer

-        i = GetAll_Ter_RecordsByLPU_ID(objTer, id, Range("ent_date"), Range("RM_ID"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.25

-        Else

-            SetupData objTer(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{0DC9E035-CE0A-49FF-85A2-A4EC5FF8FE96}{D54DDC8A-1EE2-4BB3-8B94-343B521AF098}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-LPU_BDGT
->>>>>>
-Attribute VB_Name = "LPU_BDGT"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const LOCAL_ENT_DATE As String = "S15"

-

-Sub PrintCopy()

-    Range("B1:K21").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Sub SetDefFocus()

-    Range(Range("DEF_FOCUS")).Select

-End Sub

-

-Public Sub ClearData()

-    ClearSheetData

-End Sub

-

-Sub ClearSheetData()

-    If Range("F10") = 0 And Range("F13") = 0 Then

-        Range("F11:F18") = ""

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("F11:F13") = ""

-    End If

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim bdgt As tBUDGET

-        Dim sum As Long

-        Dim test As Boolean

-        With bdgt

-            .lpu_id = Range("lpu_id")

-            .id = Range("rec_id")

-            .entry_date = Range("ent_date")

-            .bdgt_NMG = Round(Range("F11").Value, 0)

-            .bdgt_NFG = Round(Range("F12").Value, 0)

-            .sale_PLAN = Round(Range("F13").Value, 0)

-

-            sum = .bdgt_NFG + .bdgt_NMG - .sale_PLAN

-            test = .bdgt_NFG <> 0 Or .bdgt_NMG <> 0 Or .sale_PLAN <> 0

-        End With

-        If test Then

-            If sum < 0 Then

-                MsgBox _

-                    "Ваш план превышает выделенный на гепарины бюджет. Сохранить данные?", _

-                    vbOKOnly, PROGRAM_NAME

-            End If

-            If test Then

-                Insert_BDGT_Record bdgt

-            End If

-        Else

-            If bdgt.id <> 0 Then

-                If vbYes = MsgBox("Удалить данные из базы!", vbYesNo, PROGRAM_NAME) Then

-                    Delete_BDGT_Record bdgt

-                End If

-                ret_back Range("DEF_FOCUS").Worksheet

-                Exit Sub

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-    End If

-

-   ClearData

-   ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(cLPU As tLPU_COMMON)

-    Dim t_sum As Long

-    t_sum = 0

-' Setup budget data

-    Range("F11") = cLPU.bdgt.bdgt_NMG

-    Range("F12") = cLPU.bdgt.bdgt_NFG

-    Range("F13") = cLPU.bdgt.sale_PLAN

-

-    With cLPU

-        Range("F14") = .pat_ALL

-        Range("F15") = .pat_HIR

-        Range("F16") = .pat_TER

-        Range("F17") = .pat_CRD

-        Range("F18") = .sale_ALL

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    ws_activate

-End Sub

-

-

-Sub ws_activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Dim cLPU As tLPU_COMMON

-    Dim objQTR As tQTR

-    Dim objLPU As tLPU

-    Dim ent_date As String

-    Dim id As Long

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"), Range("RM_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    id = Range("lpu_id").Value

-    ent_date = Range("ent_date")

-    

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id, cRep.rm_id)

-

-    objLPU = Get_LPU_Record(id, Range("RM_ID"))

-    Get_LPU_Common cLPU, objLPU, objQTR

-

-    If cLPU.lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = cLPU.lpu.beds

-        Range("lpu_name") = cLPU.lpu.Name

-        Range("lpu_addr") = cLPU.lpu.address

-        Range("rec_id") = cLPU.bdgt.id

-

-        SetupData cLPU

-

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-'    MsgBox Target.address

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case INPUT_CHECK

-

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{BFB4547C-96A7-4739-AA0A-CEF1E35E2BDC}{C3D618A3-9410-4BC7-9D93-3B049D361132}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mSheets
->>>>>>
-Attribute VB_Name = "mSheets"

-Option Explicit

-

-Function am_load_now() As Boolean

-    am_load_now = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE")

-End Function

-

-Sub Wks_select(RetSheet As String)

-    Dim sheet As Worksheet

-    For Each sheet In ThisWorkbook.Worksheets

-        If sheet.Name = RetSheet Then

-            ThisWorkbook.Worksheets(RetSheet).Select

-            Exit Sub

-        End If

-    Next sheet

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub ret_back(sh As Worksheet)

-    Dim RetSheet As String

-    RetSheet = sh.Range("ret_addr")

-    sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    sh.Range("rec_id") = ""

-    sh.Range("lpu_id") = ""

-    sh.Range("ent_date") = ""

-    sh.Range("lpu_name") = ""

-    sh.Range("lpu_addr") = ""

-    sh.Range("lpu_beds") = ""

-    Wks_select RetSheet

-    sh.Range("ret_addr") = ""

-End Sub

-

-Sub ClearSheetData(r_start As Range)

-    If r_start <> "" Then

-        r_start.Worksheet.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        r_start = ""

-    Else

-        ret_back r_start.Worksheet

-    End If

-End Sub

-

-Sub wks_sel_chng(iset As tInputSet, ByVal Target As Range, sh As Worksheet)

-    Dim DebugMode As Boolean

-    Dim in_range As Range

-    

-    DebugMode = Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-

-    If DebugMode Then

-        sh.Unprotect

-    Else

-        sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    End If

-

-    If iset.vType = INPUT_CHECK Then

-        Set in_range = Target.Worksheet.Range(iset.rChk)

-    Else

-        Set in_range = Target

-    End If

-    

-    Dim str As String

-    str = GetFocusAddress(in_range, sh.Range("h_inputs"))

-

-'    MsgBox Target.Address & "; " & str

-    If str <> Target.address Then

-        sh.Range(str).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-Dlg_lpu_card
->>>>>>
-Attribute VB_Name = "Dlg_lpu_card"

-Attribute VB_Base = "0{9AAD262F-A6C4-4912-9C58-D7A2071181B8}{9470F4EB-DA9F-4584-9159-D09319548D21}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbLPU_List_Change()

-    Dim src As Range

-    Dim idx_src As Integer

-    

-    Set src = Worksheets(VAR_SHEET).Range(Me.cbLPU_List.RowSource)

-    idx_src = Me.cbLPU_List.ListIndex + 1

-    Me.tb_lpu_name.Text = src.Cells(idx_src, 1)

-    Me.tb_lpu_address.Text = src.Cells(idx_src, 2)

-    Me.tbBedsCount.Text = src.Cells(idx_src, 3)

-End Sub

-

-

-Private Sub cbxLPU_List_Enable_Click()

-    

-    If Me.cbxLPU_List_Enable Then

-        

-        Me.tb_lpu_name.Text = ""

-        Me.tb_lpu_name.Enabled = False

-        

-        Me.tb_lpu_address.Text = ""

-        Me.tb_lpu_address.Enabled = False

-        

-        Me.tbBedsCount.Text = ""

-        Me.tbBedsCount.Enabled = False

-        

-        Me.cbLPU_List.Enabled = True

-        cbLPU_List_Change

-    Else

-        Me.tb_lpu_name.Enabled = True

-        Me.tb_lpu_name.Text = ""

-        

-        Me.tb_lpu_address.Enabled = True

-        Me.tb_lpu_address.Text = ""

-        

-        Me.tbBedsCount.Enabled = True

-        Me.tbBedsCount.Text = ""

-        

-        Me.cbLPU_List.Enabled = False

-    End If

-End Sub

-

-<<<<<<
-======================
-UserInfo
->>>>>>
-Attribute VB_Name = "UserInfo"

-Attribute VB_Base = "0{A8FBEE9C-DE59-49DE-971D-07BC9C0E9BD2}{C712732B-D8E4-4C2D-8E78-AC90968E0CD7}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Tag = vbOK

-End Sub

-

-Private Sub cbCity_Change()

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_CITY") = Me.cbCity.ListIndex

-        .Calculate

-    End With

-End Sub

-

-Private Sub cbRegion_Change()

-    Dim LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        NewRangeOffsetCol = cbRegion.Value * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .Name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).address

-        NewSumRange = .Name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).address

-        .Calculate

-        .Range("IDX_CITY") = 0

-        cbCity.RowSource = NewCbxRange

-

-    End With

-    cbCity.ListIndex = 0

-End Sub

-

-<<<<<<
-======================
-mREGMAN
->>>>>>
-Attribute VB_Name = "mREGMAN"

-Option Explicit

-

-Sub hw_reset()

-    Dim rs As Range

-    Dim re As Object

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    HWReset

-    With Application

-        .DisplayAlerts = False

-        .Quit

-    End With

-End Sub

-

-Sub CheckUser()

-    If Range("HW_Number") = "" Then

-        StoreHWInfo

-    End If

-    If CheckHWInfo <> True Then

-        MsgBox "2"

-        cmAbout

-'        With Application

-'            .DisplayAlerts = False

-'            .Quit

-'        End With

-    Else

-        SetupUser

-    End If

-End Sub

-

-

-Sub SetupUser()

-'    Dim cREGMAN As tREGMAN

-'    Dim idx As Integer

-'    Dim dlg_ui As UserInfo

-'

-'    Set dlg_ui = New UserInfo

-'

-'    cREGMAN = Get_REGMAN_Record()

-'

-'    With ThisWorkbook.Worksheets(REGS_SHEET)

-'        .Range("IDX_REGION") = cREGMAN.Region

-'        .Range("IDX_CITY") = cREGMAN.City

-'    End With

-'

-'    With dlg_ui

-'        .cbRegion = cREGMAN.Region

-'        .cbCity = cREGMAN.City

-'        .tbFName = cREGMAN.FirstName

-'        .tbLName = cREGMAN.LastName

-'    End With

-'

-'    dlg_ui.Show

-'    Worksheets(REGS_SHEET).Calculate

-'

-'    If dlg_ui.Tag = vbOK Then

-'        With cREGMAN

-'            .Region = dlg_ui.cbRegion.Value

-'            .City = dlg_ui.cbCity.Value

-'            .FirstName = dlg_ui.tbFName.Value

-'            .LastName = dlg_ui.tbLName.Value

-'        End With

-'        Set_REGMAN_Record cREGMAN

-'    Else

-'        cmAbout

-'        With Application

-'            .DisplayAlerts = False

-'            .Quit

-'        End With

-'    End If

-End Sub

-

-Sub StoreHWInfo()

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim objHW() As Long

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    Set r = Range("HW_Number")

-    i = 1

-    For Each d In dc

-        If d.drivetype = 2 Then

-            r = d.SerialNumber

-            Set r = r.Offset(1, 0)

-            ReDim Preserve objHW(i)

-            objHW(i) = d.SerialNumber

-            i = i + 1

-        End If

-    Next

-    

-    UpdateHWRecords objHW

-End Sub

-

-Function CheckHWInfo()

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim objHW() As Long

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    

-    CheckHWInfo = False

-    

-    i = GetHWRecords(objHW)

-    If i = 0 And Range("HW_Number") <> 0 Then

-        Exit Function

-    End If

-    For Each d In dc

-        If d.drivetype = 2 Then

-            Set r = Range("HW_Number")

-            Do While r <> ""

-                If r = d.SerialNumber Then

-                    For i = 1 To UBound(objHW)

-                        If d.SerialNumber = objHW(i) Then

-                            CheckHWInfo = True

-                            Exit Function

-                        End If

-                    Next i

-                End If

-                Set r = r.Offset(1, 0)

-            Loop

-        End If

-    Next

-End Function

-<<<<<<
-======================
-dbBudget
->>>>>>
-Attribute VB_Name = "dbBudget"

-Option Explicit

-

-Public Type tBUDGET

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    rm_id As Long

-    bdgt_NMG As Long

-    bdgt_NFG As Long

-    sale_PLAN As Long

-End Type

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function GetAll_BDGT_RecordsByLPU_ID(ByRef allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_BDGT_RecordsByLPU_ID = dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection, allBDGT, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function Get_BDGT_Record(ByVal lpu_id As Long, ByVal ent_date As String, rm_id As Long) As tBUDGET

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    Get_BDGT_Record = dbGet_BDGT_Record(dbConnection, lpu_id, ent_date, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-' if objBDGT.ID <> 0 then updatre else insert

-Public Sub Insert_BDGT_Record(objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    If objBDGT.id <> 0 Then

-        dbUpdate_BDGT_Record dbConnection, objBDGT

-    Else

-        dbInsert_BDGT_Record dbConnection, objBDGT

-    End If

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Public Sub Delete_BDGT_Record(ByRef objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    dbDelete_BDGT_Record dbConnection, objBDGT

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_BDGT_Record(dbConnection As Object, ByVal lpu_id As Long, ent_date As String, rm_id As Long) As tBUDGET

-    

-    Dim sql As String

-    Dim objBDGT As tBUDGET

-    

-    With objBDGT

-        .id = 0

-        .lpu_id = lpu_id

-        .rm_id = rm_id

-        .entry_date = ent_date

-        .bdgt_NMG = 0

-        .bdgt_NFG = 0

-        .sale_PLAN = 0

-    End With

-        

-    

-    sql = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        With objBDGT

-            .entry_date = dbRecordset("entry_date")

-            .id = dbRecordset("id")

-            .lpu_id = dbRecordset("lpu_id")

-            .bdgt_NFG = dbRecordset("bdgt_NFG")

-            .bdgt_NMG = dbRecordset("bdgt_NMG")

-            .sale_PLAN = dbRecordset("sale_PLAN")

-        End With

-    End If

-    

-    dbGet_BDGT_Record = objBDGT

-End Function

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection As Object, allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_BDGT_SQL As String

-    Dim getAll_BDGT_SQL As String

-    Dim BDGT_Count As Long

-    BDGT_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_BDGT_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        BDGT_Count = dbRecordset("BDGT_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_BDGT_RecordsbyLPU_ID = BDGT_Count

-    

-    If BDGT_Count > 0 Then

-        'we have records

-        ReDim allBDGT(1 To BDGT_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_BDGT_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpBDGT As tBUDGET

-                 With tmpBDGT

-                    .entry_date = dbRecordset("entry_date")

-                    .id = dbRecordset("id")

-                    .lpu_id = dbRecordset("lpu_id")

-                    .bdgt_NFG = dbRecordset("bdgt_NFG")

-                    .bdgt_NMG = dbRecordset("bdgt_NMG")

-                    .sale_PLAN = dbRecordset("sale_PLAN")

-                 End With

-                 

-                 allBDGT(index) = tmpBDGT

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbInsert_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "lpu_budget", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    dbRecordset("entry_date") = objBDGT.entry_date

-    dbRecordset("lpu_id") = objBDGT.lpu_id

-    dbRecordset("bdgt_NMG") = objBDGT.bdgt_NMG

-    dbRecordset("bdgt_NFG") = objBDGT.bdgt_NFG

-    dbRecordset("sale_PLAN") = objBDGT.sale_PLAN

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objBDGT.id = dbRecordset("id")

-  

-End Sub

-

-Public Sub dbUpdate_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu_budget SET " & _

-    "entry_date='" & objBDGT.entry_date & "'," & _

-    "lpu_id=" & objBDGT.lpu_id & "," & _

-    "bdgt_NMG=" & objBDGT.bdgt_NMG & "," & _

-    "bdgt_NFG=" & objBDGT.bdgt_NFG & "," & _

-    "sale_PLAN=" & objBDGT.sale_PLAN & _

-    " WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-Public Sub dbDelete_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_BDGT_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbDatabase
->>>>>>
-Attribute VB_Name = "dbDatabase"

-Option Explicit

-

-

-Sub dbOpenConnection(dbConnection As Object)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-<<<<<<
-======================
-dbLPU
->>>>>>
-Attribute VB_Name = "dbLPU"

-Option Explicit

-

-Public Type tLPU

-    id As Long

-    rep_id As Long

-    rm_id As Long

-    Name As String

-    address As String

-    beds As Integer

-End Type

-

-Function Get_LPU_Record(ByVal lpu_id As Long, rm_id As Long) As tLPU

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_LPU_Record = dbGet_LPU_Record(dbConnection, lpu_id, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_LPU_byQTR(allLPU() As tLPU, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_LPU_byQTR = dbGetAll_LPU_byQTR(dbConnection, allLPU, ent_date, rep_id, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_Record(dbConnection As Object, ByVal lpu_id As Long, rm_id As Long) As tLPU

-    

-    Dim sql As String

-    Dim objLPU As tLPU

-    

-    objLPU.id = lpu_id

-    objLPU.Name = ""

-    objLPU.address = ""

-    

-    sql = "SELECT * FROM lpu WHERE id=" & lpu_id & " AND rm_id=" & rm_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objLPU.Name = dbRecordset("name")

-        objLPU.address = dbRecordset("address")

-        objLPU.rep_id = dbRecordset("rep_id")

-        objLPU.rm_id = dbRecordset("rm_id")

-        objLPU.beds = dbRecordset("beds")

-    End If

-    

-    dbGet_LPU_Record = objLPU

-

-End Function

-

-Function dbGetAll_LPU_byQTR(dbConnection As Object, allLPU() As tLPU, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    Dim Where As String

-    Where = "WHERE lpu_budget.entry_date like '" & ent_date & "'" & " AND lpu.id=lpu_budget.lpu_id " & _

-    "AND lpu.rep_id=" & rep_id & " AND lpu.rm_id=lpu_budget.rm_id AND lpu.rm_id=" & rm_id

-

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu_budget, lpu " & Where

-    

-    getAll_LPU_SQL = "SELECT lpu.id as id, lpu.rep_id as rep_id, lpu.name as name, lpu.address as address, lpu.beds AS beds, lpu.rm_id AS rm_id " & _

-    "FROM lpu, lpu_budget " & Where

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_LPU_byQTR = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .Name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-dbREP
->>>>>>
-Attribute VB_Name = "dbREP"

-'Option Explicit

-'

-'Public Type tREP

-'    FirstName As String

-'    LastName As String

-'    Region As Integer

-'    City As Integer

-'End Type

-'

-'Function GetREPRecord() As tREP

-'    Dim dbConnection As Object

-'

-'    dbOpenConnection dbConnection

-'    GetREPRecord = dbGetREPRecord(dbConnection)

-'    dbCloseConnection dbConnection

-'End Function

-'

-'Sub SetREPRecord(cUser As tREP)

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbSetREPRecord dbConnection, cUser

-'    dbCloseConnection dbConnection

-'End Sub

-'

-'Public Function dbGetREPRecord(dbConnection As Object) As tREP

-'

-'    Dim SQL As String

-'    Dim objREP As tREP

-'

-'    objREP.FirstName = ""

-'    objREP.LastName = ""

-'    objREP.Region = 0

-'    objREP.City = 0

-'    SQL = "SELECT firstname, lastname, region, city FROM " & _

-'          "rep"

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open SQL, dbConnection

-'    ', 3, 3

-'    If Not dbRecordset.BOF Then

-'

-'        objREP.FirstName = dbRecordset("firstname")

-'        objREP.LastName = dbRecordset("lastname")

-'        objREP.Region = dbRecordset("region")

-'        objREP.City = dbRecordset("city")

-'

-'    End If

-'

-'    dbGetREPRecord = objREP

-'

-'End Function

-'

-'Public Sub dbSetREPRecord(dbConnection As Object, ByRef objREP As tREP)

-'

-'    Dim DeleteSQL As String

-'    Dim InsertSQL As String

-'

-'    DeleteSQL = "DELETE FROM rep"

-'    InsertSQL = "INSERT INTO rep (firstname, lastname, region, city) VALUES (" & _

-'    "'" & objREP.FirstName & "', " & _

-'    "'" & objREP.LastName & "', " & _

-'    objREP.Region & ", " & _

-'    objREP.City & ")"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-'

-'End Sub

-'

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    CheckWorkBooksArround Wb

-End Sub

-

-

-Sub CheckWorkBooksArround(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If app.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEL сейчас будут закрыты!", vbOKOnly, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub GetState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-        ActiveWorkbook.DisplayDrawingObjects = xlDisplayShapes

-        

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.Name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars(STDBAR_NAME).Visible = False

-End Sub

-

-

-Public Sub RestoreState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars(STDBAR_NAME).Visible = True

-End Sub

-

-

-

-<<<<<<
-======================
-cdbRM
->>>>>>
-Attribute VB_Name = "cdbRM"

-Option Explicit

-

-Public Type tRMID_COMMON

-    rm As tREGMAN

-    rgcd_count As Integer

-    rgcd() As tREGION

-End Type

-

-Function Get_RM_CommonList_by_QTR(ByRef rmcd() As tRMID_COMMON, ent_date As String) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_RM_CommonList_by_QTR = dbGet_RM_CommonList_by_QTR(dbConnection, rmcd(), ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_RM_CommonList_by_QTR(dbConnection As Object, ByRef rmcd() As tRMID_COMMON, ent_date As String) As Integer

-    ' Получить список RM-ов

-    Dim count As Integer

-    count = db_get_All_RM_by_QTR(dbConnection, rmcd(), ent_date)

-    

-    Dim i As Integer

-    For i = 1 To count

-        rmcd(i).rgcd_count = 1

-        ReDim rmcd(i).rgcd(1 To 1)

-        getREGION_by_QTR ent_date, rmcd(i).rgcd(1), rmcd(i).rm.rm_id

-    Next i

-    dbGet_RM_CommonList_by_QTR = count

-End Function

-

-Function db_get_All_RM_by_QTR(dbConnection As Object, rmcd() As tRMID_COMMON, ent_date As String) As Integer

-    

-    Dim count_sql As String

-    Dim get_sql As String

-    Dim rs As Object

-    Dim RM_Count As Integer

-        

-    count_sql = "SELECT COUNT(*) AS RM_TOTAL FROM reg_man"

-    get_sql = "SELECT * FROM reg_man"

-    Set rs = CreateObject("ADODB.Recordset")

-    rs.Open count_sql, dbConnection

-    

-    If Not rs.BOF Then

-        RM_Count = rs("RM_TOTAL")

-    End If

-    

-    rs.Close

-    

-     db_get_All_RM_by_QTR = RM_Count

-    

-    If RM_Count > 0 Then

-        'we have records

-        ReDim rmcd(1 To RM_Count)

-        Dim index As Long

-        index = 1

-        rs.Open get_sql, dbConnection

-        

-        If Not rs.BOF Then

-             Do While Not rs.EOF

-                 Dim tmp_rmcd As tRMID_COMMON

-                 With tmp_rmcd

-                    .rgcd_count = 0

-                    .rm.City = rs("city")

-                    .rm.FirstName = rs("firstname")

-                    .rm.LastName = rs("lastname")

-                    .rm.rm_id = rs("mgr_id")

-                    .rm.Region = rs("region")

-                 End With

-                 

-                 rmcd(index) = tmp_rmcd

-                 index = index + 1

-                 rs.MoveNext

-             Loop

-        End If

-    End If

-    

-End Function

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Public Const STDBAR_NAME = "Worksheet Menu Bar"

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Import data"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmDataImport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-             With .Add(msoControlPopup)

-                .Caption = "&Report"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&New Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 18

-                        .OnAction = "cmNewReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Open Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmOpenReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Close && Save"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseReport"

-                    End With

-                End With

-            End With

-           With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Exit && Restore Excel"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 548

-                        .OnAction = "cmExitRestore"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-        End With

-    End With

-End Sub

-

-Sub CreateExtCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom extendet commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Import data"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmDataImport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-             With .Add(msoControlPopup)

-                .Caption = "&Report"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&New Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 18

-                        .OnAction = "cmNewReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Open Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmOpenReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Close && Save"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseReport"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Add New Slide"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 280

-                .OnAction = "cmAddSlide"

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(flag As Boolean)

-    If flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars(STDBAR_NAME)

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmExport()

-    dbExport

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    Dim dlg As dlgAbout

-    Set dlg = New dlgAbout

-    

-    dlg.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlg.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlg.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlg.Show

-End Sub

-

-Sub cmMail2Support()

-    Dim err_description As String

-    Dim dlg_msg As dlg_Mail

-    Set dlg_msg = New dlg_Mail

-    With dlg_msg

-        .Show

-        If .Tag = vbOK Then

-            ThisWorkbook.Worksheets(VAR_SHEET).Range("ERR_MESSAGE") _

-                = .tbMessage.Text

-            ThisWorkbook.Save

-            ThisWorkbook.SendMail Recipients:="infra@i-rs.ru", Subject:=PROGRAM_NAME & " ver.:" & PROGRAM_VERSION

-            MsgBox "Сообщение об ошибке отправлено. Перезагрузите программу.", vbOKOnly, PROGRAM_NAME

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-    End With

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-'        helppath = "hh.exe " & .Path & "\Telfast.chm"

-'        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub set_work_mode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-End Sub

-

-Sub cmSetStandaloneMode()

-    set_work_mode

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    Dim dlg As dlgGetPwd

-    rp = common_pwd

-    

-    Set dlg = New dlgGetPwd

-    dlg.edPwd = ""

-    dlg.Show

-    

-    If dlg.edPwd = rp Then

-        Application.ScreenUpdating = False

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-        xlRestoreView

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-        Application.ScreenUpdating = True

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmNewReport()

-    ppReport.CreateReport

-    MsgBox "Новый отчет создан", vbInformation + vbOKOnly, PROGRAM_NAME

-    CreateExtCommandBar theApp:=ThisWorkbook.Application

-End Sub

-

-Sub cmOpenReport()

-    Dim fileToOpen

-    Dim s As String

-    fileToOpen = Application _

-        .GetOpenFileName("Report Files (*.ppt), *.ppt", title:="Report OPen", MultiSelect:=False)

-    If fileToOpen <> False Then

-        s = fileToOpen

-        ppReport.OpenReport s

-        CreateExtCommandBar theApp:=ThisWorkbook.Application

-    End If

-End Sub

-

-Sub cmCloseReport()

-    On Error Resume Next

-    ppReport.SaveReport

-    CreateCommandBar theApp:=ThisWorkbook.Application

-End Sub

-

-Sub cmAddSlide()

-    ThisWorkbook.ActiveSheet.PrintCopy

-    ppReport.InsertSlide

-End Sub

-

-Sub cmHomePage()

-    ThisWorkbook.Worksheets("PRJ_QTR").Select

-End Sub

-

-Sub cmExitRestore()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = True

-    Application.Quit

-End Sub

-

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    Dim dlg_prn As dlgPrint

-    

-    Set dlg_prn = New dlgPrint

-    

-    With dlg_prn

-        .cbMainReport = True

-        .cbMainBudget = False

-        .cbSrcData = False

-        .cbAllSheets = False

-    

-        .Show

-    

-        If .Tag = vbCancel Then

-            Exit Sub

-        End If

-    End With

-    

-    Dim PrnIdx As Integer

-    

-    With dlg_prn

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("REP_QTR", "budget", "Final")

-    Case 1111

-        plist = Array("REP_QTR", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("REP_QTR")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Clexane bar"

-Public Const common_pwd As String = "crdjhxtyjr"

-

-

-Sub SetEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    With Application

-        .Caption = PROGRAM_NAME

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .GetState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = False

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Unprotect

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    If cWindow.Type = xlWorkbook Then

-                        cWindow.DisplayHeadings = True

-                    End If

-                Next

-            End If

-        Next

-        If DesignMode Then

-            SetupDesignMenu True

-        End If

-        With mobjAppState

-            .RestoreState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Option Explicit

-

-Sub UpdateHWRecords(objHW() As Long)

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    dbUpdateHWRecords dbConnection, objHW

-    dbCloseConnection dbConnection

-End Sub

-

-Function GetHWRecords(objHW() As Long) As Integer

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    GetHWRecords = dbGetHWRecords(dbConnection, objHW)

-    dbCloseConnection dbConnection

-End Function

-

-Sub HWReset()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbInsertHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    

-    Dim dbRecordset As Object

-    Dim i As Long

-    

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "hw", dbConnection, 2, 2

-    

-    For i = 1 To UBound(objHW)

-        dbRecordset.addnew

-        dbRecordset("num") = objHW(i)

-        dbRecordset.Update

-    Next i

-    

-End Sub

-

-Sub dbUpdateHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    dbDeleteHWRecord dbConnection

-    dbInsertHWRecords dbConnection, objHW

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-dbHir
->>>>>>
-Attribute VB_Name = "dbHir"

-Option Explicit

-

-Public Type tHIRURGIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    operations_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_ambulator_clexan_40mg As Integer

-    patients_ambulator_clexan_20mg As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-    patients_stationar_clexan_40mg As Integer

-    patients_stationar_clexan_20mg As Integer

-End Type

-

-' if objHir.ID <> 0 then updatre else insert

-Sub Insert_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objHir.id <> 0 Then

-        dbUpdate_Hir_Record dbConnection, objHir

-    Else

-        dbInsert_Hir_Record dbConnection, objHir

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Hir_RecordsByLPU_ID(ByRef allHir() As tHIRURGIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Hir_RecordsByLPU_ID = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, allHir, lpu_id, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Hir_Record dbConnection, objHir

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objHir.ID <> 0 then updatre else insert

-

-Sub dbInsert_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_hir", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objHir

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("operations_per_quarter") = .operations_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_ambulator_clexan_20mg") = .patients_ambulator_clexan_20mg

-        dbRecordset("patients_ambulator_clexan_40mg") = .patients_ambulator_clexan_40mg

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-        dbRecordset("patients_stationar_clexan_20mg") = .patients_stationar_clexan_20mg

-        dbRecordset("patients_stationar_clexan_40mg") = .patients_stationar_clexan_40mg

-        

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objHir.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim UpdateSQL As String

-    

-    With objHir

-        UpdateSQL = "UPDATE lpu_hir SET " & _

-            "entry_date='" & objHir.entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "operations_per_quarter=" & .operations_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_ambulator_clexan_20mg=" & .patients_ambulator_clexan_20mg & "," & _

-            "patients_ambulator_clexan_40mg=" & .patients_ambulator_clexan_40mg & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & "," & _

-            "patients_stationar_clexan_20mg=" & .patients_stationar_clexan_20mg & "," & _

-            "patients_stationar_clexan_40mg=" & .patients_stationar_clexan_40mg & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_Hir_RecordsbyLPU_ID(dbConnection As Object, allHir() As tHIRURGIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_Hir_SQL As String

-    Dim getAll_Hir_SQL As String

-    Dim Hir_Count As Long

-    Hir_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    Else

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Hir_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Hir_Count = dbRecordset("HIR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Hir_RecordsbyLPU_ID = Hir_Count

-    

-    If Hir_Count > 0 Then

-        'we have records

-        ReDim allHir(1 To Hir_Count)

-        Dim index As Integer

-        index = 1

-        dbRecordset.Open getAll_Hir_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpHir As tHIRURGIA

-                 With tmpHir

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .operations_per_quarter = dbRecordset("operations_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_ambulator_clexan_20mg = dbRecordset("patients_ambulator_clexan_20mg")

-                    .patients_ambulator_clexan_40mg = dbRecordset("patients_ambulator_clexan_40mg")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                    .patients_stationar_clexan_20mg = dbRecordset("patients_stationar_clexan_20mg")

-                    .patients_stationar_clexan_40mg = dbRecordset("patients_stationar_clexan_40mg")

-                 End With

-                 

-                 allHir(index) = tmpHir

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE ID=" & objHir.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Hir_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbTer
->>>>>>
-Attribute VB_Name = "dbTer"

-Option Explicit

-

-Public Type tTERAPIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objTer.ID <> 0 then updatre else insert

-Sub Insert_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objTer.id <> 0 Then

-        dbUpdate_Ter_Record dbConnection, objTer

-    Else

-        dbInsert_Ter_Record dbConnection, objTer

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Ter_RecordsByLPU_ID(ByRef allTer() As tTERAPIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Ter_RecordsByLPU_ID = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, allTer, lpu_id, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Ter_Record dbConnection, objTer

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objTer.ID <> 0 then updatre else insert

-

-Sub dbInsert_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_ter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objTer

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objTer.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim Update_SQL As String

-    

-    With objTer

-        Update_SQL = "UPDATE lpu_ter SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_Ter_RecordsbyLPU_ID(dbConnection As Object, allTer() As tTERAPIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_Ter_SQL As String

-    Dim getAll_Ter_SQL As String

-    Dim Ter_Count As Long

-    Ter_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    Else

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Ter_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Ter_Count = dbRecordset("TER_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Ter_RecordsbyLPU_ID = Ter_Count

-    

-    If Ter_Count > 0 Then

-        'we have records

-        ReDim allTer(1 To Ter_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_Ter_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpTer As tTERAPIA

-                 With tmpTer

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 allTer(index) = tmpTer

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE ID=" & objTer.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Ter_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-mLPU_LIST
->>>>>>
-Attribute VB_Name = "mLPU_LIST"

-Option Explicit

-

-Public Const CINP_AREA As String = "B12"

-Public Const CLPU_NAME As Integer = 0

-Public Const CLPU_NAME1 As Integer = 1

-Public Const CLPU_NAME2 As Integer = 2

-Public Const CLPU_ID As Integer = 3

-Public Const CLPU_BEDS As Integer = 4

-Public Const CLPU_NFG As Integer = 5

-Public Const CLPU_NMG As Integer = 6

-Public Const CLPU_HIR As Integer = 7

-Public Const CLPU_TER As Integer = 8

-Public Const CLPU_CAR As Integer = 9

-Public Const CLPU_FACT As Integer = 10

-Public Const CLPU_PLAN As Integer = 11

-Public Const CLPU_PAT_LPU As Integer = 16

-Public Const CLPU_BDGT As Integer = 17

-Public Const CLPU_PAT_ALL As Integer = 16

-

-Sub EditLPU(cLPU As tLPU, ent_date As String)

-    NoFunc

-End Sub

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("LPU_LIST")

-        s = .Range("C4") & " " & .Range("C3") & ", " & .Range("G4") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_LPU_BBL").Range("title") = MakeChartTitle

-End Sub

-

-Sub Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PIE").Range("title") = MakeChartTitle

-End Sub

-

-Sub Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU_A").Range("title") = MakeChartTitle

-End Sub

-

-Sub btLPU_DEL_IT()

-'    Dim cLPU As tLPU

-'    Dim ent_date As String

-'    Dim delete_all As Integer

-'    Dim dlg_del As dlg_LPU_delete

-'

-'    With Worksheets("LPU_LIST")

-'        ent_date = .Range("ent_date")

-'        cLPU.id = .getCurrentLPU_ID()

-'    End With

-'

-'    If cLPU.id = 0 Then

-'        MsgBox "Укажите удаляемый объект", vbOKOnly, PROGRAM_NAME

-'        Exit Sub

-'    End If

-'    cLPU = Get_LPU_Record(cLPU.id)

-'

-'    Set dlg_del = New dlg_LPU_delete

-'    With dlg_del

-'        .chbDeleteQTR.Value = True

-'        .chbDeleteAll.Value = False

-'        .lComment = ent_date & ": Удаление ЛПУ '" _

-'        & cLPU.Name & "', расположенного по адресу:" _

-'        & cLPU.address & " не разрешено."

-'        .Show

-'    End With

-End Sub

-

-Sub btLPU_RET_IT()

-    With Worksheets("LPU_LIST")

-        .setEnt_date ("")

-        .Range("LAST_FOCUS") = ""

-        

-        Wks_select .Range("ret_addr")

-    End With

-

-End Sub

-

-

-Sub btLPU_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim lpu_id As Long

-

-    i = Worksheets(VAR_SHEET).Range("QTR_ACTION").Value

-    With Worksheets("LPU_LIST")

-        ent_date = .getEnt_date()

-

-

-        lpu_id = .getCurrentLPU_ID

-        If lpu_id = 0 And i <> 6 Then

-            i = 1

-        End If

-        Select Case i

-            Case 1

-                .SelectLPU_NAME lpu_id, ent_date

-                .Range("JUMP") = "LPU_BDGT"

-            Case 2

-                .SelectLPU_BDGT lpu_id, ent_date

-                .Range("JUMP") = "LPU_BDGT"

-            Case 3

-                .SelectLPU_HIR lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_HIR"

-

-            Case 4

-                .SelectLPU_TER lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_TER"

-

-            Case 5

-                .SelectLPU_C_ACS lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        End Select

-    End With

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-dbQTR
->>>>>>
-Attribute VB_Name = "dbQTR"

-Option Explicit

-

-Public Type tQTR

-    id As Long

-    entry_date As String

-    rep_id As Long

-    rm_id As Long

-    sale_PLAN As Long

-    ClxnH20mg As Long

-    ClxnH40mg As Long

-    ClxnT40mg As Long

-    ClxnC_IM As Long

-    ClxnC_ACS As Long

-End Type

-

-Function Get_QTR_Record(ByVal QTR_ID As Long, rm_id As Long) As tQTR

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_QTR_Record = dbGet_QTR_Record(dbConnection, QTR_ID, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_Record(dbConnection As Object, ByVal QTR_ID As Long, rm_id As Long) As tQTR

-    

-    Dim sql As String

-    Dim objQTR As tQTR

-    

-    With objQTR

-        .ClxnC_ACS = 0

-        .ClxnC_IM = 0

-        .ClxnH20mg = 0

-        .ClxnH40mg = 0

-        .ClxnT40mg = 0

-        .entry_date = ""

-        .id = QTR_ID

-        .rm_id = rm_id

-    End With

-    

-    sql = "SELECT * FROM quarter WHERE id=" & QTR_ID & " AND rm_id=" & rm_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objQTR.entry_date = dbRecordset("entry_date")

-        objQTR.rep_id = dbRecordset("rep_id")

-        objQTR.rm_id = dbRecordset("rm_id")

-        objQTR.sale_PLAN = dbRecordset("sale_plan")

-        objQTR.ClxnH20mg = dbRecordset("ClxnH20mg")

-        objQTR.ClxnH40mg = dbRecordset("ClxnH40mg")

-        objQTR.ClxnT40mg = dbRecordset("ClxnT40mg")

-        objQTR.ClxnC_IM = dbRecordset("ClxnC_IM")

-        objQTR.ClxnC_ACS = dbRecordset("ClxnC_ACS")

-        objQTR.id = dbRecordset("id")

-    End If

-    

-    dbGet_QTR_Record = objQTR

-

-End Function

-

-

-Function Get_QTR_Record_by_REP(ent_date As String, rep_id As Long, rm_id As Long) As tQTR

-    Dim dbConnection As Object

-    Dim allQTR() As tQTR

-    Dim i As Long

-

-    dbOpenConnection dbConnection

-

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id, rm_id)

-    If i <> 0 Then

-        Get_QTR_Record_by_REP = allQTR(1)

-    End If

-

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTR_Records_by_REP(ByRef all_QTR() As tQTR, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-

-    GetAll_QTR_Records_by_REP = dbGetAll_QTR_Records_By_REP(dbConnection, all_QTR, ent_date, rep_id, rm_id)

-

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGetAll_QTR_Records_By_REP(dbConnection As Object, all_QTR() As tQTR, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-

-    Dim getCount_QTR_SQL As String

-    Dim getAll_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    Dim rep_sql As String

-    Dim rm_sql As String

-    

-    rep_sql = ""

-    rm_sql = ""

-    

-    If rep_id <> 0 Then

-        rep_sql = " AND rep_id=" & rep_id

-    End If

-    

-    If rm_id <> 0 Then

-        rm_sql = " AND rm_id=" & rm_id

-    End If

-    

-    

-        getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter " & _

-        "WHERE entry_date like '" & ent_date & "' " & rep_sql & rm_sql

-        getAll_QTR_SQL = "SELECT * FROM quarter " & _

-        "WHERE entry_date like '" & ent_date & "' " & rep_sql & rm_sql & " ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-

-    dbRecordset.Close

-

-    dbGetAll_QTR_Records_By_REP = QTR_Count

-

-    If QTR_Count > 0 Then

-        'we have records

-        ReDim all_QTR(1 To QTR_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTR_SQL, dbConnection

-

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTR As tQTR

-                 With tmp_QTR

-                    .entry_date = dbRecordset("entry_date")

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .ClxnH20mg = dbRecordset("ClxnH20mg")

-                    .ClxnH40mg = dbRecordset("ClxnH40mg")

-                    .ClxnT40mg = dbRecordset("ClxnT40mg")

-                    .ClxnC_IM = dbRecordset("ClxnC_IM")

-                    .ClxnC_ACS = dbRecordset("ClxnC_ACS")

-                    .id = dbRecordset("id")

-                 End With

-

-                 all_QTR(index) = tmp_QTR

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-cdbQTR
->>>>>>
-Attribute VB_Name = "cdbQTR"

-Option Explicit

-

-Public Type tQTR_COMMON

-    qtr As tQTR

-    i_lcd As Long           ' число ЛПУ в СПИСКЕ

-    lcd() As tLPU_COMMON    ' список ЛПУ

-    c_beds As Long          ' сумма коек

-    c_bdgt_NFG As Long      ' общий бюджет на НФГ

-    c_bdgt_NMG As Long      ' общий бюджет на НМГ

-    c_bdgt_LPU As Long      ' общий бюджет на гепарины

-    c_sale_PLAN As Long     ' план продаж репа

-    c_sale_ALL As Long      ' продажи

-    c_sale_HIR As Long      ' в хирургии

-    c_sale_TER  As Long     ' в терапии

-    c_sale_CRD  As Long     ' в кардиологии

-    c_pat_HIR   As Long     ' пациенты

-    c_pat_TER   As Long     '

-    c_pat_CRD   As Long     '

-    c_pat_ALL   As Long     '

-    c_pat_LPU   As Long     ' Всего операций

-End Type

-

-Function Get_QTR_CommonList_by_REP(ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long, rm_id As Long) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_QTR_CommonList_by_REP = dbGet_QTR_CommonList_by_REP(dbConnection, qcd, ent_date, rep_id, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_CommonList_by_REP(dbConnection As Object, ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long, rm_id As Long) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim allQTR() As tQTR

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id, rm_id)

-    dbGet_QTR_CommonList_by_REP = i

-    If i > 0 Then

-        ReDim qcd(i)

-        For i = 1 To UBound(allQTR)

-            With qcd(i)

-                .qtr = allQTR(i)

-                .c_beds = 0

-                .c_bdgt_NFG = 0

-                .c_bdgt_NMG = 0

-                .c_bdgt_LPU = 0

-                .c_sale_PLAN = 0

-                .c_pat_HIR = 0

-                .c_pat_TER = 0

-                .c_pat_CRD = 0

-                .c_pat_ALL = 0

-                .c_sale_HIR = 0

-                .c_sale_TER = 0

-                .c_sale_CRD = 0

-                .c_sale_ALL = 0

-                .c_pat_LPU = 0

-                

-                j = dbGet_LPU_CommonQTR(dbConnection, .lcd, .qtr)

-                .i_lcd = j

-                If j > 0 Then

-                    For j = 1 To UBound(.lcd)

-                        .c_beds = .c_beds + .lcd(j).lpu.beds

-                        .c_bdgt_NFG = .c_bdgt_NFG + .lcd(j).bdgt.bdgt_NFG

-                        .c_bdgt_NMG = .c_bdgt_NMG + .lcd(j).bdgt.bdgt_NMG

-                        .c_bdgt_LPU = .c_bdgt_LPU + .lcd(j).bdgt_LPU

-                        .c_sale_PLAN = .c_sale_PLAN + .lcd(j).bdgt.sale_PLAN

-                        .c_pat_HIR = .c_pat_HIR + .lcd(j).pat_HIR

-                        .c_pat_TER = .c_pat_TER + .lcd(j).pat_TER

-                        .c_pat_CRD = .c_pat_CRD + .lcd(j).pat_CRD

-                        .c_pat_ALL = .c_pat_ALL + .lcd(j).pat_ALL

-                        .c_sale_HIR = .c_sale_HIR + .lcd(j).sale_HIR

-                        .c_sale_TER = .c_sale_TER + .lcd(j).sale_TER

-                        .c_sale_CRD = .c_sale_CRD + .lcd(j).sale_CRD

-                        .c_sale_ALL = .c_sale_ALL + .lcd(j).sale_ALL

-                        .c_pat_LPU = .c_pat_LPU + .lcd(j).pat_LPU

-                    Next j

-                    

-                End If

-            End With

-        Next i

-    End If

-End Function

-

-Function GetLastQtr() As String

-    Dim s As String

-    Dim r As Range

-    Set r = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Do While r.Cells(1, 1) <> ""

-        s = r.Cells(1, 1)

-        Set r = r.Cells.Offset(1, 0)

-    Loop

-    GetLastQtr = s

-End Function

-

-Function GetNextQTR(ent_date As String) As String

-    Dim rd As Range

-    Dim idx As Integer

-    Dim b As Variant

-    Dim dlg As dlg_newQTR

-    Set dlg = New dlg_newQTR

-    

-    If ent_date = "" Then

-        Dim ir As Variant

-        idx = 0

-        dlg.Show

-        b = dlg.Tag

-            

-        If IsNumeric(b) Then

-            GetNextQTR = dlg.cbQTR

-        Else

-            GetNextQTR = ""

-        End If

-    Else

-        Set rd = Worksheets(VAR_SHEET).Range("Date_Lst")

-        idx = WorksheetFunction.Match(ent_date, rd, 0)

-        GetNextQTR = WorksheetFunction.index(rd, idx + 1, 1)

-    End If

-End Function

-<<<<<<
-======================
-mRestView
->>>>>>
-Attribute VB_Name = "mRestView"

-Option Explicit

-

-Sub xlRestoreView()

-Attribute xlRestoreView.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute xlRestoreView.VB_ProcData.VB_Invoke_Func = " \n14"

-    With Application

-        .CommandBars("Standard").Visible = True

-        .CommandBars("Formatting").Visible = True

-        .DisplayFormulaBar = True

-        .DisplayStatusBar = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = True

-    End With

-End Sub

-<<<<<<
-======================
-dlg_newQTR
->>>>>>
-Attribute VB_Name = "dlg_newQTR"

-Attribute VB_Base = "0{92648543-CB84-4B6B-BEB3-539AE7EF9D84}{7E20E3E3-027A-483B-A14D-AA9EA5398ACC}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mDec2TS
->>>>>>
-Attribute VB_Name = "mDec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-CHRT_LPU_BBL
->>>>>>
-Attribute VB_Name = "CHRT_LPU_BBL"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    Unprotect

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Потенциал рынка: " & Range("title")

-    Range("view_key") = False

-    ChangeLabels

-    Range("A1").Select

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Unprotect

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub BCLabelChng_Click()

-    Unprotect

-    If Range("view_key") Then

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать названия"

-    Else

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать объемы"

-    End If

-    Range("view_key") = Not Range("view_key")

-    ChangeLabels

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub ChangeLabels()

-    Dim i As Integer

-    Dim offset_text As Integer

-    Dim src As Range

-    Set src = Range("CHRT_BBL_DATA")

-    

-    offset_text = 3

-    If Range("view_key") Then

-        offset_text = 4

-    End If

-    

-    With ChartObjects(1).Chart

-        With .SeriesCollection(1)

-            For i = 1 To .Points.count

-                On Error GoTo ExitLabel

-                .Points(i).DataLabel.Characters.Text = Format(src.Cells(i, offset_text))

-            Next i

-        End With

-    End With

-ExitLabel:

-End Sub

-<<<<<<
-======================
-CHRT_PAT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PAT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Пациенты на Клексане(чел.): " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-<<<<<<
-======================
-CHRT_PAT_LPU
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Пациенты на Клексане(%): " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_nextQTR
->>>>>>
-Attribute VB_Name = "dlg_nextQTR"

-Attribute VB_Base = "0{067FED69-B41E-427D-AF59-5798B8E2E73A}{4C13CAB1-FDCC-4708-89EB-E92EDC125712}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-cdbLPU
->>>>>>
-Attribute VB_Name = "cdbLPU"

-Option Explicit

-

-Public Type tLPU_COMMON

-    lpu As tLPU

-    bdgt As tBUDGET

-    i_hir As Long

-    hir() As tHIRURGIA

-    i_ter As Long

-    ter() As tTERAPIA

-    i_ACS As Long

-    ACS() As tACS

-    bdgt_LPU As Long

-    sale_HIR As Long

-    sale_TER As Long

-    sale_CRD As Long

-    sale_ALL As Long

-    pat_HIR As Long

-    pat_TER As Long

-    pat_CRD As Long

-    pat_ALL As Long     ' Сумма всех пациентов на клексане

-    pat_LPU As Long     ' Число потенциальных пациентов для продаж клексана

-End Type

-

-Function Get_LPU_CommonQTR(ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    Get_LPU_CommonQTR = dbGet_LPU_CommonQTR(dbConnection, lcd, objQTR)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_CommonQTR(dbConnection As Object, ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    i = dbGetAll_LPU_byQTR(dbConnection, allLPU, objQTR.entry_date, objQTR.rep_id, objQTR.rm_id)

-    dbGet_LPU_CommonQTR = i

-    If i > 0 Then

-        ReDim lcd(i)

-        For i = 1 To UBound(allLPU)

-            dbGet_LPU_Common dbConnection, lcd(i), allLPU(i), objQTR

-        Next i

-    End If

-End Function

-

-Sub Get_LPU_Common(ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    dbGet_LPU_Common dbConnection, lcd, cLPU, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbGet_LPU_Common(dbConnection As Object, ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-

-    lcd.lpu = cLPU

-    lcd.bdgt = dbGet_BDGT_Record(dbConnection, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    lcd.i_hir = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, lcd.hir, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    lcd.i_ter = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, lcd.ter, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    lcd.i_ACS = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, lcd.ACS, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    With lcd

-        .bdgt_LPU = .bdgt.bdgt_NFG + .bdgt.bdgt_NMG

-        .pat_LPU = 0

-        If .i_hir > 0 Then

-            .pat_HIR = .hir(1).patients_ambulator_clexan + .hir(1).patients_stationar_clexan

-            .sale_HIR = objQTR.ClxnH20mg * (.hir(1).patients_ambulator_clexan_20mg + .hir(1).patients_stationar_clexan_20mg)

-            .sale_HIR = .sale_HIR + objQTR.ClxnH40mg * (.hir(1).patients_ambulator_clexan_40mg + .hir(1).patients_stationar_clexan_40mg)

-            .pat_LPU = .pat_LPU + .hir(1).operations_per_quarter

-        End If

-        If .i_ter > 0 Then

-            .pat_TER = .ter(1).patients_ambulator_clexan + .ter(1).patients_stationar_clexan

-            .sale_TER = .pat_TER * objQTR.ClxnT40mg

-            .pat_LPU = .pat_LPU + .ter(1).patients_per_quarter

-        End If

-        If .i_ACS > 0 Then

-            .pat_CRD = .ACS(1).patients_stationar_clexan

-            .sale_CRD = .pat_CRD * objQTR.ClxnC_ACS

-            .pat_LPU = .pat_LPU + .ACS(1).patients_per_quarter

-        End If

-        .pat_ALL = .pat_HIR + .pat_TER + .pat_CRD

-        .sale_ALL = .sale_HIR + .sale_TER + .sale_CRD

-    End With

-End Sub

-

-<<<<<<
-======================
-CHRT_PIE
->>>>>>
-Attribute VB_Name = "CHRT_PIE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Unprotect

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Доля продаж: " & Range("title")

-    

-    On Error Resume Next

-    Range("P5:Q24").Sort _

-        Key1:=Range("Q5"), _

-        Order1:=xlDescending, _

-        Header:=xlGuess, _

-        OrderCustom:=1, _

-        MatchCase:=False, _

-        Orientation:=xlTopToBottom

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PLN_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PLN_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Динамика продаж: " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_BDGT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_BDGT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Бюджеты ЛПУ: " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-dlg_LPU_delete
->>>>>>
-Attribute VB_Name = "dlg_LPU_delete"

-Attribute VB_Base = "0{9C81F4D2-4ECF-46F5-999B-9801D572A12F}{B382508B-7F3D-4747-8407-0F75F6F265F5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlg_Mail
->>>>>>
-Attribute VB_Name = "dlg_Mail"

-Attribute VB_Base = "0{EA8CE4CE-AC2E-45BC-BAF8-1429E6242097}{575F0762-04F4-4F86-B98A-8E87E3424B0D}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dbREP_id
->>>>>>
-Attribute VB_Name = "dbREP_id"

-Public Type tREPID

-    rep_id As Long

-    rm_id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function GetAll_REPID_Records_by_QTR(ByRef all_REPID() As tREPID, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_REPID_Records_by_QTR = dbGetAll_REPID_Records_by_QTR(dbConnection, all_REPID, ent_date, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function Get_REPID_Record(rep_id As Long, rm_id As Long) As tREPID

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REPID_Record = dbGet_REPID_Record(dbConnection, rep_id, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_REPID_Records(ByRef all_REPID() As tREPID) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_REPID_Records = dbGetAll_REPID_Records(dbConnection, all_REPID)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function dbGet_REPID_Record(dbConnection As Object, rep_id As Long, rm_id As Long) As tREPID

-    

-    Dim sql As String

-    Dim objREPID As tREPID

-    

-    objREPID.FirstName = ""

-    objREPID.LastName = ""

-    objREPID.Region = 0

-    objREPID.City = 0

-    sql = "SELECT * FROM " & _

-          "rep WHERE rep_id=" & rep_id & " AND rm_id=" & rm_id

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREPID.rep_id = dbRecordset("rep_id")

-        objREPID.rm_id = dbRecordset("rm_id")

-        objREPID.FirstName = dbRecordset("firstname")

-        objREPID.LastName = dbRecordset("lastname")

-        objREPID.Region = dbRecordset("region")

-        objREPID.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REPID_Record = objREPID

-        

-End Function

-

-Function dbGetAll_REPID_Records_by_QTR(dbConnection As Object, ByRef all_REPID() As tREPID, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    Dim Where As String

-    

-    REPID_Count = 0

-    

-    Where = " WHERE lpu_budget.entry_date like '" & ent_date & "' " & _

-        "AND rep.rep_id=lpu.rep_id AND lpu.id=lpu_budget.lpu_id"

-    If rm_id <> 0 Then

-        Where = Where & " AND rep.rm_id=" & rm_id

-    End If

-    

-    getAll_REPID_SQL = "SELECT distinct rep.* FROM rep, lpu, lpu_budget" & Where

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM (" & getAll_REPID_SQL & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records_by_QTR = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Function dbGetAll_REPID_Records(dbConnection As Object, ByRef all_REPID() As tREPID) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    REPID_Count = 0

-    

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM rep"

-    getAll_REPID_SQL = "SELECT * FROM rep"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-cdbExport
->>>>>>
-Attribute VB_Name = "cdbExport"

-Option Explicit

-

-Function GetDBSN() As String

-    Dim n As Long

-    Randomize Timer

-    n = Int((100000000 - 1000000 + 1) * Rnd + 1000000)

-    GetDBSN = Dec2ThirtySix(n)

-End Function

-

-Sub dbExport()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim old_file As String

-    

-    On Error GoTo ErrHandler

-    

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    old_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & "*.*"

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & GetDBSN() & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.DeleteFile old_file, True

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Данные экспортированы в файл:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для передачи", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-Exit Sub

-

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-<<<<<<
-======================
-mRegs
->>>>>>
-Attribute VB_Name = "mRegs"

-Option Explicit

-

-Function GetRegionName(idx As Integer) As String

-    GetRegionName = Worksheets(REGS_SHEET).Range("LST_REGIONS").Cells(idx + 1, 1).Text

-End Function

-

-Function GetCityName(idx_reg As Integer, idx_city As Integer) As String

-    GetCityName = Worksheets(REGS_SHEET).Range("CITY_TABLES").Offset(idx_city + 1, idx_reg * 2).Text

-End Function

-

-Sub testReg()

-    Dim r As Integer

-    Dim c As Integer

-    Dim s As String

-    

-    r = 3

-    c = 3

-    s = GetRegionName(r)

-    s = s & ", " & GetCityName(r, c)

-    MsgBox s

-End Sub

-

-<<<<<<
-======================
-RM_QTR
->>>>>>
-Attribute VB_Name = "RM_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CRGN_QT As Integer = 0

-Const CRGN_PLN As Integer = 2

-Const CRGN_FCT As Integer = 3

-Const CRGN_BDG As Integer = 4

-Const CRGN_LPU As Integer = 5

-Const CRGN_REP As Integer = 6

-Const CRGN_HIR As Integer = 7

-Const CRGN_TER As Integer = 8

-Const CRGN_CRD As Integer = 9

-Const CRGN_CLXN_BDG As Integer = 10

-Const CRGN_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Const LOCAL_ENT_DATE As String = "B11"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("RM_QTR")

-        s = .Range("D5") & " " & .Range("D4") & ", " & .Range("H4") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub update_history()

-    Dim objRGN() As tREGION

-    Dim i As Long

-    Dim r As Range

-    Dim cRMan As tREGMAN

-

-    cRMan = Get_REGMAN_Record(Range("RM_ID"))

-    

-    Range("D4") = cRMan.LastName

-    Range("D5") = cRMan.FirstName

-

-    Range("H4") = GetRegionName(cRMan.Region)

-    

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetRGN_COMM_DATA(objRGN, Range("RM_ID"))

-    

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objRGN)

-            r.Offset(i - 1, CRGN_QT) = objRGN(i).ent_date

-            r.Offset(i - 1, CRGN_FCT) = objRGN(i).total_SALE

-            r.Offset(i - 1, CRGN_PLN) = objRGN(i).sale_PLAN

-            r.Offset(i - 1, CRGN_BDG) = objRGN(i).total_BDGT

-            r.Offset(i - 1, CRGN_LPU) = objRGN(i).total_LPU

-            r.Offset(i - 1, CRGN_REP) = objRGN(i).total_REP

-            r.Offset(i - 1, CRGN_HIR) = objRGN(i).total_HIR

-            r.Offset(i - 1, CRGN_TER) = objRGN(i).total_TER

-            r.Offset(i - 1, CRGN_CRD) = objRGN(i).total_ACS

-            If objRGN(i).total_BDGT <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_BDG) = objRGN(i).total_SALE / objRGN(i).total_BDGT

-            End If

-            If objRGN(i).total_BDGT_NMG <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_NMG) = objRGN(i).total_SALE / objRGN(i).total_BDGT_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRGN_CRD + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-

-Sub Draw_PLN_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_FCT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PLN_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Draw_BDGT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_CLXN_NMG + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_BDGT_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Public Sub cbxRM_QtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR_RM

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR_RM

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR_RM

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = RM_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CRGN_QT + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    If r = "" Then

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = currRange.address

-    End If

-    Cancel = True

-    btRM_QTR_Do_IT

-End Sub

-

-<<<<<<
-======================
-dbREG_MAN
->>>>>>
-Attribute VB_Name = "dbREG_MAN"

-Option Explicit

-

-Public Type tREGMAN

-    rm_id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function Get_REGMAN_Record(rm_id As Long) As tREGMAN

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REGMAN_Record = dbGet_REGMAN_Record(dbConnection, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Sub Set_REGMAN_Record(cREGMAN As tREGMAN)

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbSet_REGMAN_Record dbConnection, cREGMAN

-'    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_REGMAN_Record(dbConnection As Object, rm_id As Long) As tREGMAN

-    

-    Dim sql As String

-    Dim objREGMAN As tREGMAN

-    

-    objREGMAN.FirstName = ""

-    objREGMAN.LastName = ""

-    objREGMAN.Region = 0

-    objREGMAN.City = 0

-    objREGMAN.rm_id = rm_id

-    sql = "SELECT * FROM " & _

-          "reg_man WHERE mgr_id=" & rm_id

-          

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREGMAN.FirstName = dbRecordset("firstname")

-        objREGMAN.LastName = dbRecordset("lastname")

-        objREGMAN.Region = dbRecordset("region")

-        objREGMAN.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REGMAN_Record = objREGMAN

-        

-End Function

-

-Public Sub dbSet_REGMAN_Record(dbConnection As Object, ByRef objREGMAN As tREGMAN)

-  

-'    Dim DeleteSQL As String

-'    Dim InsertSQL As String

-'

-'    DeleteSQL = "DELETE FROM reg_man"

-'    InsertSQL = "INSERT INTO reg_man (firstname, lastname, region, city) VALUES (" & _

-'    "'" & objREGMAN.FirstName & "', " & _

-'    "'" & objREGMAN.LastName & "', " & _

-'    objREGMAN.Region & ", " & _

-'    objREGMAN.City & ")"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-       

-End Sub

-

-

-

-<<<<<<
-======================
-dbDatabaseMerge
->>>>>>
-Attribute VB_Name = "dbDatabaseMerge"

-Option Explicit

-

-Public Type tDBFIELD

-    Name As String

-End Type

-

-Public Type tDBTABLE

-    Name As String

-    field() As tDBFIELD

-End Type

-

-

-Function dbGetConnection(dbAccessFileFullPath As String) As Object

-    Dim dbConnection As Object

-    Dim dbAccessFilePasswd As String

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFileFullPath & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    Set dbGetConnection = dbConnection

-End Function

-

-Sub dbCloseOpenedConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteOpenedSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-Function dbMergeREP(from_dbConnection As Object, to_dbConnection As Object) As Long

-

-    Dim getRecordset As Object

-    Dim getREPData_SQL As String

-    Dim REP_fn As String

-    Dim REP_ln As String

-    Dim REP_region As String

-    Dim REP_city As String

-

-

-    getREPData_SQL = "SELECT * FROM rep"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getREPData_SQL, from_dbConnection

-        

-        If Not getRecordset.BOF Then

-            REP_fn = getRecordset("firstname")

-            REP_ln = getRecordset("lastname")

-            REP_city = getRecordset("city")

-            REP_region = getRecordset("region")

-        Else

-            MsgBox "There is no information about rep! This database cannot be merged!!!"

-            dbMergeREP = -1

-            Exit Function

-        End If

-    

-    Dim insertRecordset As Object

-    Set insertRecordset = CreateObject("ADODB.Recordset")

-        

-    insertRecordset.Open "rep", to_dbConnection, 2, 2

-    insertRecordset.addnew

-        

-    insertRecordset("firstname") = REP_fn

-    insertRecordset("lastname") = REP_ln

-    insertRecordset("region") = REP_region

-    insertRecordset("city") = REP_city

-    insertRecordset.Update

-    insertRecordset.MoveLast

-    'new ID

-    

-    dbMergeREP = insertRecordset("rep_id")

-    

-End Function

-

-Sub dbMergeLPU(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getLPU_SQL As String

-    Dim getRecordset As Object

-    Dim idx As Long

-    idx = 1

-    

-    getLPU_SQL = "SELECT * FROM lpu"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getLPU_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            ReDim Preserve objLPU(1 To idx)

-            objLPU(idx).old_lpu_id = getRecordset("id")

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "lpu", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("name") = getRecordset("name")

-            insRS("address") = getRecordset("address")

-            insRS("beds") = getRecordset("beds")

-            insRS.Update

-            insRS.MoveLast

-            'new ID

-            

-            objLPU(idx).new_lpu_id = insRS("id")

-                        

-            idx = idx + 1

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about LPU! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-

-Sub dbMergeLPURelated(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object)

-

-    ' 6 tables to change

-    Dim tables(1 To 5) As tDBTABLE

-    

-    'lpu budget

-    tables(1).Name = "lpu_budget"

-    ReDim tables(1).field(1 To 4)

-    

-    tables(1).field(1).Name = "entry_date"

-    tables(1).field(2).Name = "bdgt_NMG"

-    tables(1).field(3).Name = "bdgt_NFG"

-    tables(1).field(4).Name = "sale_PLAN"

-    

-    'lpu hir

-    tables(2).Name = "lpu_hir"

-    ReDim tables(2).field(1 To 13)

-    

-    tables(2).field(1).Name = "entry_date"

-    tables(2).field(2).Name = "operations_per_quarter"

-    tables(2).field(3).Name = "risk_percent"

-    tables(2).field(4).Name = "patients_with_risk_ON"

-    tables(2).field(5).Name = "patients_ambulator"

-    tables(2).field(6).Name = "patients_ambulator_nmg"

-    tables(2).field(7).Name = "patients_ambulator_clexan"

-    tables(2).field(8).Name = "patients_ambulator_clexan_40mg"

-    tables(2).field(9).Name = "patients_ambulator_clexan_20mg"

-    tables(2).field(10).Name = "patients_stationar_nmg"

-    tables(2).field(11).Name = "patients_stationar_clexan"

-    tables(2).field(12).Name = "patients_stationar_clexan_40mg"

-    tables(2).field(13).Name = "patients_stationar_clexan_20mg"

-    

-    

-    'lpu acs

-    tables(3).Name = "lpu_acs"

-    ReDim tables(3).field(1 To 5)

-    

-    tables(3).field(1).Name = "entry_date"

-    tables(3).field(2).Name = "patients_with_geparins"

-    tables(3).field(3).Name = "patients_per_quarter"

-    tables(3).field(4).Name = "patients_stationar_nmg"

-    tables(3).field(5).Name = "patients_stationar_clexan"

-    

-    'lpu acs

-    tables(4).Name = "lpu_im"

-    ReDim tables(4).field(1 To 5)

-    

-    tables(4).field(1).Name = "entry_date"

-    tables(4).field(2).Name = "patients_with_geparins"

-    tables(4).field(3).Name = "patients_per_quarter"

-    tables(4).field(4).Name = "patients_stationar_nmg"

-    tables(4).field(5).Name = "patients_stationar_clexan"

-    

-    

-    'lpu acs

-    tables(5).Name = "lpu_ter"

-    ReDim tables(5).field(1 To 9)

-    

-    tables(5).field(1).Name = "entry_date"

-    tables(5).field(2).Name = "patients_per_quarter"

-    tables(5).field(3).Name = "risk_percent"

-    tables(5).field(4).Name = "patients_with_risk_ON"

-    tables(5).field(5).Name = "patients_ambulator"

-    tables(5).field(6).Name = "patients_ambulator_nmg"

-    tables(5).field(7).Name = "patients_ambulator_clexan"

-    tables(5).field(8).Name = "patients_stationar_nmg"

-    tables(5).field(9).Name = "patients_stationar_clexan"

-    

-    

-    

-    Dim tbl_idx As Integer

-    

-    For tbl_idx = 1 To UBound(tables)

-        

-        Dim getSQL As String

-        Dim getRS As Object

-        

-        

-        

-        Set getRS = CreateObject("ADODB.Recordset")

-        

-        getSQL = "SELECT * FROM " & tables(tbl_idx).Name

-        getRS.Open getSQL, from_db

-        

-        If Not getRS.BOF Then

-            Do While Not getRS.EOF

-                Dim insRS As Object

-                Set insRS = CreateObject("ADODB.Recordset")

-                

-                insRS.Open tables(tbl_idx).Name, to_db, 2, 2

-                insRS.addnew

-                Dim fld_idx As Integer

-    

-                    For fld_idx = 1 To UBound(tables(tbl_idx).field)

-                        insRS(tables(tbl_idx).field(fld_idx).Name) = getRS(tables(tbl_idx).field(fld_idx).Name)

-                        insRS("lpu_id") = findNewLPU_IDByOld(objLPU, getRS("lpu_id"))

-                    Next fld_idx

-                    

-                insRS.Update

-                insRS.MoveLast

-                getRS.MoveNext

-            Loop

-        End If

-        

-        

-    Next tbl_idx

-

-End Sub

-

-Function findNewLPU_IDByOld(objLPU() As tLPUCONVERTION, old_id As Long)

-

-Dim i As Integer

-For i = 1 To UBound(objLPU)

-    If objLPU(i).old_lpu_id = old_id Then

-        findNewLPU_IDByOld = objLPU(i).new_lpu_id

-        Exit Function

-    End If

-Next i

-

-findNewLPU_IDByOld = -1

-End Function

-

-

-

-

-

-Sub dbMergeQTR(from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getQTR_SQL As String

-    Dim getRecordset As Object

-    

-    getQTR_SQL = "SELECT * FROM quarter"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getQTR_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "quarter", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("entry_date") = getRecordset("entry_date")

-            insRS("sale_plan") = getRecordset("sale_plan")

-            insRS("ClxnH20mg") = getRecordset("ClxnH20mg")

-            insRS("ClxnH40mg") = getRecordset("ClxnH40mg")

-            insRS("ClxnT40mg") = getRecordset("ClxnT40mg")

-            insRS("ClxnC_IM") = getRecordset("ClxnC_IM")

-            insRS("ClxnC_ACS") = getRecordset("ClxnC_ACS")

-            

-            

-            insRS.Update

-            

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about quarter budget! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-dbMerge
->>>>>>
-Attribute VB_Name = "dbMerge"

-Option Explicit

-

-Public Type tLPUCONVERTION

-    old_lpu_id As Long

-    new_lpu_id As Long

-End Type

-

-Sub Merge_BackUp_All_Data()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim time_stump As String

-    

-    On Error GoTo ErrHandler

-    

-    time_stump = Format(Date, "yy-mm-dd_") & Format(Time, "hh-mm")

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_BACKUPNAME & time_stump & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Старые данные сохранены в файле:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для восстанеовления данных в случае утери", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-    Exit Sub

-    

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-

-Sub Merge_Clear_All_Data(access_file_full_path As String)

-    

-    Dim db As Object

-    Dim tables_to_clear() As String

-    On Error GoTo ErrHandler

-    

-    ReDim tables_to_clear(1 To 10)

-    tables_to_clear(1) = "rep"

-    tables_to_clear(2) = "lpu"

-    tables_to_clear(3) = "lpu_budget"

-    tables_to_clear(4) = "lpu_hir"

-    tables_to_clear(5) = "lpu_ter"

-    tables_to_clear(6) = "lpu_acs"

-    tables_to_clear(7) = "lpu_im"

-    tables_to_clear(8) = "quarter"

-    tables_to_clear(9) = "quarter_rm"

-    tables_to_clear(10) = "reg_man"

-    

-    Set db = dbGetConnection(access_file_full_path)

-

-    Dim i As Integer

-    

-    For i = 1 To UBound(tables_to_clear)

-        

-        If tables_to_clear(i) <> "" Then

-            Dim Clear_SQL As String

-            Clear_SQL = "DELETE FROM " & tables_to_clear(i)

-            dbExecuteOpenedSQL db, Clear_SQL

-        Else

-            'do nothing or show message

-        End If

-    Next i

-    

-    dbCloseOpenedConnection db

-    Set db = Nothing

-    

-Exit Sub

-

-ErrHandler:

-    MsgBox "something wrong: " & err.Description

-    Resume Next

-    

-End Sub

-

-Function MergeREP(from_file As String, to_file As String) As Long

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    Dim new_rep_id As Long

-

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    MergeREP = dbMergeREP(db1, db2)

-    'MsgBox "new rep ID is " & new_rep_id

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Function

-

-Sub MergeQTR(from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeQTR db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-

-Sub MergeLPU(objLPU() As tLPUCONVERTION, from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeLPU objLPU, db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-Sub MergeLPURelated(objLPU() As tLPUCONVERTION, from_file As String, to_file As String)

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    dbMergeLPURelated objLPU, db1, db2

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-

-End Sub

-

-Sub MergeGlobal(rep_files() As String, rm_file As String)

-

-    Dim i As Integer

-    'clear output file content

-    Merge_Clear_All_Data rm_file

-    

-    For i = 1 To UBound(rep_files)

-        

-        Dim rep_file As String

-        'setup input and output files

-        rep_file = rep_files(i)

-        

-        Dim new_rep_id As Long

-        ' insert REP data and get new rep_id

-        new_rep_id = MergeREP(rep_file, rm_file)

-        

-        Dim objLPU() As tLPUCONVERTION

-        'insert all LPU using new generated rep_id

-        'and populate objLPU old->new relation object

-        

-        MergeLPU objLPU, rep_file, rm_file, new_rep_id

-        'insert quarter data using new rep_id

-        MergeQTR rep_file, rm_file, new_rep_id

-        

-        

-        ' and.... insert all another data (5 tables excl version and hw)

-        'using objLPU old->new relation object

-        MergeLPURelated objLPU, rep_file, rm_file

-    

-    

-    Next i

-    

-End Sub

-

-Function GetDBList(MyPath() As String, ByRef dblist() As String) As Integer

-    Dim i As Integer

-    Dim MyName, MyMask

-    MyMask = MyPath(0) & MyPath(1) & PROGRAM_DATAEXT

-    i = 0

-    MyName = Dir(MyMask)      ' Retrieve the first entry.

-    Do While MyName <> ""    ' Start the loop.

-        ' Ignore the current directory and the encompassing directory.

-        If MyName <> "." And MyName <> ".." Then

-            ' Use bitwise comparison to make sure MyName is a directory.

-            i = i + 1

-            ReDim Preserve dblist(i)

-            dblist(i) = MyPath(0) & MyName

-        End If

-        MyName = Dir    ' Get next entry.

-    Loop

-    GetDBList = i

-End Function

-

-<<<<<<
-======================
-cdbPRJ
->>>>>>
-Attribute VB_Name = "cdbPRJ"

-Option Explicit

-

-Type tPROJECT

-    total_SALE  As Long ' общий объем продаж

-    total_BDGT  As Long ' бюджет всех ЛПУ

-    total_BDGT_NMG As Long ' бюджет всех ЛПУ на НМГ

-    total_LPU   As Long ' число ЛПУ

-    total_REP   As Long ' число репов

-    total_RM    As Long ' число репов

-    total_BEDS  As Long ' общее число коек

-    total_HIR   As Long '  общее число пациентов на клексане в хирургии

-    total_TER   As Long '  общее число пациентов на клексане в терапии

-    total_ACS   As Long '  общее число пациентов на клексане в кардиологии

-    sale_PLAN   As Long '  план продаж Авентиса

-    objRGN() As tREGION

-End Type

-

-Function GetPRJ_COMM_DATA(ByRef prj_data As tPROJECT) As Integer

-    Dim i As Integer

-    i = GetRGN_COMM_DATA(prj_data.objRGN, 0)

-    GetPRJ_COMM_DATA = i

-    If i > 0 Then

-        With prj_data

-            .sale_PLAN = 0

-            .total_ACS = 0

-            .total_BDGT = 0

-            .total_BDGT_NMG = 0

-            .total_BEDS = 0

-            .total_HIR = 0

-            .total_LPU = 0

-            .total_REP = 0

-            .total_RM = 0

-            .total_SALE = 0

-            .total_TER = 0

-            For i = 1 To UBound(prj_data.objRGN)

-                

-            Next i

-        End With

-    End If

-

-End Function

-

-<<<<<<
-======================
-dbQTR_RM
->>>>>>
-Attribute VB_Name = "dbQTR_RM"

-Option Explicit

-

-Public Type tQTRRM

-    id As Long

-    entry_date As String

-    rm_id As Long

-    sale_PLAN As Long

-End Type

-

-

-Sub Insert_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objQTRRM.id <> 0 Then

-        dbUpdate_QTRRM_Record dbConnection, objQTRRM

-    Else

-        dbInsert_QTRRM_Record dbConnection, objQTRRM

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-Function Get_QTRRM_Record(ent_date As String) As tQTRRM

-    Dim dbConnection As Object

-    Dim allQTRRM() As tQTRRM

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    i = dbGetAll_QTRRM_Records(dbConnection, allQTRRM, ent_date)

-    If i <> 0 Then

-        Get_QTRRM_Record = allQTRRM(1)

-    End If

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTRRM_Records(ByRef all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_QTRRM_Records = dbGetAll_QTRRM_Records(dbConnection, all_QTRRM, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_QTRRM_Record dbConnection, objQTRRM

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objQTRRM.ID <> 0 then updatre else insert

-Sub dbInsert_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "quarter_rm", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objQTRRM

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("sale_plan") = .sale_PLAN

-        dbRecordset("rm_id") = .rm_id

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objQTRRM.id = dbRecordset("id")

-

-End Sub

-

-Sub dbUpdate_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim Update_SQL As String

-    

-    With objQTRRM

-        Update_SQL = "UPDATE quarter_rm SET " & _

-            "entry_date='" & .entry_date & "'" & "," & _

-            "rm_id=" & .rm_id & "," & _

-            "sale_plan=" & .sale_PLAN & "," & _

-            " WHERE id=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if ent_date = % then all_records

-Function dbGetAll_QTRRM_Records(dbConnection As Object, all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    

-    Dim getCount_QTRRM_SQL As String

-    Dim getAll_QTRRM_SQL As String

-    Dim QTRRM_Count As Long

-    QTRRM_Count = 0

-    

-    getCount_QTRRM_SQL = "SELECT COUNT(*) AS QTRRM_TOTAL FROM quarter_rm WHERE entry_date like '" & ent_date & "'"

-    getAll_QTRRM_SQL = "SELECT * FROM quarter_rm WHERE entry_date like '" & ent_date & "' ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTRRM_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTRRM_Count = dbRecordset("QTRRM_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_QTRRM_Records = QTRRM_Count

-    

-    If QTRRM_Count > 0 Then

-        'we have records

-        ReDim all_QTRRM(1 To QTRRM_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTRRM_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTRRM As tQTRRM

-                 With tmp_QTRRM

-                    .entry_date = dbRecordset("entry_date")

-                    .rm_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .id = dbRecordset("id")

-                 End With

-                 

-                 all_QTRRM(index) = tmp_QTRRM

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM quarter_rm " & _

-    "WHERE id=" & objQTRRM.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-    

-    'delete related budget entries

-    MsgBox "remember delete related"

-'    dbDelete_BDGT_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Hir_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Ter_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_ACS_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-       

-End Sub

-

-

-<<<<<<
-======================
-REP_LIST
->>>>>>
-Attribute VB_Name = "REP_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Const LOCAL_ENT_DATE As String = "C10"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-

-Public Function getCurrentREP_ID() As Long

-    Dim r As Range

-

-    With Worksheets("REP_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CREP_ID)

-    End With

-

-    getCurrentREP_ID = r

-End Function

-

-Public Sub REP_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Rep_Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Rep_Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Rep_Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Rep_Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectREP_LPU(rep_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    Range("JUMP") = "LPU_LIST"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-        .Range("RM_ID") = rm_id

-        .setEnt_date (getEnt_date())

-    End With

-End Sub

-

-Public Sub SelectREP_QTR(rep_id As Long)

-    Dim vo As Boolean

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    Range("JUMP") = "REP_QTR"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("REP_QTR")

-        .Range("VIEW_ONLY") = vo

-        .Range("RM_ID") = rm_id

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateREPList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim rep_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CREP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CREP_AREA).row, CREP_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    rep_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CREP_AREA).Column

-    

-    If i < 4 Then

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 1

-    Else

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 2

-    End If

-    

-    If rep_id = 0 Then

-        Range("LAST_FOCUS") = Range(CREP_AREA).address

-    End If

-

-    If rep_id = 0 Then

-        i = CREP_NAME

-        Range("JUMP") = ""

-    Else

-        btREP_LIST_DO_IT

-    End If

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateREPList()

-    Dim rcd() As tREPID_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-

-    ent_date = getEnt_date

-

-    Dim rm_struc As tREGMAN

-    

-    i = Range("RM_ID")

-    rm_struc = Get_REGMAN_Record(i)

-    

-    Range("C4") = rm_struc.LastName

-    Range("C5") = rm_struc.FirstName

-

-    Range("G5") = GetRegionName(rm_struc.Region)

-    

-    i = Get_REP_CommonList_by_QTR(rcd, ent_date, Range("RM_ID"))

-

-    

-    With ThisWorkbook.Worksheets("REP_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(rcd)

-            r.Offset(i - 1, CREP_NAME) = rcd(i).rep.FirstName & " " & rcd(i).rep.LastName

-            r.Offset(i - 1, CREP_ID) = rcd(i).rep.rep_id

-            r.Offset(i - 1, CREP_BEDS) = rcd(i).qtrs(1).c_beds

-

-            r.Offset(i - 1, CREP_NFG) = rcd(i).qtrs(1).c_bdgt_NFG

-            r.Offset(i - 1, CREP_NMG) = rcd(i).qtrs(1).c_bdgt_NMG

-

-            r.Offset(i - 1, CREP_PLAN) = rcd(i).qtrs(1).qtr.sale_PLAN

-

-            r.Offset(i - 1, CREP_HIR) = rcd(i).qtrs(1).c_pat_HIR

-            r.Offset(i - 1, CREP_TER) = rcd(i).qtrs(1).c_pat_TER

-            r.Offset(i - 1, CREP_CAR) = rcd(i).qtrs(1).c_pat_CRD

-            r.Offset(i - 1, CREP_FACT) = rcd(i).qtrs(1).c_sale_ALL

-            r.Offset(i - 1, CREP_PAT_LPU) = rcd(i).qtrs(1).c_pat_LPU

-            r.Offset(i - 1, CREP_BDGT) = rcd(i).qtrs(1).c_bdgt_LPU

-            If rcd(i).qtrs(1).c_bdgt_LPU > 0 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = rcd(i).qtrs(1).c_sale_ALL / rcd(i).qtrs(1).c_bdgt_LPU

-            End If

-            If r.Offset(i - 1, CREP_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-

-

-<<<<<<
-======================
-mREP_LIST
->>>>>>
-Attribute VB_Name = "mREP_LIST"

-Option Explicit

-

-Public Const CREP_AREA As String = "B12"

-Public Const CREP_NAME As Integer = 0

-Public Const CREP_NAME1 As Integer = 1

-Public Const CREP_NAME2 As Integer = 2

-Public Const CREP_ID As Integer = 3

-Public Const CREP_BEDS As Integer = 4

-Public Const CREP_NFG As Integer = 5

-Public Const CREP_NMG As Integer = 6

-Public Const CREP_HIR As Integer = 7

-Public Const CREP_TER As Integer = 8

-Public Const CREP_CAR As Integer = 9

-Public Const CREP_FACT As Integer = 10

-Public Const CREP_PLAN As Integer = 11

-Public Const CREP_PAT_LPU As Integer = 16

-Public Const CREP_BDGT As Integer = 17

-

-

-Const LOCAL_ENT_DATE As String = "C10"

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Sub EditREP(cRep As tREPID, ent_date As String)

-    NoFunc

-End Sub

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("REP_LIST")

-        s = .Range("C5") & " " & .Range("C4") & ", " & .Range("G5") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub Rep_Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_LPU_BBL").Range("title") = MakeChartTitle

-End Sub

-

-Sub Rep_Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CREP_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CREP_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CREP_FACT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PIE").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rep_Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CREP_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CREP_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CREP_HIR + 1)

-            psum = psum + src.Cells(i, CREP_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CREP_TER + 1)

-            psum = psum + src.Cells(i, CREP_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CREP_CAR + 1)

-            psum = psum + src.Cells(i, CREP_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CREP_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rep_Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CREP_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CREP_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CREP_HIR + 1)

-            psum = psum + src.Cells(i, CREP_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CREP_TER + 1)

-            psum = psum + src.Cells(i, CREP_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CREP_CAR + 1)

-            psum = psum + src.Cells(i, CREP_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CREP_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU_A").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub btREP_RET_IT()

-    With Worksheets("REP_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = "RM_QTR"

-    End With

-    Dim str As String

-    str = Range("ret_addr")

-    ThisWorkbook.Worksheets(str).Activate

-End Sub

-

-

-Sub btREP_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim rep_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("REP_LST_DETALS")

-    With Worksheets("REP_LIST")

-        rep_id = .getCurrentREP_ID

-        

-        Select Case i

-            Case 1:

-                .SelectREP_QTR rep_id

-            Case 2:

-                ent_date = .getEnt_date()

-                .SelectREP_LPU rep_id, ent_date

-        End Select

-    End With

-    

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-

-

-

-<<<<<<
-======================
-cdbREP
->>>>>>
-Attribute VB_Name = "cdbREP"

-Option Explicit

-

-Public Type tREPID_COMMON

-    rep As tREPID

-    i_qtrs As Integer

-    qtrs() As tQTR_COMMON

-End Type

-

-Function Get_REP_CommonList_by_QTR(ByRef rcd() As tREPID_COMMON, ent_date As String, rm_id As Long) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_REP_CommonList_by_QTR = dbGet_REP_CommonList_by_QTR(dbConnection, rcd, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_REP_CommonList_by_QTR(dbConnection As Object, ByRef rcd() As tREPID_COMMON, ent_date As String, rm_id As Long) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim k As Long

-    Dim allREPID() As tREPID

-    

-    i = dbGetAll_REPID_Records_by_QTR(dbConnection, allREPID, ent_date, rm_id)

-    dbGet_REP_CommonList_by_QTR = i

-    If i > 0 Then

-        ReDim rcd(i)

-        For i = 1 To UBound(allREPID)

-            rcd(i).rep = allREPID(i)

-            rcd(i).i_qtrs = Get_QTR_CommonList_by_REP(rcd(i).qtrs, ent_date, allREPID(i).rep_id, allREPID(i).rm_id)

-        Next i

-    End If

-End Function

-

-

-

-<<<<<<
-======================
-CHRT_PAT_LPU_A
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU_A"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Пациенты на Клексане(чел.): " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-cdbRegion
->>>>>>
-Attribute VB_Name = "cdbRegion"

-Option Explicit

-

-Type tREGION

-    ent_date As String

-    rm_id As Long

-    total_SALE As Long ' общий объем продаж

-    total_BDGT As Long ' бюджет всех ЛПУ

-    total_BDGT_NMG As Long ' бюджет всех ЛПУ на НМГ

-    total_LPU As Long ' число ЛПУ

-    total_REP   As Long ' число репов

-    total_BEDS As Long ' общее число коек

-    total_HIR As Long '  общее число пациентов на клексане в хирургии

-    total_TER As Long '  общее число пациентов на клексане в терапии

-    total_ACS As Long '  общее число пациентов на клексане в кардиологии

-    sale_PLAN As Long '  план продаж Авентиса

-End Type

-

-Function GetRGN_COMM_DATA(ByRef reg_data() As tREGION, rm_id As Long) As Integer

-    Dim q_date() As String

-    Dim q_count As Integer, i As Integer

-    

-    q_count = getAllQTRNames(q_date, rm_id)

-    If q_count > 0 Then

-        ReDim reg_data(q_count)

-        For i = 1 To q_count

-            Dim current_REP_count As Integer

-            reg_data(i).rm_id = rm_id

-            reg_data(i).ent_date = q_date(i)

-            current_REP_count = getREGION_by_QTR(q_date(i), reg_data(i), rm_id)

-        Next i

-    End If

-    

-    GetRGN_COMM_DATA = q_count

-End Function

-

-' if rm_id = 0 then gets all records

-Function getAllQTRNames(ByRef qtr_lst() As String, rm_id As Long) As Integer

-    

-    Dim sql As String

-    Dim i As Integer

-    Dim db As Object, rs As Object

-    

-    sql = "SELECT DISTINCT entry_date FROM lpu_budget"

-    

-    If rm_id <> 0 Then

-        sql = sql & " WHERE rm_id=" & rm_id

-    End If

-    

-    i = 0

-    

-    dbOpenConnection db

-    Set rs = CreateObject("ADODB.Recordset")

-    

-    rs.Open sql, db

-        

-        If Not rs.BOF Then

-            Do While Not rs.EOF

-                i = i + 1

-                ReDim Preserve qtr_lst(i)

-                qtr_lst(i) = rs("entry_date")

-                rs.MoveNext

-            Loop

-        Else

-            getAllQTRNames = 0

-            Exit Function

-        End If

-    getAllQTRNames = i

-    dbCloseConnection db

-End Function

-

-Function getREGION_by_QTR(ent_date As String, treg As tREGION, rm_id As Long) As Integer

-    Dim rep_count As Integer

-    rep_count = 0

-    

-    Dim reps() As tQTR_COMMON

-    rep_count = Get_QTR_CommonList_by_REP(reps, ent_date, 0, rm_id)

-    

-    treg.ent_date = ent_date

-    treg.total_BDGT = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.total_BDGT_NMG = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.sale_PLAN = 0 ' quarter.sale_plan

-    treg.total_SALE = 0 'summ of

-    ' hir = (amb40+st40)*pr40 + (amb20+st20)*pr20

-    'ter (amb_clx+stat_clx)*price

-    ' acs xxx

-    'price per rep

-    treg.total_HIR = 0 'patiens clxn

-    treg.total_TER = 0 'patiens clxn

-    treg.total_ACS = 0 'patiens clxn

-    treg.total_LPU = 0 'lpu

-    treg.total_BEDS = 0 'lpu.beds

-    treg.total_REP = 0 '

-    

-    If rep_count > 0 Then

-        Dim i As Integer

-        

-        For i = 1 To UBound(reps)

-            ' current rep is reps(i)

-            With reps(i)

-                treg.total_BDGT = treg.total_BDGT + .c_bdgt_NFG + .c_bdgt_NMG

-                treg.total_BDGT_NMG = treg.total_BDGT_NMG + .c_bdgt_NMG

-                treg.sale_PLAN = treg.sale_PLAN + .qtr.sale_PLAN

-                treg.total_SALE = treg.total_SALE + .c_sale_ALL

-                treg.total_HIR = treg.total_HIR + .c_pat_HIR

-                treg.total_TER = treg.total_TER + .c_pat_TER

-                treg.total_ACS = treg.total_ACS + .c_pat_CRD

-                treg.total_LPU = treg.total_LPU + .i_lcd

-                treg.total_BEDS = treg.total_BEDS + .c_beds

-                treg.total_REP = treg.total_REP + 1

-            End With

-            

-        Next i

-        

-    End If

-    

-    getREGION_by_QTR = treg.total_REP

-End Function

-

-<<<<<<
-======================
-mRM_QTR
->>>>>>
-Attribute VB_Name = "mRM_QTR"

-Option Explicit

-

-Sub btRM_QTR_Do_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    Dim i As Integer

-    Dim def_dir As String

-    Dim flist() As String

-    

-    idx = Worksheets(VAR_SHEET).Range("RM_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-'            def_dir = GetWBPath(ThisWorkbook.FullName)

-'            If GetImportDirectory(def_dir, flist) Then

-'                Dim db_list() As String

-'                i = GetDBList(flist, db_list)

-'                If i > 0 Then

-'                    ImportFromRegionalManagers db_list, GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-'                End If

-'            End If

-'            Worksheets(RM_QTR_SHEET).update_history

-        Case 2

-            Worksheets("REP_LIST").Range("ret_addr") = "RM_QTR"

-            Worksheets("REP_LIST").setEnt_date (Worksheets(RM_QTR_SHEET).getEnt_date())

-            Worksheets("REP_LIST").Range("RM_ID") = Worksheets(RM_QTR_SHEET).Range("RM_ID")

-            Worksheets("REP_LIST").Range("VIEW_ONLY") = True

-

-            Worksheets("REP_LIST").Select

-        Case 3

-            MsgBox "Функция не доступна", vbOKOnly, PROGRAM_NAME

-    End Select

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-End Sub

-

-Sub btRM_QTR_RET_IT()

-    Dim str As String

-    str = Range("ret_addr")

-    ThisWorkbook.Worksheets(str).Activate

-End Sub

-

-<<<<<<
-======================
-mImport
->>>>>>
-Attribute VB_Name = "mImport"

-    Option Explicit

-

-Const OFN_ALLOWMULTISELECT As Long = 512

-Const OFN_EXPLORER As Long = 524288

-Const OFN_HIDEREADONLY As Long = 4

-Const OFN_NONETWORKBUTTON As Long = 131072

-Const OFN_READONLY As Long = 1

-       

-Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _

-    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

-

-Private Type OPENFILENAME

-    lStructSize As Long

-    hWndOwner As Long

-    hInstance As Long

-    lpstrFilter As String

-    lpstrCustomFilter As String

-    nMaxCustFilter As Long

-    nFilterIndex As Long

-    lpstrFile As String

-    nMaxFile As Long

-    lpstrFileTitle As String

-    nMaxFileTitle As Long

-    lpstrInitialDir As String

-    lpstrTitle As String

-    flags As Long

-    nFileOffset As Integer

-    nFileExtension As Integer

-    lpstrDefExt As String

-    lCustData As Long

-    lpfnHook As Long

-    lpTemplateName As String

-End Type

-

-Function GetImportDirectory(DB_dir As String, flist() As String) As Boolean

-    Dim OpenFile As OPENFILENAME

-    Dim lReturn As Long

-    Dim sFilter As String

-    

-    OpenFile.lStructSize = Len(OpenFile)

-    '         OpenFile.hwndOwner = Form1.hWnd

-    '         OpenFile.hInstance = App.hInstance

-    sFilter = "Clexane Data Files" & Chr(0) & PROGRAM_IMPORTNAME & PROGRAM_DATAEXT & Chr(0)

-    OpenFile.lpstrFilter = sFilter

-    OpenFile.nFilterIndex = 1

-    OpenFile.lpstrFile = String(257, 0)

-    OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1

-    OpenFile.lpstrFileTitle = OpenFile.lpstrFile

-    OpenFile.nMaxFileTitle = OpenFile.nMaxFile

-    OpenFile.lpstrInitialDir = DB_dir

-    OpenFile.lpstrTitle = "Импорт данных"

-    OpenFile.flags = OFN_HIDEREADONLY + OFN_EXPLORER

-    lReturn = GetOpenFileName(OpenFile)

-    If lReturn = 0 Then

-        GetImportDirectory = False

-    Else

-        GetImportDirectory = True

- 

-        flist = Split(OpenFile.lpstrFile, Chr(0), Compare:=vbBinaryCompare)

-        Dim i As Integer

-        i = 0

-        Do While flist(i) <> ""

-            i = i + 1

-        Loop

-        If i = 1 Then

-            flist(1) = flist(0)

-            flist(0) = GetWBPath(flist(1))

-            flist(1) = GetWBName(flist(1))

-        Else

-            flist(0) = flist(0) & "\"

-        End If

-    End If

-End Function

-<<<<<<
-======================
-cPPReport
->>>>>>
-Attribute VB_Name = "cPPReport"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Const PPR_NON As Integer = 0

-Const PPR_NEW As Integer = 1

-Const PPR_OLD As Integer = 2

-

-Dim ReportApp As PowerPoint.Application

-Dim ReportDoc As PowerPoint.Presentation

-Dim ReportState As Integer

-Dim PowerPointPath As String

-

-Private Sub Class_Initialize()

-    Set ReportApp = CreateObject("PowerPoint.Application")

-    PowerPointPath = ReportApp.Path & "\PowerPNT.EXE"

-    ReportState = PPR_NON

-End Sub

-

-Sub OpenReport(FileName As String)

-    If ReportState <> PPR_NON Then

-        SaveReport

-    End If

-    Set ReportDoc = GetObject(FileName)

-    ReportState = PPR_OLD

-End Sub

-

-Sub CreateReport()

-    If ReportState <> PPR_NON Then

-        SaveReport

-    End If

-    Set ReportDoc = ReportApp.Presentations.Add

-    ReportState = PPR_NEW

-End Sub

-

-Sub SaveReport()

-    Select Case ReportState

-        Case PPR_NEW

-            ReportDoc.SaveAs GetWBPath(ThisWorkbook.FullName) + PROGRAM_FILENAME

-        Case PPR_OLD

-            ReportDoc.Save

-    End Select

-    ReportState = PPR_NON

-End Sub

-

-Sub ReportView()

-    Dim CmdName As String

-    CmdName = GetWBPath(ThisWorkbook.FullName) + PROGRAM_FILENAME + ".PPT"

-    CmdName = PowerPointPath & " " & CmdName

-    Shell CmdName, 1

-End Sub

-

-Sub InsertSlide()

-    Dim ReportPage As PowerPoint.Slide

-    Set ReportPage = ReportDoc.Slides.Add(ReportDoc.Slides.count + 1, ppLayoutBlank)

-    

-    ReportPage.Shapes.Paste

-    ReportPage.Shapes.AddLabel(msoTextOrientationHorizontal, 20, 20, 640, 40) _

-      .TextFrame.TextRange.Text = "Slide #" & Format(ReportDoc.Slides.count)

-End Sub

-

-

-Private Sub Class_Terminate()

-    SaveReport

-    ReportApp.Quit

-End Sub

-<<<<<<
-======================
-dlgImprtDB
->>>>>>
-Attribute VB_Name = "dlgImprtDB"

-Attribute VB_Base = "0{36355920-F7A4-44A8-96EF-5D79CF26137D}{F852BDF2-AB3E-468E-89DF-EC5DC0C7C88B}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Private Sub btSelAll_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = True

-    Next i

-End Sub

-

-Private Sub btUnselect_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = False

-    Next i

-End Sub

-<<<<<<
-======================
-rmImport
->>>>>>
-Attribute VB_Name = "rmImport"

-Option Explicit

-

-Public Type dbDESCRIPTION

-    Name As String

-    Fields() As String

-End Type

-

-Sub ImportFromRegionalManagers(rm_files() As String, fm_file As String)

-    Dim db(9) As dbDESCRIPTION

-    

-    '''''data

-    db(1).Name = "rep"

-    

-    db(2).Name = "lpu"

-    db(3).Name = "lpu_acs"

-    db(4).Name = "lpu_budget"

-    db(5).Name = "lpu_hir"

-    db(6).Name = "lpu_im"

-    db(7).Name = "lpu_ter"

-    db(8).Name = "quarter"

-    db(9).Name = "quarter_rm"

-    

-    ReDim db(1).Fields(5)

-    With db(1)

-        .Fields(1) = "rep_id"

-        .Fields(2) = "firstname"

-        .Fields(3) = "lastname"

-        .Fields(4) = "region"

-        .Fields(5) = "city"

-    End With

-    

-    ReDim db(2).Fields(5)

-    With db(2)

-        .Fields(1) = "id"

-        .Fields(2) = "rep_id"

-        .Fields(3) = "name"

-        .Fields(4) = "address"

-        .Fields(5) = "beds"

-    End With

-    

-    ReDim db(3).Fields(7)

-    With db(3)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "patients_with_geparins"

-        .Fields(5) = "patients_per_quarter"

-        .Fields(6) = "patients_stationar_nmg"

-        .Fields(7) = "patients_stationar_clexan"

-    End With

-    

-    ReDim db(4).Fields(6)

-    With db(4)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "bdgt_NMG"

-        .Fields(5) = "bdgt_NFG"

-        .Fields(6) = "sale_PLAN"

-    End With

-    

-    ReDim db(5).Fields(15)

-    With db(5)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "operations_per_quarter"

-        .Fields(5) = "risk_percent"

-        .Fields(6) = "patients_with_risk_ON"

-        .Fields(7) = "patients_ambulator"

-        .Fields(8) = "patients_ambulator_nmg"

-        .Fields(9) = "patients_ambulator_clexan"

-        .Fields(10) = "patients_ambulator_clexan_40mg"

-        .Fields(11) = "patients_ambulator_clexan_20mg"

-        .Fields(12) = "patients_stationar_nmg"

-        .Fields(13) = "patients_stationar_clexan"

-        .Fields(14) = "patients_stationar_clexan_40mg"

-        .Fields(15) = "patients_stationar_clexan_20mg"

-    End With

-    

-    

-    ReDim db(6).Fields(7)

-    With db(6)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "patients_with_geparins"

-        .Fields(5) = "patients_per_quarter"

-        .Fields(6) = "patients_stationar_nmg"

-        .Fields(7) = "patients_stationar_clexan"

-    End With

-    

-    ReDim db(7).Fields(11)

-    With db(7)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "patients_per_quarter"

-        .Fields(5) = "risk_percent"

-        .Fields(6) = "patients_with_risk_ON"

-        .Fields(7) = "patients_ambulator"

-        .Fields(8) = "patients_ambulator_nmg"

-        .Fields(9) = "patients_ambulator_clexan"

-        .Fields(10) = "patients_stationar_nmg"

-        .Fields(11) = "patients_stationar_clexan"

-    End With

-    

-    ReDim db(8).Fields(9)

-    With db(8)

-        .Fields(1) = "ID"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "rep_id"

-        .Fields(4) = "sale_plan"

-        .Fields(5) = "ClxnH20mg"

-        .Fields(6) = "ClxnH40mg"

-        .Fields(7) = "ClxnT40mg"

-        .Fields(8) = "ClxnC_IM"

-        .Fields(9) = "ClxnC_ACS"

-    End With

-    

-    ReDim db(9).Fields(3)

-    With db(9)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "sale_plan"

-    End With

-    

-    Dim rm_idx As Integer

-    Dim to_db As Object

-    'back uo

-    Merge_BackUp_All_Data

-    

-    'clean up

-    Merge_Clear_All_Data fm_file

-    

-    Set to_db = dbGetConnection(fm_file)

-    

-    For rm_idx = 1 To UBound(rm_files)

-        Dim from_db As Object

-        

-        Set from_db = dbGetConnection(rm_files(rm_idx))

-        

-        Dim new_rm_id As Long

-        new_rm_id = dbMergeRM(from_db, to_db)

-

-        Dim i As Integer

-

-        For i = 1 To UBound(db)

-            Dim get_sql As String

-            Dim getRS As Object

-            Dim insRS As Object

-            Dim field_idx As Integer

-                        

-            get_sql = "SELECT * FROM " & db(i).Name

-            Set getRS = CreateObject("ADODB.Recordset")

-            Set insRS = CreateObject("ADODB.Recordset")

-            insRS.Open db(i).Name, to_db, 2, 2

-

-            getRS.Open get_sql, from_db

-            

-            If Not getRS.BOF Then

-                Do While Not getRS.EOF

-                    insRS.addnew

-                    Dim fld_name As String

-                    

-                    For field_idx = 1 To UBound(db(i).Fields)

-                        fld_name = db(i).Fields(field_idx)

-                        insRS(fld_name) = getRS(fld_name)

-                    Next field_idx

-                    

-                    insRS("rm_id") = new_rm_id

-                    insRS.Update

-                    getRS.MoveNext

-                Loop

-            

-            Else

-                'empty table

-                ' do nothing

-            End If

-            

-            

-        Next i

-        

-        dbCloseOpenedConnection from_db

-    Next rm_idx

-    

-    dbCloseOpenedConnection to_db

-End Sub

-

-Function dbMergeRM(from_dbConnection As Object, to_dbConnection As Object) As Long

-

-    Dim getRecordset As Object

-    Dim getREPData_SQL As String

-    Dim REP_fn As String

-    Dim REP_ln As String

-    Dim REP_region As String

-    Dim REP_city As String

-

-

-    getREPData_SQL = "SELECT * FROM reg_man"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getREPData_SQL, from_dbConnection

-        

-        If Not getRecordset.BOF Then

-            REP_fn = getRecordset("firstname")

-            REP_ln = getRecordset("lastname")

-            REP_city = getRecordset("city")

-            REP_region = getRecordset("region")

-        Else

-            MsgBox "There is no information about Regional Manager! This database cannot be merged!!!"

-            dbMergeRM = -1

-            Exit Function

-        End If

-    

-    Dim insertRecordset As Object

-    Set insertRecordset = CreateObject("ADODB.Recordset")

-        

-    insertRecordset.Open "reg_man", to_dbConnection, 2, 2

-    insertRecordset.addnew

-        

-    insertRecordset("firstname") = REP_fn

-    insertRecordset("lastname") = REP_ln

-    insertRecordset("region") = REP_region

-    insertRecordset("city") = REP_city

-    insertRecordset.Update

-    insertRecordset.MoveLast

-    'new ID

-    dbMergeRM = insertRecordset("mgr_id")

-    

-End Function

-

-Sub cmDataImport()

-    Dim def_dir As String

-    Dim flist() As String

-    Dim i As Integer

-

-    def_dir = GetWBPath(ThisWorkbook.FullName)

-    If GetImportDirectory(def_dir, flist) Then

-        Dim ImpMask() As String

-        ImpMask = Split(flist(1), Chr(95), Compare:=vbBinaryCompare)

-        flist(1) = ImpMask(0) & "*"

-        Dim db_list() As String

-        i = GetDBList(flist(), db_list)

-        

-        If i > 0 Then

-            ImportFromRegionalManagers db_list, GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-        End If

-    End If

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).Select

-End Sub

-

-

-<<<<<<
-======================
-PRJ_QTR
->>>>>>
-Attribute VB_Name = "PRJ_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CPRJ_QT As Integer = 0

-Const CPRJ_ID As Integer = 1

-Const CPRJ_PLN As Integer = 2

-Const CPRJ_FCT As Integer = 3

-Const CPRJ_BDG As Integer = 4

-Const CPRJ_CNT As Integer = 5

-Const CPRJ_BEDS As Integer = 6

-Const CPRJ_HIR As Integer = 7

-Const CPRJ_TER As Integer = 8

-Const CPRJ_CRD As Integer = 9

-Const CPRJ_CLXN_BDG As Integer = 10

-Const CPRJ_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Const LOCAL_ENT_DATE As String = "B11"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("PRJ_QTR")

-        s = "Все регионы, " & .getEnt_date()

-    End With

-    

-    MakeChartTitle = s

-End Function

-

-Sub update_history()

-    Dim objQTR() As tREGION

-    Dim i As Long

-    Dim r As Range

-

-

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetRGN_COMM_DATA(objQTR(), 0)

-    

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CPRJ_QT) = objQTR(i).ent_date

-            r.Offset(i - 1, CPRJ_ID) = ""

-            r.Offset(i - 1, CPRJ_PLN) = objQTR(i).sale_PLAN

-            r.Offset(i - 1, CPRJ_FCT) = objQTR(i).total_SALE

-            r.Offset(i - 1, CPRJ_BDG) = objQTR(i).total_BDGT

-            r.Offset(i - 1, CPRJ_CNT) = objQTR(i).total_LPU

-            r.Offset(i - 1, CPRJ_BEDS) = objQTR(i).total_REP

-            r.Offset(i - 1, CPRJ_HIR) = objQTR(i).total_HIR

-            r.Offset(i - 1, CPRJ_TER) = objQTR(i).total_TER

-            r.Offset(i - 1, CPRJ_CRD) = objQTR(i).total_ACS

-            If objQTR(i).total_BDGT <> 0 Then

-                r.Offset(i - 1, CPRJ_CLXN_BDG) = objQTR(i).total_SALE / objQTR(i).total_BDGT

-            End If

-            If objQTR(i).total_BDGT_NMG <> 0 Then

-                r.Offset(i - 1, CPRJ_CLXN_NMG) = objQTR(i).total_SALE / objQTR(i).total_BDGT_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR_PRJ()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(PRJ_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CPRJ_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CPRJ_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CPRJ_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CPRJ_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CPRJ_CRD + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-

-Sub Draw_PLN_QTR_PRJ()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(PRJ_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CPRJ_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CPRJ_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CPRJ_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CPRJ_FCT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PLN_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Draw_BDGT_QTR_PRJ()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(PRJ_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CPRJ_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CPRJ_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CPRJ_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CPRJ_CLXN_NMG + 1)

-        End If

-    Next i

-    Worksheets("CHRT_BDGT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-Public Sub cbxPRJ_QtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR_PRJ

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR_PRJ

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR_PRJ

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = PRJ_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    Protect UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CPRJ_QT + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    If r = "" Then

-        Worksheets(VAR_SHEET).Range("PRJ_ACTION") = 2

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        Worksheets(VAR_SHEET).Range("PRJ_ACTION") = 2

-        Range("LAST_FOCUS") = currRange.address

-        With Worksheets("REP_LIST")

-            .Range("ret_addr") = "PRJ_QTR"

-            .Range("ent_date") = r

-            .Range("VIEW_ONLY") = True

-        End With

-    End If

-    Cancel = True

-    btPRJ_QTR_Do_IT ' old btRM_OTR_DO_IT

-End Sub

-

-<<<<<<
-======================
-RM_LIST
->>>>>>
-Attribute VB_Name = "RM_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Const LOCAL_ENT_DATE As String = "C10"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-

-Public Function getCurrentRM_ID() As Long

-    Dim r As Range

-

-    With Worksheets("RM_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CRM_ID)

-    End With

-

-    getCurrentRM_ID = r

-End Function

-

-Public Sub RM_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("PM_CHR_IDX")

-        Case 1

-            Rm_Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Rm_Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Rm_Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-

-        Case 4

-            Rm_Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectRM_QTR(rm_id As Long)

-    Dim vo As Boolean

-

-    Range("JUMP") = "RM_QTR"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("RM_QTR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "RM_LIST"

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Public Sub SelectREP_LIST(rm_id As Long)

-    Dim vo As Boolean

-

-    Range("JUMP") = "REP_LIST"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("REP_LIST")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "RM_LIST"

-        .setEnt_date (getEnt_date())

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateRMList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Sub UpdateRMList()

-    Dim rmcd() As tRMID_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-

-    ent_date = getEnt_date

-

-    i = Get_RM_CommonList_by_QTR(rmcd(), ent_date)

-

-    With ThisWorkbook.Worksheets("RM_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(rmcd)

-            r.Offset(i - 1, CRM_NAME) = GetRegionName(rmcd(i).rm.Region)

-            r.Offset(i - 1, CRM_ID) = rmcd(i).rm.rm_id

-            r.Offset(i - 1, CRM_BEDS) = rmcd(i).rgcd(1).total_BEDS

-            r.Offset(i - 1, CRM_BDGT) = rmcd(i).rgcd(1).total_BDGT

-            r.Offset(i - 1, CRM_NMG) = rmcd(i).rgcd(1).total_BDGT_NMG

-            r.Offset(i - 1, CRM_HIR) = rmcd(i).rgcd(1).total_HIR

-            r.Offset(i - 1, CRM_TER) = rmcd(i).rgcd(1).total_TER

-            r.Offset(i - 1, CRM_CAR) = rmcd(i).rgcd(1).total_ACS

-            r.Offset(i - 1, CRM_FACT) = rmcd(i).rgcd(1).total_SALE

-            r.Offset(i - 1, CRM_PLAN) = rmcd(i).rgcd(1).sale_PLAN

-            

-            With rmcd(i).rgcd(1)

-                r.Offset(i - 1, CRM_PAT_LPU) = .total_HIR + .total_TER + .total_ACS

-            End With

-            

-            r.Offset(i - 1, CRM_BDGT_1) = rmcd(i).rgcd(1).total_BDGT

-            If rmcd(i).rgcd(1).total_BDGT > 0 Then

-                r.Offset(i - 1, CRM_BDGT_1 + 1) = rmcd(i).rgcd(1).total_SALE / rmcd(i).rgcd(1).total_BDGT

-            End If

-            If r.Offset(i - 1, CRM_BDGT_1 + 1) > 1 Then

-                r.Offset(i - 1, CRM_BDGT_1 + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim rep_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CRM_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CRM_AREA).row, CRM_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    rep_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CRM_AREA).Column

-

-    If i < 4 Then

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 1

-    Else

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 2

-    End If

-

-    If rep_id = 0 Then

-        Range("LAST_FOCUS") = Range(CRM_AREA).address

-    End If

-

-    If rep_id = 0 Then

-        i = CRM_NAME

-        Range("JUMP") = ""

-    Else

-        btRM_LIST_DO_IT

-    End If

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-<<<<<<
-======================
-mPRJ_QTR
->>>>>>
-Attribute VB_Name = "mPRJ_QTR"

-Sub btPRJ_QTR_Do_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    

-    idx = Worksheets(VAR_SHEET).Range("PRJ_ACTION")

-    ent_date = Worksheets(PRJ_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            cmDataImport

-        Case 2

-            Worksheets("RM_LIST").setEnt_date (Worksheets("PRJ_QTR").getEnt_date())

-            Worksheets("RM_LIST").Range("ret_addr") = "PRJ_QTR"

-            Worksheets("RM_LIST").Select

-        Case 3

-            cmNewReport

-    End Select

-    Worksheets(VAR_SHEET).Range("PRJ_ACTION") = 2

-End Sub

-

-

-<<<<<<
-======================
-mRM_LIST
->>>>>>
-Attribute VB_Name = "mRM_LIST"

-Option Explicit

-

-Public Const CRM_AREA As String = "B12"

-Public Const CRM_NAME As Integer = 0

-Public Const CRM_NAME1 As Integer = 1

-Public Const CRM_NAME2 As Integer = 2

-Public Const CRM_ID As Integer = 3

-Public Const CRM_BEDS As Integer = 4

-Public Const CRM_BDGT As Integer = 5

-Public Const CRM_NMG As Integer = 6

-Public Const CRM_HIR As Integer = 7

-Public Const CRM_TER As Integer = 8

-Public Const CRM_CAR As Integer = 9

-Public Const CRM_FACT As Integer = 10

-Public Const CRM_PLAN As Integer = 11

-Public Const CRM_PAT_LPU As Integer = 16

-Public Const CRM_BDGT_1 As Integer = 17

-

-

-Const LOCAL_ENT_DATE As String = "C10"

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Sub EditREP(CRM As tREPID, ent_date As String)

-    NoFunc

-End Sub

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("RM_LIST")

-        s = "Регионы, " & .getEnt_date()

-    End With

-    

-    MakeChartTitle = s

-End Function

-

-Sub Rm_Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_LPU_BBL").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rm_Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRM_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRM_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRM_FACT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PIE").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rm_Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CRM_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRM_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRM_HIR + 1)

-            psum = psum + src.Cells(i, CRM_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRM_TER + 1)

-            psum = psum + src.Cells(i, CRM_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRM_CAR + 1)

-            psum = psum + src.Cells(i, CRM_CAR + 1)

-            dst.Cells(i, 5) = psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU").Range("title") = MakeChartTitle

-    

-End Sub

-

-Sub Rm_Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CRM_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRM_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRM_HIR + 1)

-            psum = psum + src.Cells(i, CRM_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRM_TER + 1)

-            psum = psum + src.Cells(i, CRM_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRM_CAR + 1)

-            psum = psum + src.Cells(i, CRM_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CRM_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU_A").Range("title") = MakeChartTitle

-    

-End Sub

-

-Sub btRM_LIST_RET_IT()

-    With Worksheets("RM_LIST")

-        .setEnt_date ("")

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = "PRJ_QTR"

-    End With

-    ThisWorkbook.Worksheets("PRJ_QTR").Activate

-End Sub

-

-

-Sub btRM_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim rm_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("RM_LIST_ACTION")

-    With Worksheets("RM_LIST")

-        rm_id = .getCurrentRM_ID()

-        

-        Select Case i

-            Case 1:

-                .SelectRM_QTR rm_id

-            Case 2:

-                .SelectREP_LIST rm_id

-            End Select

-    End With

-    

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-

-

-

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mImport2
->>>>>>
-Attribute VB_Name = "mImport2"

-Option Explicit

-

-Sub FOpen()

-    Dim flist As String

-    Dim fileToOpen, s

-    flist = ""

-    fileToOpen = Application _

-        .GetOpenFileName("Data Files (*.mdb), mr*.mdb", Title:="Импорт данных", MultiSelect:=True)

-    If fileToOpen <> False Then

-        For Each s In fileToOpen

-            flist = flist & s & "; "

-        Next s

-        MsgBox "Open " & flist

-    End If

-End Sub

-

-Sub t2()

-Dim d As ImprtDB

-Set d = New ImprtDB

-d.Show

-

-End Sub

-

-<<<<<<
-======================
-ImprtDB
->>>>>>
-Attribute VB_Name = "ImprtDB"

-Attribute VB_Base = "0{67FA6A28-8370-4981-8F01-1A9079245761}{ECFCB43F-B241-4CD9-9CB3-2A981933173D}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btSelAll_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = True

-    Next i

-End Sub

-

-Private Sub btUnselect_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = False

-    Next i

-End Sub

-<<<<<<
-======================
-mImport
->>>>>>
-Attribute VB_Name = "mImport"

-    Option Explicit

-

-Const OFN_ALLOWMULTISELECT As Long = 512

-Const OFN_EXPLORER As Long = 524288

-Const OFN_HIDEREADONLY As Long = 4

-Const OFN_NONETWORKBUTTON As Long = 131072

-Const OFN_READONLY As Long = 1

-       

-Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _

-  "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

-

-Private Type OPENFILENAME

-  lStructSize As Long

-  hWndOwner As Long

-  hInstance As Long

-  lpstrFilter As String

-  lpstrCustomFilter As String

-  nMaxCustFilter As Long

-  nFilterIndex As Long

-  lpstrFile As String

-  nMaxFile As Long

-  lpstrFileTitle As String

-  nMaxFileTitle As Long

-  lpstrInitialDir As String

-  lpstrTitle As String

-  flags As Long

-  nFileOffset As Integer

-  nFileExtension As Integer

-  lpstrDefExt As String

-  lCustData As Long

-  lpfnHook As Long

-  lpTemplateName As String

-End Type

-

-Private Sub Command1_Click()

-  Dim OpenFile As OPENFILENAME

-  Dim lReturn As Long

-  Dim sFilter As String

-  OpenFile.lStructSize = Len(OpenFile)

-'         OpenFile.hwndOwner = Form1.hWnd

-'         OpenFile.hInstance = App.hInstance

-  sFilter = "Clexane Data Files" & Chr(0) & "mr*.mdb" & Chr(0)

-  OpenFile.lpstrFilter = sFilter

-  OpenFile.nFilterIndex = 1

-  OpenFile.lpstrFile = String(257, 0)

-  OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1

-  OpenFile.lpstrFileTitle = OpenFile.lpstrFile

-  OpenFile.nMaxFileTitle = OpenFile.nMaxFile

-' OpenFile.lpstrInitialDir = "C:\"

-  OpenFile.lpstrTitle = "Импорт данных"

-  OpenFile.flags = OFN_HIDEREADONLY + OFN_ALLOWMULTISELECT + OFN_EXPLORER

-  lReturn = GetOpenFileName(OpenFile)

-  If lReturn = 0 Then

-     MsgBox "The User pressed the Cancel Button"

-  Else

-     MsgBox "The user Chose " & Trim(OpenFile.lpstrFile)

-  End If

-End Sub

-

-<<<<<<
-Project Name : 'ClexaneRM'
-Quirk - duff tag length======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    ThisWorkbook.Worksheets(RM_QTR_SHEET).ClearRMName

-    

-    Application.EnableEvents = True

-    Set MyAppEvents.app = Application

-    

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    

-    MyAppEvents.CheckWorkBooksArround ThisWorkbook

-    

-    cmSetStandaloneMode

-    

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-    

-    Application.ScreenUpdating = True

-    

-    If CheckUser Then

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).update_history

-        Application.Calculate

-    End If

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    

-    Dim RestMode As Boolean

-    RestMode = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE")

-    

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-'        If RestMode Then

-            ThisWorkbook.Saved = True

-'        Else

-'            ThisWorkbook.Save

-'        End If

-    End If

-    Application.Caption = Empty

-    Application.CommandBars(STDBAR_NAME).Reset

-    If RestMode Then

-        xlRestoreView

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    End If

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-    Dim MaxX, MaxY As Integer

-    With ThisWorkbook.Worksheets(TITLE_SHEET)

-        MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-        MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-    End With

-

-    With ThisWorkbook.Application

-        .ScreenUpdating = False

-        .WindowState = xlNormal

-        .Height = MaxY

-        .Width = MaxX

-    End With

-End Sub

-

-

-

-

-

-<<<<<<
-======================
-REP_QTR
->>>>>>
-Attribute VB_Name = "REP_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CQTR_QT As Integer = 0

-Const CQTR_ID As Integer = 1

-Const CQTR_PLN As Integer = 2

-Const CQTR_FCT As Integer = 3

-Const CQTR_BDG As Integer = 4

-Const CQTR_CNT As Integer = 5

-Const CQTR_BEDS As Integer = 6

-Const CQTR_HIR As Integer = 7

-Const CQTR_TER As Integer = 8

-Const CQTR_CRD As Integer = 9

-Const CQTR_CLXN_BDG As Integer = 10

-Const CQTR_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub update_history()

-    Dim objQTR() As tQTR

-    Dim i As Long

-    Dim r As Range

-    Dim cRep As tREPID

-

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    Range("D4") = cRep.LastName

-    Range("D5") = cRep.FirstName

-

-    Range("H4") = GetRegionName(cRep.Region)

-    Range("H5") = GetCityName(cRep.Region, cRep.City)

-

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetAll_QTR_Records_by_REP(objQTR, "%", cRep.rep_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CQTR_QT) = objQTR(i).entry_date

-        Next i

-    End If

-    Dim qcd() As tQTR_COMMON

-    i = Get_QTR_CommonList_by_REP(qcd, "%", cRep.rep_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(qcd)

-            r.Offset(i - 1, CQTR_QT) = qcd(i).qtr.entry_date

-            r.Offset(i - 1, CQTR_ID) = qcd(i).qtr.id

-            r.Offset(i - 1, CQTR_PLN) = qcd(i).qtr.sale_PLAN

-            r.Offset(i - 1, CQTR_FCT) = qcd(i).c_sale_ALL

-            r.Offset(i - 1, CQTR_BDG) = qcd(i).c_bdgt_LPU

-            r.Offset(i - 1, CQTR_CNT) = qcd(i).i_lcd

-            r.Offset(i - 1, CQTR_BEDS) = qcd(i).c_beds

-            r.Offset(i - 1, CQTR_HIR) = qcd(i).c_pat_HIR

-            r.Offset(i - 1, CQTR_TER) = qcd(i).c_pat_TER

-            r.Offset(i - 1, CQTR_CRD) = qcd(i).c_pat_CRD

-            If qcd(i).c_bdgt_LPU <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_BDG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_LPU

-            End If

-            If qcd(i).c_bdgt_NMG <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_NMG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CQTR_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRepQtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect UserInterfaceOnly:=True

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CQTR_ID + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    i = currRange.Column - Range(CINP_AREA).Column

-

-    QTR_ID = r

-

-    If QTR_ID = 0 Then

-        Worksheets(VAR_SHEET).Range("USER_ACTION") = 1

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        If i > CQTR_FCT Then

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-            Range("LAST_FOCUS") = currRange.address

-        Else

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 3

-            Range("LAST_FOCUS") = currRange.address

-        End If

-    End If

-    Cancel = True

-    btHomeDo_IT

-End Sub

-

-<<<<<<
-======================
-mRep_QTR
->>>>>>
-Attribute VB_Name = "mRep_QTR"

-Option Explicit

-

-Sub NoFunc()

-    MsgBox "Функция не доступна", vbOKOnly, PROGRAM_NAME

-End Sub

-

-Sub DO_Price_qtr(ent_date As String)

-    Dim qtr As tQTR

-    Dim res As Integer

-    Dim cRep As tREPID

-

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    qtr = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-

-    If qtr.id = 0 Then

-        qtr.entry_date = ent_date

-

-        With Worksheets(VAR_SHEET)

-            qtr.ClxnH20mg = .Range("ClxnH20mg")

-            qtr.ClxnH40mg = .Range("ClxnH40mg")

-            qtr.ClxnT40mg = .Range("ClxnT40mg")

-            qtr.ClxnC_ACS = .Range("ClxnC_ACS")

-            qtr.ClxnC_IM = .Range("ClxnC_IM")

-        End With

-    End If

-

-    Dim dlg_nq As dlg_nextQTR

-    Set dlg_nq = New dlg_nextQTR

-

-    With dlg_nq

-        .tb_qtr_name = qtr.entry_date

-        .tb_bdgt_avts = qtr.sale_PLAN

-        .tb_qtr_name = qtr.entry_date

-        .tb_ClxnH20mg = qtr.ClxnH20mg

-        .tb_ClxnH40mg = qtr.ClxnH40mg

-        .tb_ClxnT40mg = qtr.ClxnT40mg

-        .tb_ClxnC_ACS = qtr.ClxnC_ACS

-        .tb_ClxnC_IM = qtr.ClxnC_IM

-    End With

-

-    dlg_nq.Show

-End Sub

-

-Sub DO_Edit_qtr(ent_date As String)

-    If ent_date = "" Then

-        NoFunc

-    Else

-        Dim rep_id As Long

-        rep_id = Worksheets(REP_QTR_SHEET).Range("REP_ID")

-        With ThisWorkbook.Worksheets("LPU_LIST")

-            .Range("VIEW_ONLY") = True

-            .Range("ent_date") = ent_date

-            .Range("REP_ID") = rep_id

-            .Select

-        End With

-    End If

-End Sub

-

-Sub DO_Delete_qtr(ent_date As String)

-    If ent_date <> "" Then

-        MsgBox "Удалить данные за период [" & ent_date & "] нельзя ", vbOKOnly, PROGRAM_NAME

-    End If

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-

-Sub btHomeDo_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    idx = Worksheets(VAR_SHEET).Range("USER_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            NoFunc

-            ' Обновляем экран

-        Case 2

-            DO_Edit_qtr ent_date

-        Case 3

-            DO_Price_qtr ent_date

-        Case 4

-            NoFunc

-    End Select

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-Sub Delete_qtr()

-'    Dim ent_date As String

-'    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-'    DO_Delete_qtr ent_date

-End Sub

-

-Sub btREP_QTR_RET_IT()

-    Dim s As String

-    With Worksheets("REP_QTR")

-        .Range("LAST_FOCUS") = ""

-        s = .Range("ret_addr")

-        .Range("ret_addr") = ""

-    End With

-    If s <> "" Then

-        ThisWorkbook.Worksheets(s).Select

-    Else

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane[RM]"

-Public Const PROGRAM_VERSION As String = "version 1.3"

-Public Const PROGRAM_FILENAME As String = "clexane-rm"

-Public Const PROGRAM_BACKUPNAME As String = "rm-backup-"

-Public Const PROGRAM_EXPORTNAME As String = "rm-ex-"

-Public Const PROGRAM_IMPORTNAME As String = "mr-ex-*"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20030329

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "O40"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-Public Const RM_QTR_SHEET As String = "RM_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-

-End Sub

-

-Function Double2Str(ByVal d As Double, ByVal precision As Integer, Optional Delim As String = ".") As String

-    Dim s As String

-    If Not precision > 0 Then

-        s = Round(d)

-    Else

-        Dim i As Integer

-        i = Fix(d)

-        s = i & Delim

-        d = Abs(d - i)

-        Do

-            precision = precision - 1

-            d = d * 10

-            If precision > 0 Then

-                i = Fix(d)

-            Else

-                i = Round(d)

-            End If

-            If i < 1 Then

-                s = s & "0"

-            Else

-                s = s & i

-                d = d - i

-            End If

-        Loop While precision > 0

-    End If

-    Double2Str = s

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetWBName(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBName = Right(FullName, s_len - pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.name = VAR_SHEET Or sh.name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-<<<<<<
-======================
-Var
->>>>>>
-Attribute VB_Name = "Var"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-title
->>>>>>
-Attribute VB_Name = "title"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LPU_LIST
->>>>>>
-Attribute VB_Name = "LPU_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentLPU_ID() As Long

-    Dim r As Range

-

-    With Worksheets("LPU_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CLPU_ID)

-    End With

-

-    getCurrentLPU_ID = r

-End Function

-

-Public Sub LPU_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectLPU_NAME(lpu_id As Long, ent_date As String)

-    If Range("VIEW_ONLY") = True Then

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    Dim cLPU As tLPU

-    If lpu_id = 0 Then

-        cLPU.id = 0

-        cLPU.rep_id = 0

-        cLPU.address = ""

-        cLPU.name = ""

-    Else

-        cLPU = Get_LPU_Record(lpu_id)

-    End If

-    EditLPU cLPU, getEnt_date

-    Worksheet_Activate

-End Sub

-

-Sub SelectLPU_BDGT(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    vo = Range("VIEW_ONLY")

-    If lpu_id = 0 Then

-        SelectLPU_NAME lpu_id, ent_date

-    Else

-        With ThisWorkbook.Worksheets("LPU_BDGT")

-            .Range("VIEW_ONLY") = vo

-            .Range("ret_addr") = "LPU_LIST"

-            .Range("REP_ID") = r_id

-            .Range("ent_date") = ent_date

-            .Range("lpu_id") = lpu_id

-        End With

-    End If

-End Sub

-

-Sub SelectLPU_HIR(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_HIR")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Sub SelectLPU_TER(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_TER")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Sub SelectLPU_C_ACS(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_C_ACS")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect UserInterfaceOnly:=True

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateLPUList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim lpu_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CINP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CINP_AREA).row, CLPU_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    lpu_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CINP_AREA).Column

-

-    If lpu_id = 0 Then

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    End If

-

-    If lpu_id = 0 Then

-        i = CLPU_NAME

-        Range("JUMP") = ""

-    End If

-    Select Case i

-        Case CLPU_NAME, CLPU_NAME1, CLPU_NAME2, CLPU_BEDS

-            SelectLPU_NAME lpu_id, ent_date

-            Range("JUMP") = ""

-

-        Case CLPU_NMG, CLPU_NFG, CLPU_PLAN, CLPU_FACT

-            SelectLPU_BDGT lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-

-        Case CLPU_HIR

-            SelectLPU_HIR lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_HIR"

-

-        Case CLPU_TER

-            SelectLPU_TER lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_TER"

-

-        Case CLPU_CAR

-            SelectLPU_C_ACS lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        Case Else

-            Range("JUMP") = ""

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateLPUList()

-    Dim lcd() As tLPU_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-    Dim objQTR As tQTR

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    ent_date = getEnt_date

-

-'     ent_date = "%" ' % - all records

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-    i = Get_LPU_CommonQTR(lcd, objQTR)

-

-'     стираем ФИО

-    Range("C3:C4").ClearContents

-

-    Range("C3") = cRep.LastName

-    Range("C4") = cRep.FirstName

-    Range("G3") = GetRegionName(cRep.Region)

-    Range("G4") = GetCityName(cRep.Region, cRep.City)

-    Range("G5") = objQTR.sale_PLAN

-

-

-

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(lcd)

-            r.Offset(i - 1, CLPU_NAME) = lcd(i).lpu.name

-            r.Offset(i - 1, CLPU_ID) = lcd(i).lpu.id

-            r.Offset(i - 1, CLPU_BEDS) = lcd(i).lpu.beds

-

-

-            r.Offset(i - 1, CLPU_NFG) = lcd(i).bdgt.bdgt_NFG

-            r.Offset(i - 1, CLPU_NMG) = lcd(i).bdgt.bdgt_NMG

-            r.Offset(i - 1, CLPU_PLAN) = lcd(i).bdgt.sale_PLAN

-

-            r.Offset(i - 1, CLPU_HIR) = lcd(i).pat_HIR

-            r.Offset(i - 1, CLPU_TER) = lcd(i).pat_TER

-            r.Offset(i - 1, CLPU_CAR) = lcd(i).pat_CRD

-            r.Offset(i - 1, CLPU_FACT) = lcd(i).sale_ALL

-            r.Offset(i - 1, CLPU_PAT_LPU) = lcd(i).pat_LPU

-            r.Offset(i - 1, CLPU_BDGT) = lcd(i).bdgt_LPU

-            If lcd(i).bdgt_LPU > 0 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = lcd(i).sale_ALL / lcd(i).bdgt_LPU

-            End If

-            If r.Offset(i - 1, CLPU_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{F2A5159C-AEB6-4066-B85F-339184DAFECD}{712D78F6-CCB6-499E-9674-B992A7482317}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-dbACS
->>>>>>
-Attribute VB_Name = "dbACS"

-Option Explicit

-

-Public Type tACS

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    patients_with_geparins As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objACS.ID <> 0 then updatre else insert

-Sub Insert_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objACS.id <> 0 Then

-        dbUpdate_ACS_Record dbConnection, objACS

-    Else

-        dbInsert_ACS_Record dbConnection, objACS

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_ACS_RecordsByLPU_ID(ByRef all_ACS_() As tACS, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_ACS_RecordsByLPU_ID = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, all_ACS_, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_ACS_Record dbConnection, objACS

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub dbInsert_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_acs", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objACS

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("patients_with_geparins") = .patients_with_geparins

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objACS.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim Update_SQL As String

-    

-    With objACS

-        Update_SQL = "UPDATE lpu_acs SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "patients_with_geparins=" & .patients_with_geparins & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_ACS_RecordsbyLPU_ID(dbConnection As Object, all_ACS() As tACS, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_ACS_SQL As String

-    Dim getAll_ACS_SQL As String

-    Dim ACS_Count As Long

-    ACS_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_ACS_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        ACS_Count = dbRecordset("ACS_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_ACS_RecordsbyLPU_ID = ACS_Count

-    

-    If ACS_Count > 0 Then

-        'we have records

-        ReDim all_ACS(1 To ACS_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_ACS_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_ACS As tACS

-                 With tmp_ACS

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .patients_with_geparins = dbRecordset("patients_with_geparins")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 all_ACS(index) = tmp_ACS

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE ID=" & objACS.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_ACS_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_HIR
->>>>>>
-Attribute VB_Name = "LPU_CLSN_HIR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-

-        Dim objHir As tHIRURGIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objHir

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .operations_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L9")

-                .patients_ambulator_clexan_20mg = Range("L10")

-                .patients_ambulator_clexan_40mg = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L19")

-                .patients_stationar_clexan_20mg = Range("L20")

-                .patients_stationar_clexan_40mg = Range("L21")

-            End With

-            Insert_Hir_Record objHir

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objHir.id = Range("rec_id")

-                    If objHir.id <> 0 Then

-                        Delete_Hir_Record objHir

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objHir As tHIRURGIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    With objHir

-        Range("rec_id") = .id

-        Range("F6") = .operations_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L9") = .patients_ambulator_clexan

-        Range("L10") = .patients_ambulator_clexan_20mg

-        Range("I21") = .patients_stationar_nmg

-        Range("L19") = .patients_stationar_clexan

-        Range("L20") = .patients_stationar_clexan_20mg

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id)

-

-        formula = "=" & qtr.ClxnH20mg & "*($L$10+$L$20)+" & qtr.ClxnH40mg & "*($L$11+$L$21)"

-        Range("F11").formula = formula

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objHir() As tHIRURGIA

-        Dim i As Integer

-        i = GetAll_Hir_RecordsByLPU_ID(objHir, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.3

-        Else

-            SetupData objHir(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-mSapes
->>>>>>
-Attribute VB_Name = "mSapes"

-Option Explicit

-

-Const SHAPE_COLOR As Integer = 1

-Const SHAPE_NAME As Integer = 2

-

-

-Sub ShapeView(r_sh_finite_state As Range)

-    Dim chk As Range

-    Dim s As String

-    Dim c, idx As Integer

-    For Each chk In r_sh_finite_state

-        idx = 0

-        If chk = "+" Then

-            c = chk.Offset(0, idx + SHAPE_COLOR)

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While c <> 0

-                ShapeFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s)), c

-                idx = idx + 2

-                c = chk.Offset(0, idx + SHAPE_COLOR)

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        Else

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While s <> ""

-                ShapeUnFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s))

-                idx = idx + 2

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        End If

-    Next chk

-End Sub

-

-Sub ShapeFill(sh As ShapeRange, ByVal color As Integer)

-    sh.Fill.Visible = msoTrue

-    sh.Fill.Solid

-    sh.Fill.ForeColor.SchemeColor = color

-    sh.Fill.Transparency = 0#

-End Sub

-

-Sub ShapeUnFill(sh As ShapeRange)

-    sh.Fill.Visible = msoFalse

-    sh.Fill.Transparency = 0#

-End Sub

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Public Const INPUT_NO = 0

-Public Const INPUT_NUMBER = 1

-Public Const INPUT_PERCENT = 2

-Public Const INPUT_STRING = 3

-Public Const INPUT_CHECK = 4

-

-Public Const INP_IDX_TYPE = 1

-Public Const INP_IDX_NEXT = 2

-Public Const INP_IDX_MIN = 3

-Public Const INP_IDX_MAX = 4

-Public Const INP_IDX_DEP = 5

-Public Const INP_IDX_ALT = 7

-

-

-Public Type tInputSet

-    vType As Integer

-    vMin As Long

-    vMax As Long

-    rChk As String

-End Type

-

-Function is_input_cell(ByVal Target As Range, inputs As Range) As tInputSet

-    Dim t As Range

-    Dim iset As tInputSet

-    Dim test As Range

-    iset.vType = INPUT_NO

-    iset.vMin = 0

-    iset.vMax = 0

-    iset.rChk = ""

-    is_input_cell = iset

-

-' Закоментировать следующую сточку для работы

-'  Exit Function

-

-    Set test = Target.Cells(1, 1)

-    For Each t In inputs

-        If Range(t).Column = test.Column And Range(t).row = test.row Then

-            iset.vType = t.Offset(0, INP_IDX_TYPE).Value

-            Select Case iset.vType

-                Case INPUT_CHECK

-                    iset.rChk = t.Offset(0, INP_IDX_ALT)

-                Case INPUT_NUMBER, INPUT_PERCENT

-                    iset.vMin = t.Offset(0, INP_IDX_MIN).Value

-                    iset.vMax = t.Offset(0, INP_IDX_MAX).Value

-            End Select

-            is_input_cell = iset

-            Exit Function

-        End If

-    Next t

-End Function

-

-Function GetFocusAddress(ByVal r As Range, f_next As Range) As String

-    Dim chk, t As Range

-    

-    For Each chk In f_next

-        For Each t In r

-            If t.address = chk Then

-                GetFocusAddress = chk

-                Exit Function

-            End If

-            If Range(chk).Column = t.Column - 1 And Range(chk).row = t.row _

-            Or Range(chk).Column = t.Column And Range(chk).row = t.row - 1 _

-            Then

-                If Range(chk) <> "" Then

-                    If Range(chk) = 0 Then

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_ALT)).address

-                    Else

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_NEXT)).address

-                    End If

-                Else

-                    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-                End If

-                Exit Function

-            End If

-        Next t

-    Next chk

-    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-End Function

-

-Sub SetDependet(r As Range, inputs As Range)

-    Dim chk As Range

-    Dim s, serr As String

-    Dim idx As Integer

-    Dim iset As tInputSet

-    Dim err_found As Boolean

-    

-    If r.count > 1 Then

-        Exit Sub

-    End If

-    

-    err_found = False

-    For Each chk In inputs

-        idx = INP_IDX_DEP

-        

-        

-        iset.vType = chk.Offset(0, INP_IDX_TYPE).Value

-        Select Case iset.vType

-            Case INPUT_NUMBER, INPUT_PERCENT

-                iset.vMin = chk.Offset(0, INP_IDX_MIN).Value

-                iset.vMax = chk.Offset(0, INP_IDX_MAX).Value

-                

-                If Range(chk) > iset.vMax Then

-                    err_found = True

-                    Range(chk) = iset.vMax

-                    serr = "Выход за дозволенный диапазон [" & iset.vMin & ".." & iset.vMax & "]! Данные скорректированы."

-                End If

-                

-                If Range(chk) = "" Then

-                    s = chk.Offset(0, idx)

-                    Do While s <> ""

-                        Range(s) = ""

-                        idx = idx + 1

-                        s = chk.Offset(0, idx)

-                    Loop

-                End If

-        End Select

-    Next chk

-    If err_found Then

-        MsgBox serr, vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Function CheckInputData(inputs As Range) As Boolean

-    Dim r As Range

-    

-    CheckInputData = True

-    For Each r In inputs

-        If Range(r) = "" Then

-            CheckInputData = False

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100.", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Sub Check_Int_Number(Target As Range, Def_Val As Long)

-    Dim err As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    err = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                err = True

-            End If

-        End If

-    Next r

-    If err Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_TER
->>>>>>
-Attribute VB_Name = "LPU_CLSN_TER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim objTer As tTERAPIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objTer

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .patients_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L20")

-            End With

-            Insert_Ter_Record objTer

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objTer.id = Range("rec_id")

-                    If objTer.id <> 0 Then

-                        Delete_Ter_Record objTer

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objTer As tTERAPIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    With objTer

-        Range("rec_id") = .id

-        Range("F6") = .patients_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L11") = .patients_ambulator_clexan

-        Range("I21") = .patients_stationar_nmg

-        Range("L20") = .patients_stationar_clexan

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id)

-        formula = "=" & qtr.ClxnT40mg & "*($L$12+$L$20)"

-        Range("F11").formula = formula

-

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objTer() As tTERAPIA

-        Dim i As Integer

-        i = GetAll_Ter_RecordsByLPU_ID(objTer, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.25

-        Else

-            SetupData objTer(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{5D2CB2D2-3E5E-4B6E-9E0C-2EEBA5E10E17}{C891C133-B6B4-43D3-B411-B4A821905C23}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-LPU_BDGT
->>>>>>
-Attribute VB_Name = "LPU_BDGT"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub SetDefFocus()

-    Range(Range("DEF_FOCUS")).Select

-End Sub

-

-Public Sub ClearData()

-    ClearSheetData

-End Sub

-

-Sub ClearSheetData()

-    If Range("F10") = 0 And Range("F13") = 0 Then

-        Range("F11:F18") = ""

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("F11:F13") = ""

-    End If

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim bdgt As tBUDGET

-        Dim test As Boolean

-        Dim sum As Long

-        With bdgt

-            .lpu_id = Range("lpu_id")

-            .id = Range("rec_id")

-            .entry_date = Range("ent_date")

-            .bdgt_NMG = Round(Range("F11").Value, 0)

-            .bdgt_NFG = Round(Range("F12").Value, 0)

-            .sale_PLAN = Round(Range("F13").Value, 0)

-

-            sum = .bdgt_NFG + .bdgt_NMG - .sale_PLAN

-            test = .bdgt_NFG <> 0 Or .bdgt_NMG <> 0 Or .sale_PLAN <> 0

-        End With

-        If test Then

-            If sum < 0 Then

-                MsgBox _

-                    "Ваш план превышает выделенный на гепарины бюджет. Сохранить данные?", _

-                    vbOKOnly, PROGRAM_NAME

-            End If

-            If test Then

-                Insert_BDGT_Record bdgt

-            End If

-        Else

-            If bdgt.id <> 0 Then

-                If vbYes = MsgBox("Удалить данные из базы!", vbYesNo, PROGRAM_NAME) Then

-                    Delete_BDGT_Record bdgt

-                End If

-                ret_back Range("DEF_FOCUS").Worksheet

-                Exit Sub

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-    End If

-

-   ClearData

-   ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(cLPU As tLPU_COMMON)

-    Dim t_sum As Long

-    t_sum = 0

-' Setup budget data

-    Range("F11") = cLPU.bdgt.bdgt_NMG

-    Range("F12") = cLPU.bdgt.bdgt_NFG

-    Range("F13") = cLPU.bdgt.sale_PLAN

-

-    With cLPU

-        Range("F14") = .pat_ALL

-        Range("F15") = .pat_HIR

-        Range("F16") = .pat_TER

-        Range("F17") = .pat_CRD

-        Range("F18") = .sale_ALL

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-    ws_activate

-End Sub

-

-

-Sub ws_activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Dim cLPU As tLPU_COMMON

-    Dim objQTR As tQTR

-    Dim objLPU As tLPU

-    Dim ent_date As String

-    Dim id As Long

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    id = Range("lpu_id").Value

-    ent_date = Range("ent_date")

-    

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-

-    objLPU = Get_LPU_Record(id)

-    Get_LPU_Common cLPU, objLPU, objQTR

-

-    If cLPU.lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = cLPU.lpu.beds

-        Range("lpu_name") = cLPU.lpu.name

-        Range("lpu_addr") = cLPU.lpu.address

-        Range("rec_id") = cLPU.bdgt.id

-

-        SetupData cLPU

-

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-'    MsgBox Target.address

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case INPUT_CHECK

-

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{BB60E38F-A4AB-4AB4-91D0-40AA798D9F5C}{BE9A54D9-F093-4755-9E17-0B47BB5E2546}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mSheets
->>>>>>
-Attribute VB_Name = "mSheets"

-Option Explicit

-

-Function am_load_now() As Boolean

-    am_load_now = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE")

-End Function

-

-Sub Wks_select(RetSheet As String)

-    Dim sheet As Worksheet

-    For Each sheet In ThisWorkbook.Worksheets

-        If sheet.name = RetSheet Then

-            ThisWorkbook.Worksheets(RetSheet).Select

-            Exit Sub

-        End If

-    Next sheet

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub ret_back(sh As Worksheet)

-    Dim RetSheet As String

-    RetSheet = sh.Range("ret_addr")

-    sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    sh.Range("ret_addr") = ""

-    sh.Range("rec_id") = ""

-    sh.Range("lpu_id") = ""

-    sh.Range("ent_date") = ""

-    sh.Range("lpu_name") = ""

-    sh.Range("lpu_addr") = ""

-    sh.Range("lpu_beds") = ""

-    Wks_select RetSheet

-End Sub

-

-Sub ClearSheetData(r_start As Range)

-    If r_start <> "" Then

-        r_start.Worksheet.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        r_start = ""

-    Else

-        ret_back r_start.Worksheet

-    End If

-End Sub

-

-Sub wks_sel_chng(iset As tInputSet, ByVal Target As Range, sh As Worksheet)

-    Dim DebugMode As Boolean

-    Dim in_range As Range

-    

-    DebugMode = Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-

-    If DebugMode Then

-        sh.Unprotect

-    Else

-        sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    End If

-

-    If iset.vType = INPUT_CHECK Then

-        Set in_range = Target.Worksheet.Range(iset.rChk)

-    Else

-        Set in_range = Target

-    End If

-    

-    Dim str As String

-    str = GetFocusAddress(in_range, sh.Range("h_inputs"))

-

-'    MsgBox Target.Address & "; " & str

-    If str <> Target.address Then

-        sh.Range(str).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-Dlg_lpu_card
->>>>>>
-Attribute VB_Name = "Dlg_lpu_card"

-Attribute VB_Base = "0{2C69E842-8DA9-4240-A0A8-F6B0141DC246}{75AAB28C-ADCF-4D1B-9D5A-AF89E80A810C}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbLPU_List_Change()

-    Dim src As Range

-    Dim idx_src As Integer

-    

-    Set src = Worksheets(VAR_SHEET).Range(Me.cbLPU_List.RowSource)

-    idx_src = Me.cbLPU_List.ListIndex + 1

-    Me.tb_lpu_name.Text = src.Cells(idx_src, 1)

-    Me.tb_lpu_address.Text = src.Cells(idx_src, 2)

-    Me.tbBedsCount.Text = src.Cells(idx_src, 3)

-End Sub

-

-

-Private Sub cbxLPU_List_Enable_Click()

-    

-    If Me.cbxLPU_List_Enable Then

-        

-        Me.tb_lpu_name.Text = ""

-        Me.tb_lpu_name.Enabled = False

-        

-        Me.tb_lpu_address.Text = ""

-        Me.tb_lpu_address.Enabled = False

-        

-        Me.tbBedsCount.Text = ""

-        Me.tbBedsCount.Enabled = False

-        

-        Me.cbLPU_List.Enabled = True

-        cbLPU_List_Change

-    Else

-        Me.tb_lpu_name.Enabled = True

-        Me.tb_lpu_name.Text = ""

-        

-        Me.tb_lpu_address.Enabled = True

-        Me.tb_lpu_address.Text = ""

-        

-        Me.tbBedsCount.Enabled = True

-        Me.tbBedsCount.Text = ""

-        

-        Me.cbLPU_List.Enabled = False

-    End If

-End Sub

-

-<<<<<<
-======================
-UserInfo
->>>>>>
-Attribute VB_Name = "UserInfo"

-Attribute VB_Base = "0{BA873669-5C2D-400A-8A8B-572ACD8CCE4C}{D11400A0-9912-4240-A78C-44C33731216A}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Tag = vbOK

-End Sub

-

-Private Sub cbCity_Change()

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_CITY") = Me.cbCity.ListIndex

-        .Calculate

-    End With

-End Sub

-

-Private Sub cbRegion_Change()

-    Dim LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        NewRangeOffsetCol = cbRegion.Value * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).address

-        NewSumRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).address

-        .Calculate

-        .Range("IDX_CITY") = 0

-        cbCity.RowSource = NewCbxRange

-

-    End With

-    cbCity.ListIndex = 0

-End Sub

-

-<<<<<<
-======================
-mREGMAN
->>>>>>
-Attribute VB_Name = "mREGMAN"

-Option Explicit

-

-Sub hwnew()

-    Dim rs As Range

-    Dim re As Object

-    

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    HWReset

-    ReSet_REGMAN_Record

-    With Worksheets("RM_QTR")

-        .ClearRMName

-        .Range("REP_QTR_INPUT_DATA").ClearContents ' Это не ошибка, названия совпадают

-'        .Range("A1").Select

-    End With

-    Worksheets(TITLE_SHEET).Select

-    With Application

-        .DisplayAlerts = False

-        .ThisWorkbook.Save

-        .Quit

-    End With

-End Sub

-

-Function CheckUser() As Boolean

-    Dim objHW() As Long

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    

-    GetHWInfo objHW()

-    i = GetHWRecords(objHW_DB)

-    

-    If i = 0 Then ' First time

-        StoreHWInfo objHW()

-    End If

-    If CheckHWInfo(objHW()) <> True Then

-        CheckUser = False

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    Else

-        CheckUser = SetupUser

-    End If

-End Function

-

-Function SetupUser() As Boolean

-    Dim cREGMAN As tREGMAN

-    Dim idx As Integer

-    Dim dlg_ui As UserInfo

-    

-    Set dlg_ui = New UserInfo

-    

-    cREGMAN = Get_REGMAN_Record()

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_REGION") = cREGMAN.Region

-        .Range("IDX_CITY") = cREGMAN.City

-    End With

-        

-    With dlg_ui

-        .cbRegion = cREGMAN.Region

-        .cbCity = cREGMAN.City

-        .tbFName = cREGMAN.FirstName

-        .tbLName = cREGMAN.LastName

-    End With

-    

-    Worksheets(REGS_SHEET).Calculate

-    

-    Dim test_Ok As Boolean

-    test_Ok = False

-    

-    On Error GoTo l1

-    

-    Do

-        dlg_ui.Show

-        If dlg_ui.Tag = vbOK Then

-            test_Ok = dlg_ui.tbFName.Value <> "" And dlg_ui.tbLName <> ""

-            If test_Ok Then

-                Exit Do

-            Else

-                MsgBox "Введите имя и фамилию", vbOKOnly, PROGRAM_NAME

-            End If

-        Else

-            Exit Do

-        End If

-    Loop Until False

-l1:

-    If test_Ok Then

-        With cREGMAN

-            .Region = dlg_ui.cbRegion.Value

-            .City = dlg_ui.cbCity.Value

-            .FirstName = dlg_ui.tbFName.Value

-            .LastName = dlg_ui.tbLName.Value

-        End With

-        Set_REGMAN_Record cREGMAN

-    Else

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .ThisWorkbook.Saved = True

-            .Quit

-        End With

-    End If

-    SetupUser = test_Ok

-End Function

-

-Sub GetHWInfo(objHW() As Long)

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    i = 1

-    For Each d In dc

-        If d.drivetype = 2 Then ' 2 - HardDisk

-            ReDim Preserve objHW(i)

-            objHW(i) = d.SerialNumber

-            i = i + 1

-        End If

-    Next

-    SortHW objHW

-End Sub

-

-Sub StoreHWInfo(objHW() As Long)

-    UpdateHWRecords objHW

-End Sub

-

-Sub SortHW(objHW() As Long)

-    Dim r As Range

-    Dim rs As Range

-    Dim re As Object

-    Dim i As Integer

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    For i = 1 To UBound(objHW)

-        r = objHW(i)

-        Set r = r.Offset(1, 0)

-    Next i

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).Sort _

-            Key1:=.Range("HW_Number"), _

-            Order1:=xlDescending, _

-            Header:=xlGuess, _

-            OrderCustom:=1, _

-            MatchCase:=False, _

-            Orientation:=xlTopToBottom

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    i = 1

-    Do While r <> ""

-        objHW(i) = r

-        Set r = r.Offset(1, 0)

-        i = i + 1

-    Loop

-End Sub

-

-Function CheckHWInfo(objHW() As Long)

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    CheckHWInfo = False

-        

-    i = GetHWRecords(objHW_DB)

-    If i > 0 Then

-        SortHW objHW_DB

-    End If

-    If UBound(objHW) = UBound(objHW_DB) Then

-        For i = 1 To UBound(objHW)

-            If objHW(i) <> objHW_DB(i) Then

-                Exit Function

-            End If

-        Next i

-        CheckHWInfo = True

-    End If

-End Function

-

-

-<<<<<<
-======================
-dbBudget
->>>>>>
-Attribute VB_Name = "dbBudget"

-Option Explicit

-

-Public Type tBUDGET

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    bdgt_NMG As Long

-    bdgt_NFG As Long

-    sale_PLAN As Long

-End Type

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function GetAll_BDGT_RecordsByLPU_ID(ByRef allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_BDGT_RecordsByLPU_ID = dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection, allBDGT, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function Get_BDGT_Record(ByVal lpu_id As Long, ByVal ent_date As String) As tBUDGET

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    Get_BDGT_Record = dbGet_BDGT_Record(dbConnection, lpu_id, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objBDGT.ID <> 0 then updatre else insert

-Public Sub Insert_BDGT_Record(objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    If objBDGT.id <> 0 Then

-        dbUpdate_BDGT_Record dbConnection, objBDGT

-    Else

-        dbInsert_BDGT_Record dbConnection, objBDGT

-    End If

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Public Sub Delete_BDGT_Record(ByRef objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    dbDelete_BDGT_Record dbConnection, objBDGT

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_BDGT_Record(dbConnection As Object, ByVal lpu_id As Long, ent_date As String) As tBUDGET

-    

-    Dim sql As String

-    Dim objBDGT As tBUDGET

-    

-    With objBDGT

-        .id = 0

-        .lpu_id = lpu_id

-        .entry_date = ent_date

-        .bdgt_NMG = 0

-        .bdgt_NFG = 0

-        .sale_PLAN = 0

-    End With

-        

-    

-    sql = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        With objBDGT

-            .entry_date = dbRecordset("entry_date")

-            .id = dbRecordset("id")

-            .lpu_id = dbRecordset("lpu_id")

-            .bdgt_NFG = dbRecordset("bdgt_NFG")

-            .bdgt_NMG = dbRecordset("bdgt_NMG")

-            .sale_PLAN = dbRecordset("sale_PLAN")

-        End With

-    End If

-    

-    dbGet_BDGT_Record = objBDGT

-End Function

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection As Object, allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_BDGT_SQL As String

-    Dim getAll_BDGT_SQL As String

-    Dim BDGT_Count As Long

-    BDGT_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_BDGT_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        BDGT_Count = dbRecordset("BDGT_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_BDGT_RecordsbyLPU_ID = BDGT_Count

-    

-    If BDGT_Count > 0 Then

-        'we have records

-        ReDim allBDGT(1 To BDGT_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_BDGT_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpBDGT As tBUDGET

-                 With tmpBDGT

-                    .entry_date = dbRecordset("entry_date")

-                    .id = dbRecordset("id")

-                    .lpu_id = dbRecordset("lpu_id")

-                    .bdgt_NFG = dbRecordset("bdgt_NFG")

-                    .bdgt_NMG = dbRecordset("bdgt_NMG")

-                    .sale_PLAN = dbRecordset("sale_PLAN")

-                 End With

-                 

-                 allBDGT(index) = tmpBDGT

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbInsert_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "lpu_budget", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    dbRecordset("entry_date") = objBDGT.entry_date

-    dbRecordset("lpu_id") = objBDGT.lpu_id

-    dbRecordset("bdgt_NMG") = objBDGT.bdgt_NMG

-    dbRecordset("bdgt_NFG") = objBDGT.bdgt_NFG

-    dbRecordset("sale_PLAN") = objBDGT.sale_PLAN

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objBDGT.id = dbRecordset("id")

-  

-End Sub

-

-Public Sub dbUpdate_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu_budget SET " & _

-    "entry_date='" & objBDGT.entry_date & "'," & _

-    "lpu_id=" & objBDGT.lpu_id & "," & _

-    "bdgt_NMG=" & objBDGT.bdgt_NMG & "," & _

-    "bdgt_NFG=" & objBDGT.bdgt_NFG & "," & _

-    "sale_PLAN=" & objBDGT.sale_PLAN & _

-    " WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-Public Sub dbDelete_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_BDGT_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbDatabase
->>>>>>
-Attribute VB_Name = "dbDatabase"

-Option Explicit

-

-

-Sub dbOpenConnection(dbConnection As Object)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-<<<<<<
-======================
-dbLPU
->>>>>>
-Attribute VB_Name = "dbLPU"

-Option Explicit

-

-Public Type tLPU

-    id As Long

-    rep_id As Long

-    name As String

-    address As String

-    beds As Integer

-End Type

-

-Function Get_LPU_Record(ByVal lpu_id As Long) As tLPU

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_LPU_Record = dbGet_LPU_Record(dbConnection, lpu_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_LPU_byQTR(allLPU() As tLPU, ent_date As String, rep_id As Long) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_LPU_byQTR = dbGetAll_LPU_byQTR(dbConnection, allLPU, ent_date, rep_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_Record(dbConnection As Object, ByVal lpu_id As Long) As tLPU

-    

-    Dim sql As String

-    Dim objLPU As tLPU

-    

-    objLPU.id = lpu_id

-    objLPU.name = ""

-    objLPU.address = ""

-    

-    sql = "SELECT * FROM lpu WHERE id=" & lpu_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objLPU.name = dbRecordset("name")

-        objLPU.address = dbRecordset("address")

-        objLPU.rep_id = dbRecordset("rep_id")

-        objLPU.beds = dbRecordset("beds")

-    End If

-    

-    dbGet_LPU_Record = objLPU

-

-End Function

-

-Function dbGetAll_LPU_byQTR(dbConnection As Object, allLPU() As tLPU, ent_date As String, rep_id As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    Dim Where As String

-    Where = "WHERE lpu_budget.entry_date like '" & ent_date & "'" & " AND lpu.id=lpu_budget.lpu_id AND lpu.rep_id=" & rep_id

-

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu_budget, lpu " & Where

-    

-    getAll_LPU_SQL = "SELECT lpu.id as id, lpu.rep_id as rep_id, lpu.name as name, lpu.address as address, lpu.beds AS beds " & _

-    "FROM lpu, lpu_budget " & Where

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_LPU_byQTR = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-dbREP
->>>>>>
-Attribute VB_Name = "dbREP"

-'Option Explicit

-'

-'Public Type tREP

-'    FirstName As String

-'    LastName As String

-'    Region As Integer

-'    City As Integer

-'End Type

-'

-'Function GetREPRecord() As tREP

-'    Dim dbConnection As Object

-'

-'    dbOpenConnection dbConnection

-'    GetREPRecord = dbGetREPRecord(dbConnection)

-'    dbCloseConnection dbConnection

-'End Function

-'

-'Sub SetREPRecord(cUser As tREP)

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbSetREPRecord dbConnection, cUser

-'    dbCloseConnection dbConnection

-'End Sub

-'

-'Sub ReSetREPRecord()

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbReSetREPRecord dbConnection

-'    dbCloseConnection dbConnection

-'End Sub

-'

-'Public Function dbGetREPRecord(dbConnection As Object) As tREP

-'

-'    Dim SQL As String

-'    Dim objREP As tREP

-'

-'    objREP.FirstName = ""

-'    objREP.LastName = ""

-'    objREP.Region = 0

-'    objREP.City = 0

-'    SQL = "SELECT firstname, lastname, region, city FROM " & _

-'          "rep"

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open SQL, dbConnection

-'    ', 3, 3

-'    If Not dbRecordset.BOF Then

-'

-'        objREP.FirstName = dbRecordset("firstname")

-'        objREP.LastName = dbRecordset("lastname")

-'        objREP.Region = dbRecordset("region")

-'        objREP.City = dbRecordset("city")

-'

-'    End If

-'

-'    dbGetREPRecord = objREP

-'

-'End Function

-'

-'Public Sub dbSetREPRecord(dbConnection As Object, ByRef objREP As tREP)

-'

-'    Dim DeleteSQL As String

-'    Dim InsertSQL As String

-'

-'    DeleteSQL = "DELETE FROM rep"

-'    InsertSQL = "INSERT INTO rep (firstname, lastname, region, city) VALUES (" & _

-'    "'" & objREP.FirstName & "', " & _

-'    "'" & objREP.LastName & "', " & _

-'    objREP.Region & ", " & _

-'    objREP.City & ")"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-'

-'End Sub

-'

-'Public Sub dbReSetREPRecord(dbConnection As Object)

-'

-'    Dim DeleteSQL As String

-'

-'    DeleteSQL = "DELETE FROM rep"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-'

-'End Sub

-'

-

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    CheckWorkBooksArround Wb

-End Sub

-

-

-Sub CheckWorkBooksArround(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If app.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKOnly, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-        Exit Sub

-    End If

-

-End Sub

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub SaveExcelState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-        ActiveWorkbook.DisplayDrawingObjects = xlDisplayShapes

-        

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars(STDBAR_NAME).Visible = False

-End Sub

-

-

-Public Sub RestoreExcelState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars(STDBAR_NAME).Visible = True

-End Sub

-

-

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Public Const STDBAR_NAME = "Worksheet Menu Bar"

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Import"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmImport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Export"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 620

-                        .OnAction = "cmExport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Exit && Restore Excel"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 548

-                        .OnAction = "cmExitRestore"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-       End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(flag As Boolean)

-    If flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars(STDBAR_NAME)

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmImport()

-    Worksheets(RM_QTR_SHEET).Select

-    ImportData

-End Sub

-

-Sub cmExport()

-    dbExport

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    Dim dlg As dlgAbout

-    Set dlg = New dlgAbout

-    

-    dlg.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlg.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlg.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlg.Show

-End Sub

-

-Sub cmMail2Support()

-    Dim err_description As String

-    Dim dlg_msg As dlg_Mail

-    Set dlg_msg = New dlg_Mail

-    With dlg_msg

-        .Show

-        If .Tag = vbOK Then

-            ThisWorkbook.Worksheets(VAR_SHEET).Range("ERR_MESSAGE") _

-                = .tbMessage.Text

-            ThisWorkbook.Save

-            ThisWorkbook.SendMail Recipients:="infra@i-rs.ru", Subject:=PROGRAM_NAME & " ver.:" & PROGRAM_VERSION

-            MsgBox "Сообщение об ошибке отправлено. Перезагрузите программу.", vbOKOnly, PROGRAM_NAME

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-    End With

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-'        helppath = "hh.exe " & .Path & "\Telfast.chm"

-'        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub set_work_mode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetupEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-End Sub

-

-Sub cmSetStandaloneMode()

-    set_work_mode

-    ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    Dim dlg As dlgGetPwd

-    rp = common_pwd

-    

-    Set dlg = New dlgGetPwd

-    dlg.edPwd = ""

-    dlg.Show

-    

-    If dlg.edPwd = rp Then

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmHomePage()

-    ThisWorkbook.Worksheets("RM_QTR").Select

-End Sub

-

-Sub cmExitRestore()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = True

-    Application.Quit

-End Sub

-

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    Dim dlg_prn As dlgPrint

-    

-    Set dlg_prn = New dlgPrint

-    

-    With dlg_prn

-        .cbMainReport = True

-        .cbMainBudget = False

-        .cbSrcData = False

-        .cbAllSheets = False

-    

-        .Show

-    

-        If .Tag = vbCancel Then

-            Exit Sub

-        End If

-    End With

-    

-    Dim PrnIdx As Integer

-    

-    With dlg_prn

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("REP_QTR", "budget", "Final")

-    Case 1111

-        plist = Array("REP_QTR", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("REP_QTR")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Clexane bar"

-Public Const common_pwd As String = "crdjhxtyjr"

-

-

-Sub SetupEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    Wb.Worksheets(TITLE_SHEET).Select

-    With Application

-        .Caption = PROGRAM_NAME & " " & PROGRAM_VERSION

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .SaveExcelState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = False

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Wb.Worksheets(TITLE_SHEET).Select

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    If cWindow.Type = xlWorkbook Then

-                        cWindow.DisplayHeadings = True

-                    End If

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu True

-        End If

-        With mobjAppState

-            .RestoreExcelState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Worksheets(TITLE_SHEET).Select

-'        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Option Explicit

-

-Sub UpdateHWRecords(objHW() As Long)

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    dbUpdateHWRecords dbConnection, objHW

-    dbCloseConnection dbConnection

-End Sub

-

-Function GetHWRecords(objHW() As Long) As Integer

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    GetHWRecords = dbGetHWRecords(dbConnection, objHW)

-    dbCloseConnection dbConnection

-End Function

-

-Sub HWReset()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbInsertHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    

-    Dim dbRecordset As Object

-    Dim i As Long

-    

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "hw", dbConnection, 2, 2

-    

-    For i = 1 To UBound(objHW)

-        dbRecordset.addnew

-        dbRecordset("num") = objHW(i)

-        dbRecordset.Update

-    Next i

-    

-End Sub

-

-Sub dbUpdateHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    dbDeleteHWRecord dbConnection

-    dbInsertHWRecords dbConnection, objHW

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-dbHir
->>>>>>
-Attribute VB_Name = "dbHir"

-Option Explicit

-

-Public Type tHIRURGIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    operations_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_ambulator_clexan_40mg As Integer

-    patients_ambulator_clexan_20mg As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-    patients_stationar_clexan_40mg As Integer

-    patients_stationar_clexan_20mg As Integer

-End Type

-

-' if objHir.ID <> 0 then updatre else insert

-Sub Insert_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objHir.id <> 0 Then

-        dbUpdate_Hir_Record dbConnection, objHir

-    Else

-        dbInsert_Hir_Record dbConnection, objHir

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Hir_RecordsByLPU_ID(ByRef allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Hir_RecordsByLPU_ID = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, allHir, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Hir_Record dbConnection, objHir

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objHir.ID <> 0 then updatre else insert

-

-Sub dbInsert_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_hir", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objHir

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("operations_per_quarter") = .operations_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_ambulator_clexan_20mg") = .patients_ambulator_clexan_20mg

-        dbRecordset("patients_ambulator_clexan_40mg") = .patients_ambulator_clexan_40mg

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-        dbRecordset("patients_stationar_clexan_20mg") = .patients_stationar_clexan_20mg

-        dbRecordset("patients_stationar_clexan_40mg") = .patients_stationar_clexan_40mg

-        

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objHir.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim UpdateSQL As String

-    

-    With objHir

-        UpdateSQL = "UPDATE lpu_hir SET " & _

-            "entry_date='" & objHir.entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "operations_per_quarter=" & .operations_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_ambulator_clexan_20mg=" & .patients_ambulator_clexan_20mg & "," & _

-            "patients_ambulator_clexan_40mg=" & .patients_ambulator_clexan_40mg & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & "," & _

-            "patients_stationar_clexan_20mg=" & .patients_stationar_clexan_20mg & "," & _

-            "patients_stationar_clexan_40mg=" & .patients_stationar_clexan_40mg & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_Hir_RecordsbyLPU_ID(dbConnection As Object, allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Hir_SQL As String

-    Dim getAll_Hir_SQL As String

-    Dim Hir_Count As Long

-    Hir_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Hir_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Hir_Count = dbRecordset("HIR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Hir_RecordsbyLPU_ID = Hir_Count

-    

-    If Hir_Count > 0 Then

-        'we have records

-        ReDim allHir(1 To Hir_Count)

-        Dim index As Integer

-        index = 1

-        dbRecordset.Open getAll_Hir_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpHir As tHIRURGIA

-                 With tmpHir

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .operations_per_quarter = dbRecordset("operations_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_ambulator_clexan_20mg = dbRecordset("patients_ambulator_clexan_20mg")

-                    .patients_ambulator_clexan_40mg = dbRecordset("patients_ambulator_clexan_40mg")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                    .patients_stationar_clexan_20mg = dbRecordset("patients_stationar_clexan_20mg")

-                    .patients_stationar_clexan_40mg = dbRecordset("patients_stationar_clexan_40mg")

-                 End With

-                 

-                 allHir(index) = tmpHir

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE ID=" & objHir.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Hir_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbTer
->>>>>>
-Attribute VB_Name = "dbTer"

-Option Explicit

-

-Public Type tTERAPIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objTer.ID <> 0 then updatre else insert

-Sub Insert_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objTer.id <> 0 Then

-        dbUpdate_Ter_Record dbConnection, objTer

-    Else

-        dbInsert_Ter_Record dbConnection, objTer

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Ter_RecordsByLPU_ID(ByRef allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Ter_RecordsByLPU_ID = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, allTer, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Ter_Record dbConnection, objTer

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objTer.ID <> 0 then updatre else insert

-

-Sub dbInsert_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_ter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objTer

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objTer.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim Update_SQL As String

-    

-    With objTer

-        Update_SQL = "UPDATE lpu_ter SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_Ter_RecordsbyLPU_ID(dbConnection As Object, allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Ter_SQL As String

-    Dim getAll_Ter_SQL As String

-    Dim Ter_Count As Long

-    Ter_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Ter_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Ter_Count = dbRecordset("TER_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Ter_RecordsbyLPU_ID = Ter_Count

-    

-    If Ter_Count > 0 Then

-        'we have records

-        ReDim allTer(1 To Ter_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_Ter_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpTer As tTERAPIA

-                 With tmpTer

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 allTer(index) = tmpTer

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE ID=" & objTer.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Ter_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-mLPU_LIST
->>>>>>
-Attribute VB_Name = "mLPU_LIST"

-Option Explicit

-

-Public Const CINP_AREA As String = "B12"

-Public Const CLPU_NAME As Integer = 0

-Public Const CLPU_NAME1 As Integer = 1

-Public Const CLPU_NAME2 As Integer = 2

-Public Const CLPU_ID As Integer = 3

-Public Const CLPU_BEDS As Integer = 4

-Public Const CLPU_NFG As Integer = 5

-Public Const CLPU_NMG As Integer = 6

-Public Const CLPU_HIR As Integer = 7

-Public Const CLPU_TER As Integer = 8

-Public Const CLPU_CAR As Integer = 9

-Public Const CLPU_FACT As Integer = 10

-Public Const CLPU_PLAN As Integer = 11

-Public Const CLPU_PAT_LPU As Integer = 16

-Public Const CLPU_BDGT As Integer = 17

-Public Const CLPU_PAT_ALL As Integer = 16

-

-

-

-Sub EditLPU(cLPU As tLPU, ent_date As String)

-    NoFunc

-End Sub

-

-Sub Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-

-End Sub

-

-Sub Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btLPU_DEL_IT()

-    Dim cLPU As tLPU

-    Dim ent_date As String

-    Dim delete_all As Integer

-    Dim dlg_del As dlg_LPU_delete

-

-    With Worksheets("LPU_LIST")

-        ent_date = .Range("ent_date")

-        cLPU.id = .getCurrentLPU_ID()

-    End With

-

-    If cLPU.id = 0 Then

-        MsgBox "Укажите удаляемый объект", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    cLPU = Get_LPU_Record(cLPU.id)

-

-    Set dlg_del = New dlg_LPU_delete

-    With dlg_del

-        .chbDeleteQTR.Value = True

-        .chbDeleteAll.Value = False

-        .lComment = ent_date & ": Удаление ЛПУ '" _

-        & cLPU.name & "', расположенного по адресу:" _

-        & cLPU.address & " не разрешено."

-        .Show

-    End With

-End Sub

-

-Sub btLPU_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        

-        Wks_select .Range("ret_addr")

-    End With

-

-End Sub

-

-

-Sub btLPU_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim lpu_id As Long

-

-    i = Worksheets(VAR_SHEET).Range("QTR_ACTION").Value

-    With Worksheets("LPU_LIST")

-        ent_date = .getEnt_date()

-

-

-        lpu_id = .getCurrentLPU_ID

-        If lpu_id = 0 And i <> 6 Then

-            i = 1

-        End If

-        Select Case i

-            Case 1

-                .SelectLPU_NAME lpu_id, ent_date

-                .Range("JUMP") = ""

-            Case 2

-                .SelectLPU_BDGT lpu_id, ent_date

-                .Range("JUMP") = "LPU_BDGT"

-            Case 3

-                .SelectLPU_HIR lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_HIR"

-

-            Case 4

-                .SelectLPU_TER lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_TER"

-

-            Case 5

-                .SelectLPU_C_ACS lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        End Select

-    End With

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-dbQTR
->>>>>>
-Attribute VB_Name = "dbQTR"

-Option Explicit

-

-Public Type tQTR

-    id As Long

-    entry_date As String

-    rep_id As Long

-    sale_PLAN As Long

-    ClxnH20mg As Long

-    ClxnH40mg As Long

-    ClxnT40mg As Long

-    ClxnC_IM As Long

-    ClxnC_ACS As Long

-End Type

-

-Function Get_QTR_Record(ByVal QTR_ID As Long) As tQTR

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_QTR_Record = dbGet_QTR_Record(dbConnection, QTR_ID)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_Record(dbConnection As Object, ByVal QTR_ID As Long) As tQTR

-    

-    Dim sql As String

-    Dim objQTR As tQTR

-    

-    With objQTR

-        .ClxnC_ACS = 0

-        .ClxnC_IM = 0

-        .ClxnH20mg = 0

-        .ClxnH40mg = 0

-        .ClxnT40mg = 0

-        .entry_date = ""

-        .id = QTR_ID

-    End With

-    

-    sql = "SELECT * FROM quarter WHERE id=" & QTR_ID

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objQTR.entry_date = dbRecordset("entry_date")

-        objQTR.rep_id = dbRecordset("rep_id")

-        objQTR.sale_PLAN = dbRecordset("sale_plan")

-        objQTR.ClxnH20mg = dbRecordset("ClxnH20mg")

-        objQTR.ClxnH40mg = dbRecordset("ClxnH40mg")

-        objQTR.ClxnT40mg = dbRecordset("ClxnT40mg")

-        objQTR.ClxnC_IM = dbRecordset("ClxnC_IM")

-        objQTR.ClxnC_ACS = dbRecordset("ClxnC_ACS")

-        objQTR.id = dbRecordset("id")

-    End If

-    

-    dbGet_QTR_Record = objQTR

-

-End Function

-

-

-Function Get_QTR_Record_by_REP(ent_date As String, rep_id As Long) As tQTR

-    Dim dbConnection As Object

-    Dim allQTR() As tQTR

-    Dim i As Long

-

-    dbOpenConnection dbConnection

-

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id)

-    If i <> 0 Then

-        Get_QTR_Record_by_REP = allQTR(1)

-    End If

-

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTR_Records_by_REP(ByRef all_QTR() As tQTR, ent_date As String, rep_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-

-    GetAll_QTR_Records_by_REP = dbGetAll_QTR_Records_By_REP(dbConnection, all_QTR, ent_date, rep_id)

-

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGetAll_QTR_Records_By_REP(dbConnection As Object, all_QTR() As tQTR, ent_date As String, rep_id As Long) As Integer

-

-    Dim getCount_QTR_SQL As String

-    Dim getAll_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter " & _

-    "WHERE entry_date like '" & ent_date & "' AND rep_id=" & rep_id

-    getAll_QTR_SQL = "SELECT * FROM quarter " & _

-    "WHERE entry_date like '" & ent_date & "' AND rep_id=" & rep_id & " ORDER BY entry_date"

-

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-

-    dbRecordset.Close

-

-    dbGetAll_QTR_Records_By_REP = QTR_Count

-

-    If QTR_Count > 0 Then

-        'we have records

-        ReDim all_QTR(1 To QTR_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTR_SQL, dbConnection

-

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTR As tQTR

-                 With tmp_QTR

-                    .entry_date = dbRecordset("entry_date")

-                    .rep_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .ClxnH20mg = dbRecordset("ClxnH20mg")

-                    .ClxnH40mg = dbRecordset("ClxnH40mg")

-                    .ClxnT40mg = dbRecordset("ClxnT40mg")

-                    .ClxnC_IM = dbRecordset("ClxnC_IM")

-                    .ClxnC_ACS = dbRecordset("ClxnC_ACS")

-                    .id = dbRecordset("id")

-                 End With

-

-                 all_QTR(index) = tmp_QTR

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-cdbQTR
->>>>>>
-Attribute VB_Name = "cdbQTR"

-Option Explicit

-

-Public Type tQTR_COMMON

-    qtr As tQTR

-    i_lcd As Long           ' число ЛПУ в СПИСКЕ

-    lcd() As tLPU_COMMON    ' список ЛПУ

-    c_beds As Long          ' сумма коек

-    c_bdgt_NFG As Long      ' общий бюджет на НФГ

-    c_bdgt_NMG As Long      ' общий бюджет на НМГ

-    c_bdgt_LPU As Long      ' общий бюджет на гепарины

-    c_sale_PLAN As Long     ' план продаж репа

-    c_sale_ALL As Long      ' продажи

-    c_sale_HIR As Long      ' в хирургии

-    c_sale_TER  As Long     ' в терапии

-    c_sale_CRD  As Long     ' в кардиологии

-    c_pat_HIR   As Long     ' пациенты

-    c_pat_TER   As Long     '

-    c_pat_CRD   As Long     '

-    c_pat_ALL   As Long     '

-    c_pat_LPU   As Long     ' Всего операций

-End Type

-

-Function GetLastQTR_fromDB() As String

-    Dim dbConnection As Object

-    Dim getCount_QTR_SQL As String

-    Dim getLast_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter"

-    getLast_QTR_SQL = "SELECT MAX(entry_date) as ent_date FROM quarter"

-    

-    dbOpenConnection dbConnection

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    If QTR_Count > 0 Then

-        'we have records

-        dbRecordset.Open getLast_QTR_SQL, dbConnection

-        getLast_QTR_SQL = dbRecordset("ent_date")

-    End If

-    GetLastQTR_fromDB = getLast_QTR_SQL

-    dbCloseConnection dbConnection

-End Function

-

-Function Get_QTR_CommonList_by_REP(ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_QTR_CommonList_by_REP = dbGet_QTR_CommonList_by_REP(dbConnection, qcd, ent_date, rep_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_CommonList_by_REP(dbConnection As Object, ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim allQTR() As tQTR

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id)

-    dbGet_QTR_CommonList_by_REP = i

-    If i > 0 Then

-        ReDim qcd(i)

-        For i = 1 To UBound(allQTR)

-            With qcd(i)

-                .qtr = allQTR(i)

-                .c_beds = 0

-                .c_bdgt_NFG = 0

-                .c_bdgt_NMG = 0

-                .c_bdgt_LPU = 0

-                .c_sale_PLAN = 0

-                .c_pat_HIR = 0

-                .c_pat_TER = 0

-                .c_pat_CRD = 0

-                .c_pat_ALL = 0

-                .c_sale_HIR = 0

-                .c_sale_TER = 0

-                .c_sale_CRD = 0

-                .c_sale_ALL = 0

-                .c_pat_LPU = 0

-                

-                j = dbGet_LPU_CommonQTR(dbConnection, .lcd, .qtr)

-                .i_lcd = j

-                If j > 0 Then

-                    For j = 1 To UBound(.lcd)

-                        .c_beds = .c_beds + .lcd(j).lpu.beds

-                        .c_bdgt_NFG = .c_bdgt_NFG + .lcd(j).bdgt.bdgt_NFG

-                        .c_bdgt_NMG = .c_bdgt_NMG + .lcd(j).bdgt.bdgt_NMG

-                        .c_bdgt_LPU = .c_bdgt_LPU + .lcd(j).bdgt_LPU

-                        .c_sale_PLAN = .c_sale_PLAN + .lcd(j).bdgt.sale_PLAN

-                        .c_pat_HIR = .c_pat_HIR + .lcd(j).pat_HIR

-                        .c_pat_TER = .c_pat_TER + .lcd(j).pat_TER

-                        .c_pat_CRD = .c_pat_CRD + .lcd(j).pat_CRD

-                        .c_pat_ALL = .c_pat_ALL + .lcd(j).pat_ALL

-                        .c_sale_HIR = .c_sale_HIR + .lcd(j).sale_HIR

-                        .c_sale_TER = .c_sale_TER + .lcd(j).sale_TER

-                        .c_sale_CRD = .c_sale_CRD + .lcd(j).sale_CRD

-                        .c_sale_ALL = .c_sale_ALL + .lcd(j).sale_ALL

-                        .c_pat_LPU = .c_pat_LPU + .lcd(j).pat_LPU

-                    Next j

-                    

-                End If

-            End With

-        Next i

-    End If

-End Function

-

-Function GetLastQtr() As String

-    Dim s As String

-    Dim r As Range

-    Set r = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Do While r.Cells(1, 1) <> ""

-        s = r.Cells(1, 1)

-        Set r = r.Cells.Offset(1, 0)

-    Loop

-    GetLastQtr = s

-End Function

-

-Function GetNextQTR(ent_date As String) As String

-    Dim rd As Range

-    Dim idx As Integer

-    Dim b As Variant

-    Dim dlg As dlg_newQTR

-    Set dlg = New dlg_newQTR

-    

-    If ent_date = "" Then

-        Dim ir As Variant

-        idx = 0

-        dlg.Show

-        b = dlg.Tag

-            

-        If IsNumeric(b) Then

-            GetNextQTR = dlg.cbQTR

-        Else

-            GetNextQTR = ""

-        End If

-    Else

-        Set rd = Worksheets(VAR_SHEET).Range("Date_Lst")

-        idx = WorksheetFunction.Match(ent_date, rd, 0)

-        GetNextQTR = WorksheetFunction.index(rd, idx + 1, 1)

-    End If

-End Function

-<<<<<<
-======================
-mRestView
->>>>>>
-Attribute VB_Name = "mRestView"

-Option Explicit

-

-Sub xlRestoreView()

-Attribute xlRestoreView.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute xlRestoreView.VB_ProcData.VB_Invoke_Func = " \n14"

-    With Application

-        .CommandBars("Standard").Visible = True

-        .CommandBars("Formatting").Visible = True

-        .DisplayFormulaBar = True

-        .DisplayStatusBar = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = True

-    End With

-End Sub

-<<<<<<
-======================
-dlg_newQTR
->>>>>>
-Attribute VB_Name = "dlg_newQTR"

-Attribute VB_Base = "0{3EA3C15A-5493-445F-9858-2F241E7D6CEA}{849C1FE1-631A-485D-BE54-A7B73124582C}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mDec2TS
->>>>>>
-Attribute VB_Name = "mDec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-CHRT_LPU_BBL
->>>>>>
-Attribute VB_Name = "CHRT_LPU_BBL"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Unprotect

-    Range("view_key") = True

-    On Error Resume Next

-    ChangeLabels

-    Range("A1").Select

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Unprotect

-    Dim s As String

-    s = Range("ret_addr")

-    Protect UserInterfaceOnly:=True

-    Wks_select (s)

-End Sub

-

-Sub BCLabelChng_Click()

-    Unprotect

-    If Range("view_key") Then

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать названия"

-    Else

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать объемы"

-    End If

-    Range("view_key") = Not Range("view_key")

-    ChangeLabels

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub ChangeLabels()

-    Dim i As Integer

-    Dim offset_text As Integer

-    Dim src As Range

-    Set src = Range("CHRT_BBL_DATA")

-    

-    offset_text = 3

-    If Range("view_key") Then

-        offset_text = 4

-    End If

-    

-    With ChartObjects(1).Chart

-        With .SeriesCollection(1)

-            For i = 1 To .Points.count

-                On Error GoTo ExitLabel

-                .Points(i).DataLabel.Characters.Text = Format(src.Cells(i, offset_text))

-            Next i

-        End With

-    End With

-ExitLabel:

-End Sub

-

-<<<<<<
-======================
-CHRT_PAT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PAT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-<<<<<<
-======================
-CHRT_PAT_LPU
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_nextQTR
->>>>>>
-Attribute VB_Name = "dlg_nextQTR"

-Attribute VB_Base = "0{B85FF7F1-50C0-4433-BC6F-8A0F2C9BDDDA}{EC2D2B9E-9ED2-4005-A1E9-EF0626D3B7E7}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-cdbLPU
->>>>>>
-Attribute VB_Name = "cdbLPU"

-Option Explicit

-

-Public Type tLPU_COMMON

-    lpu As tLPU

-    bdgt As tBUDGET

-    i_hir As Long

-    hir() As tHIRURGIA

-    i_ter As Long

-    ter() As tTERAPIA

-    i_ACS As Long

-    ACS() As tACS

-    bdgt_LPU As Long

-    sale_HIR As Long

-    sale_TER As Long

-    sale_CRD As Long

-    sale_ALL As Long

-    pat_HIR As Long

-    pat_TER As Long

-    pat_CRD As Long

-    pat_ALL As Long     ' Сумма всех пациентов на клексане

-    pat_LPU As Long     ' Число потенциальных пациентов для продаж клексана

-End Type

-

-Function Get_LPU_CommonQTR(ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    Get_LPU_CommonQTR = dbGet_LPU_CommonQTR(dbConnection, lcd, objQTR)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_CommonQTR(dbConnection As Object, ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    i = dbGetAll_LPU_byQTR(dbConnection, allLPU, objQTR.entry_date, objQTR.rep_id)

-    dbGet_LPU_CommonQTR = i

-    If i > 0 Then

-        ReDim lcd(i)

-        For i = 1 To UBound(allLPU)

-            dbGet_LPU_Common dbConnection, lcd(i), allLPU(i), objQTR

-        Next i

-    End If

-End Function

-

-Sub Get_LPU_Common(ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    dbGet_LPU_Common dbConnection, lcd, cLPU, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbGet_LPU_Common(dbConnection As Object, ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-

-    lcd.lpu = cLPU

-    lcd.bdgt = dbGet_BDGT_Record(dbConnection, cLPU.id, objQTR.entry_date)

-    lcd.i_hir = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, lcd.hir, cLPU.id, objQTR.entry_date)

-    lcd.i_ter = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, lcd.ter, cLPU.id, objQTR.entry_date)

-    lcd.i_ACS = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, lcd.ACS, cLPU.id, objQTR.entry_date)

-    With lcd

-        .bdgt_LPU = .bdgt.bdgt_NFG + .bdgt.bdgt_NMG

-        .pat_LPU = 0

-        If .i_hir > 0 Then

-            .pat_HIR = .hir(1).patients_ambulator_clexan + .hir(1).patients_stationar_clexan

-            .sale_HIR = objQTR.ClxnH20mg * (.hir(1).patients_ambulator_clexan_20mg + .hir(1).patients_stationar_clexan_20mg)

-            .sale_HIR = .sale_HIR + objQTR.ClxnH40mg * (.hir(1).patients_ambulator_clexan_40mg + .hir(1).patients_stationar_clexan_40mg)

-            .pat_LPU = .pat_LPU + .hir(1).operations_per_quarter

-        End If

-        If .i_ter > 0 Then

-            .pat_TER = .ter(1).patients_ambulator_clexan + .ter(1).patients_stationar_clexan

-            .sale_TER = .pat_TER * objQTR.ClxnT40mg

-            .pat_LPU = .pat_LPU + .ter(1).patients_per_quarter

-        End If

-        If .i_ACS > 0 Then

-            .pat_CRD = .ACS(1).patients_stationar_clexan

-            .sale_CRD = .pat_CRD * objQTR.ClxnC_ACS

-            .pat_LPU = .pat_LPU + .ACS(1).patients_per_quarter

-        End If

-        .pat_ALL = .pat_HIR + .pat_TER + .pat_CRD

-        .sale_ALL = .sale_HIR + .sale_TER + .sale_CRD

-    End With

-End Sub

-

-<<<<<<
-======================
-CHRT_PIE
->>>>>>
-Attribute VB_Name = "CHRT_PIE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    

-    Unprotect

-    

-    On Error Resume Next

-    

-    Range("P5:Q24").Sort _

-        Key1:=Range("Q5"), _

-        Order1:=xlDescending, _

-        Header:=xlGuess, _

-        OrderCustom:=1, _

-        MatchCase:=False, _

-        Orientation:=xlTopToBottom

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PLN_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PLN_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_BDGT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_BDGT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_LPU_delete
->>>>>>
-Attribute VB_Name = "dlg_LPU_delete"

-Attribute VB_Base = "0{EC96F2D1-337D-47DF-B0F1-A6DF3F8CD5CC}{7EB42A63-CBFC-45B0-AE4D-C3E3D8FE7420}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlg_Mail
->>>>>>
-Attribute VB_Name = "dlg_Mail"

-Attribute VB_Base = "0{7B669454-C2AA-4FDF-8311-7ADEDDEF3FF3}{D07A0A02-4923-46C8-8EE8-62769243087D}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dbREP_id
->>>>>>
-Attribute VB_Name = "dbREP_id"

-Public Type tREPID

-    rep_id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function GetAll_REPID_Records_by_QTR(ByRef all_REPID() As tREPID, ent_date As String) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_REPID_Records_by_QTR = dbGetAll_REPID_Records_by_QTR(dbConnection, all_REPID, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-Function Get_REPID_Record(id As Long) As tREPID

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REPID_Record = dbGet_REPID_Record(dbConnection, id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_REPID_Records(ByRef all_REPID() As tREPID) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_REPID_Records = dbGetAll_REPID_Records(dbConnection, all_REPID)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function dbGet_REPID_Record(dbConnection As Object, id As Long) As tREPID

-    

-    Dim sql As String

-    Dim objREPID As tREPID

-    

-    objREPID.FirstName = ""

-    objREPID.LastName = ""

-    objREPID.Region = 0

-    objREPID.City = 0

-    sql = "SELECT rep_id, firstname, lastname, region, city FROM " & _

-          "rep WHERE rep_id=" & id

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREPID.rep_id = dbRecordset("rep_id")

-        objREPID.FirstName = dbRecordset("firstname")

-        objREPID.LastName = dbRecordset("lastname")

-        objREPID.Region = dbRecordset("region")

-        objREPID.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REPID_Record = objREPID

-        

-End Function

-

-Function dbGetAll_REPID_Records_by_QTR(dbConnection As Object, ByRef all_REPID() As tREPID, ent_date As String) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    Dim Where As String

-    

-    REPID_Count = 0

-    Where = " WHERE lpu_budget.entry_date like '" & ent_date & "' " & _

-        "AND rep.rep_id=lpu.rep_id AND lpu.id=lpu_budget.lpu_id"

-    

-    

-    getAll_REPID_SQL = "SELECT distinct rep.* FROM rep, lpu, lpu_budget" & Where

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM (" & getAll_REPID_SQL & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records_by_QTR = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Function dbGetAll_REPID_Records(dbConnection As Object, ByRef all_REPID() As tREPID) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    REPID_Count = 0

-    

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM rep"

-    getAll_REPID_SQL = "SELECT * FROM rep"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-cdbExport
->>>>>>
-Attribute VB_Name = "cdbExport"

-Option Explicit

-

-Function GetDBSN() As String

-    Dim n As Long

-    Randomize Timer

-    n = Int((100000000 - 1000000 + 1) * Rnd + 1000000)

-    GetDBSN = Dec2ThirtySix(n)

-End Function

-

-Sub dbExport()

-    Dim src_file As String

-    Dim dst_file As String

-    

-    On Error GoTo ErrHandler

-    

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & GetLastQTR_fromDB & "_" & GetDBSN() & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Данные экспортированы в файл:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для передачи", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-Exit Sub

-

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-<<<<<<
-======================
-mRegs
->>>>>>
-Attribute VB_Name = "mRegs"

-Option Explicit

-

-Function GetRegionName(idx As Integer) As String

-    GetRegionName = Worksheets(REGS_SHEET).Range("LST_REGIONS").Cells(idx + 1, 1).Text

-End Function

-

-Function GetCityName(idx_reg As Integer, idx_city As Integer) As String

-    GetCityName = Worksheets(REGS_SHEET).Range("CITY_TABLES").Offset(idx_city + 1, idx_reg * 2).Text

-End Function

-

-Sub testReg()

-    Dim r As Integer

-    Dim c As Integer

-    Dim s As String

-    

-    r = 3

-    c = 3

-    s = GetRegionName(r)

-    s = s & ", " & GetCityName(r, c)

-    MsgBox s

-End Sub

-

-<<<<<<
-======================
-RM_QTR
->>>>>>
-Attribute VB_Name = "RM_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CRGN_QT As Integer = 0

-Const CRGN_PLN As Integer = 2

-Const CRGN_FCT As Integer = 3

-Const CRGN_BDG As Integer = 4

-Const CRGN_LPU As Integer = 5

-Const CRGN_REP As Integer = 6

-Const CRGN_HIR As Integer = 7

-Const CRGN_TER As Integer = 8

-Const CRGN_CRD As Integer = 9

-Const CRGN_CLXN_BDG As Integer = 10

-Const CRGN_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub ClearRMName()

-    Unprotect

-    Range("D4") = ""

-    Range("D5") = ""

-    Range("H4") = ""

-End Sub

-

-Sub update_history()

-    Dim objRGN() As tREGION

-    Dim i As Long

-    Dim r As Range

-    Dim cRMan As tREGMAN

-

-    cRMan = Get_REGMAN_Record

-    

-    Range("D4") = cRMan.LastName

-    Range("D5") = cRMan.FirstName

-

-    Range("H4") = GetRegionName(cRMan.Region)

-    

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetRGN_COMM_DATA(objRGN)

-    

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objRGN)

-            r.Offset(i - 1, CRGN_QT) = objRGN(i).ent_date

-            r.Offset(i - 1, CRGN_FCT) = objRGN(i).total_SALE

-            r.Offset(i - 1, CRGN_PLN) = objRGN(i).sale_PLAN

-            r.Offset(i - 1, CRGN_BDG) = objRGN(i).total_BDGT

-            r.Offset(i - 1, CRGN_LPU) = objRGN(i).total_LPU

-            r.Offset(i - 1, CRGN_REP) = objRGN(i).total_REP

-            r.Offset(i - 1, CRGN_HIR) = objRGN(i).total_HIR

-            r.Offset(i - 1, CRGN_TER) = objRGN(i).total_TER

-            r.Offset(i - 1, CRGN_CRD) = objRGN(i).total_ACS

-            If objRGN(i).total_BDGT <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_BDG) = objRGN(i).total_SALE / objRGN(i).total_BDGT

-            End If

-            If objRGN(i).total_BDGT_NMG <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_NMG) = objRGN(i).total_SALE / objRGN(i).total_BDGT_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRGN_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRM_QtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR_RM

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR_RM

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR_RM

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = RM_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect UserInterfaceOnly:=True

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CRGN_QT + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    If r = "" Then

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = currRange.address

-        With Worksheets("REP_LIST")

-            .Range("ret_addr") = "RM_QTR"

-            .Range("ent_date") = r

-            .Range("VIEW_ONLY") = True

-        End With

-    End If

-    Cancel = True

-    btRM_QTR_Do_IT

-End Sub

-

-<<<<<<
-======================
-dbREG_MAN
->>>>>>
-Attribute VB_Name = "dbREG_MAN"

-Option Explicit

-

-Public Type tREGMAN

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function Get_REGMAN_Record() As tREGMAN

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REGMAN_Record = dbGet_REGMAN_Record(dbConnection)

-    dbCloseConnection dbConnection

-End Function

-

-Sub Set_REGMAN_Record(cREGMAN As tREGMAN)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbSet_REGMAN_Record dbConnection, cREGMAN

-    dbCloseConnection dbConnection

-End Sub

-

-Sub ReSet_REGMAN_Record()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbReSet_REGMAN_Record dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_REGMAN_Record(dbConnection As Object) As tREGMAN

-    

-    Dim sql As String

-    Dim objREGMAN As tREGMAN

-    

-    objREGMAN.FirstName = ""

-    objREGMAN.LastName = ""

-    objREGMAN.Region = 0

-    objREGMAN.City = 0

-    sql = "SELECT firstname, lastname, region, city FROM " & _

-          "reg_man"

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREGMAN.FirstName = dbRecordset("firstname")

-        objREGMAN.LastName = dbRecordset("lastname")

-        objREGMAN.Region = dbRecordset("region")

-        objREGMAN.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REGMAN_Record = objREGMAN

-        

-End Function

-

-Public Sub dbSet_REGMAN_Record(dbConnection As Object, ByRef objREGMAN As tREGMAN)

-  

-    Dim DeleteSQL As String

-    Dim InsertSQL As String

-    

-    DeleteSQL = "DELETE FROM reg_man"

-    InsertSQL = "INSERT INTO reg_man (firstname, lastname, region, city) VALUES (" & _

-    "'" & objREGMAN.FirstName & "', " & _

-    "'" & objREGMAN.LastName & "', " & _

-    objREGMAN.Region & ", " & _

-    objREGMAN.City & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    dbRecordset.Open InsertSQL, dbConnection

-       

-End Sub

-

-Public Sub dbReSet_REGMAN_Record(dbConnection As Object)

-  

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM reg_man"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    

-End Sub

-

-

-<<<<<<
-======================
-dbDatabaseMerge
->>>>>>
-Attribute VB_Name = "dbDatabaseMerge"

-Option Explicit

-

-Public Type tDBFIELD

-    name As String

-End Type

-

-Public Type tDBTABLE

-    name As String

-    field() As tDBFIELD

-End Type

-

-

-Function dbGetConnection(dbAccessFileFullPath As String) As Object

-    Dim dbConnection As Object

-    Dim dbAccessFilePasswd As String

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFileFullPath & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    Set dbGetConnection = dbConnection

-End Function

-

-Sub dbCloseOpenedConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteOpenedSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-Function dbMergeREP(from_dbConnection As Object, to_dbConnection As Object) As Long

-

-    Dim getRecordset As Object

-    Dim getREPData_SQL As String

-    Dim REP_fn As String

-    Dim REP_ln As String

-    Dim REP_region As String

-    Dim REP_city As String

-

-

-    getREPData_SQL = "SELECT * FROM rep"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getREPData_SQL, from_dbConnection

-        

-        If Not getRecordset.BOF Then

-            REP_fn = getRecordset("firstname")

-            REP_ln = getRecordset("lastname")

-            REP_city = getRecordset("city")

-            REP_region = getRecordset("region")

-        Else

-            MsgBox "There is no information about rep! This database cannot be merged!!!"

-            dbMergeREP = -1

-            Exit Function

-        End If

-    

-    Dim insertRecordset As Object

-    Set insertRecordset = CreateObject("ADODB.Recordset")

-        

-    insertRecordset.Open "rep", to_dbConnection, 2, 2

-    insertRecordset.addnew

-        

-    insertRecordset("firstname") = REP_fn

-    insertRecordset("lastname") = REP_ln

-    insertRecordset("region") = REP_region

-    insertRecordset("city") = REP_city

-    insertRecordset.Update

-    insertRecordset.MoveLast

-    'new ID

-    

-    dbMergeREP = insertRecordset("rep_id")

-    

-End Function

-

-Sub dbMergeLPU(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getLPU_SQL As String

-    Dim getRecordset As Object

-    Dim idx As Long

-    idx = 1

-    

-    getLPU_SQL = "SELECT * FROM lpu"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getLPU_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            ReDim Preserve objLPU(1 To idx)

-            objLPU(idx).old_lpu_id = getRecordset("id")

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "lpu", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("name") = getRecordset("name")

-            insRS("address") = getRecordset("address")

-            insRS("beds") = getRecordset("beds")

-            insRS.Update

-            insRS.MoveLast

-            'new ID

-            

-            objLPU(idx).new_lpu_id = insRS("id")

-                        

-            idx = idx + 1

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about LPU! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-

-Sub dbMergeLPURelated(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object)

-

-    ' 6 tables to change

-    Dim tables(1 To 5) As tDBTABLE

-    

-    'lpu budget

-    tables(1).name = "lpu_budget"

-    ReDim tables(1).field(1 To 4)

-    

-    tables(1).field(1).name = "entry_date"

-    tables(1).field(2).name = "bdgt_NMG"

-    tables(1).field(3).name = "bdgt_NFG"

-    tables(1).field(4).name = "sale_PLAN"

-    

-    'lpu hir

-    tables(2).name = "lpu_hir"

-    ReDim tables(2).field(1 To 13)

-    

-    tables(2).field(1).name = "entry_date"

-    tables(2).field(2).name = "operations_per_quarter"

-    tables(2).field(3).name = "risk_percent"

-    tables(2).field(4).name = "patients_with_risk_ON"

-    tables(2).field(5).name = "patients_ambulator"

-    tables(2).field(6).name = "patients_ambulator_nmg"

-    tables(2).field(7).name = "patients_ambulator_clexan"

-    tables(2).field(8).name = "patients_ambulator_clexan_40mg"

-    tables(2).field(9).name = "patients_ambulator_clexan_20mg"

-    tables(2).field(10).name = "patients_stationar_nmg"

-    tables(2).field(11).name = "patients_stationar_clexan"

-    tables(2).field(12).name = "patients_stationar_clexan_40mg"

-    tables(2).field(13).name = "patients_stationar_clexan_20mg"

-    

-    

-    'lpu acs

-    tables(3).name = "lpu_acs"

-    ReDim tables(3).field(1 To 5)

-    

-    tables(3).field(1).name = "entry_date"

-    tables(3).field(2).name = "patients_with_geparins"

-    tables(3).field(3).name = "patients_per_quarter"

-    tables(3).field(4).name = "patients_stationar_nmg"

-    tables(3).field(5).name = "patients_stationar_clexan"

-    

-    'lpu acs

-    tables(4).name = "lpu_im"

-    ReDim tables(4).field(1 To 5)

-    

-    tables(4).field(1).name = "entry_date"

-    tables(4).field(2).name = "patients_with_geparins"

-    tables(4).field(3).name = "patients_per_quarter"

-    tables(4).field(4).name = "patients_stationar_nmg"

-    tables(4).field(5).name = "patients_stationar_clexan"

-    

-    

-    'lpu acs

-    tables(5).name = "lpu_ter"

-    ReDim tables(5).field(1 To 9)

-    

-    tables(5).field(1).name = "entry_date"

-    tables(5).field(2).name = "patients_per_quarter"

-    tables(5).field(3).name = "risk_percent"

-    tables(5).field(4).name = "patients_with_risk_ON"

-    tables(5).field(5).name = "patients_ambulator"

-    tables(5).field(6).name = "patients_ambulator_nmg"

-    tables(5).field(7).name = "patients_ambulator_clexan"

-    tables(5).field(8).name = "patients_stationar_nmg"

-    tables(5).field(9).name = "patients_stationar_clexan"

-    

-    

-    

-    Dim tbl_idx As Integer

-    

-    For tbl_idx = 1 To UBound(tables)

-        

-        Dim getSQL As String

-        Dim getRS As Object

-        

-        

-        

-        Set getRS = CreateObject("ADODB.Recordset")

-        

-        getSQL = "SELECT * FROM " & tables(tbl_idx).name

-        getRS.Open getSQL, from_db

-        

-        If Not getRS.BOF Then

-            Do While Not getRS.EOF

-                Dim insRS As Object

-                Set insRS = CreateObject("ADODB.Recordset")

-                

-                insRS.Open tables(tbl_idx).name, to_db, 2, 2

-                insRS.addnew

-                Dim fld_idx As Integer

-    

-                    For fld_idx = 1 To UBound(tables(tbl_idx).field)

-                        insRS(tables(tbl_idx).field(fld_idx).name) = getRS(tables(tbl_idx).field(fld_idx).name)

-                        insRS("lpu_id") = findNewLPU_IDByOld(objLPU, getRS("lpu_id"))

-                    Next fld_idx

-                    

-                insRS.Update

-                insRS.MoveLast

-                getRS.MoveNext

-            Loop

-        End If

-        

-        

-    Next tbl_idx

-

-End Sub

-

-Function findNewLPU_IDByOld(objLPU() As tLPUCONVERTION, old_id As Long)

-

-Dim i As Integer

-For i = 1 To UBound(objLPU)

-    If objLPU(i).old_lpu_id = old_id Then

-        findNewLPU_IDByOld = objLPU(i).new_lpu_id

-        Exit Function

-    End If

-Next i

-

-findNewLPU_IDByOld = -1

-End Function

-

-

-

-

-

-Sub dbMergeQTR(from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getQTR_SQL As String

-    Dim getRecordset As Object

-    

-    getQTR_SQL = "SELECT * FROM quarter"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getQTR_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "quarter", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("entry_date") = getRecordset("entry_date")

-            insRS("sale_plan") = getRecordset("sale_plan")

-            insRS("ClxnH20mg") = getRecordset("ClxnH20mg")

-            insRS("ClxnH40mg") = getRecordset("ClxnH40mg")

-            insRS("ClxnT40mg") = getRecordset("ClxnT40mg")

-            insRS("ClxnC_IM") = getRecordset("ClxnC_IM")

-            insRS("ClxnC_ACS") = getRecordset("ClxnC_ACS")

-            

-            

-            insRS.Update

-            

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about quarter budget! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-dbMerge
->>>>>>
-Attribute VB_Name = "dbMerge"

-Option Explicit

-

-Public Type tLPUCONVERTION

-    old_lpu_id As Long

-    new_lpu_id As Long

-End Type

-

-Sub Merge_BackUp_All_Data()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim time_stump As String

-    

-    On Error GoTo ErrHandler

-    

-    time_stump = Format(Date, "yy-mm-dd_") & Format(Time, "hh-mm")

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_BACKUPNAME & time_stump & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Старые данные сохранены в файле:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для восстановления данных в случае утери", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-    Exit Sub

-    

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-

-Sub Merge_Clear_All_Data(access_file_full_path As String)

-    

-    Dim db As Object

-    Dim tables_to_clear() As String

-    On Error GoTo ErrHandler

-    

-    ReDim tables_to_clear(1 To 8)

-    tables_to_clear(1) = "rep"

-    tables_to_clear(2) = "lpu"

-    tables_to_clear(3) = "lpu_budget"

-    tables_to_clear(4) = "lpu_hir"

-    tables_to_clear(5) = "lpu_ter"

-    tables_to_clear(6) = "lpu_acs"

-    tables_to_clear(7) = "lpu_im"

-    tables_to_clear(8) = "quarter"

-    

-    Set db = dbGetConnection(access_file_full_path)

-

-    Dim i As Integer

-    

-    For i = 1 To UBound(tables_to_clear)

-        

-        If tables_to_clear(i) <> "" Then

-            Dim Clear_SQL As String

-            Clear_SQL = "DELETE FROM " & tables_to_clear(i)

-            dbExecuteOpenedSQL db, Clear_SQL

-        Else

-            'do nothing or show message

-        End If

-    Next i

-    

-    dbCloseOpenedConnection db

-    Set db = Nothing

-    

-'    Dim Engine As Object

-'    Set Engine = CreateObject("JRO.JetEngine")

-'    Engine.CompactDatabase "Password=password;Data Source=" & access_file_full_path, _

-'    "Password=password;Data Source=c:\tmp\1.mdb"

-    

-Exit Sub

-

-ErrHandler:

-    MsgBox "something wrong: " & err.Description

-    Resume Next

-    

-End Sub

-

-Function MergeREP(from_file As String, to_file As String) As Long

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    Dim new_rep_id As Long

-

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    MergeREP = dbMergeREP(db1, db2)

-    'MsgBox "new rep ID is " & new_rep_id

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Function

-

-Sub MergeQTR(from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeQTR db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-

-Sub MergeLPU(objLPU() As tLPUCONVERTION, from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeLPU objLPU, db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-Sub MergeLPURelated(objLPU() As tLPUCONVERTION, from_file As String, to_file As String)

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    dbMergeLPURelated objLPU, db1, db2

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-

-End Sub

-

-Sub MergeGlobal(rep_files() As String, rm_file As String)

-

-    Dim i As Integer

-    'clear output file content

-    Merge_Clear_All_Data rm_file

-    

-    For i = 1 To UBound(rep_files)

-        

-        Dim rep_file As String

-        'setup input and output files

-        rep_file = rep_files(i)

-        

-        Dim new_rep_id As Long

-        ' insert REP data and get new rep_id

-        new_rep_id = MergeREP(rep_file, rm_file)

-        

-        Dim objLPU() As tLPUCONVERTION

-        'insert all LPU using new generated rep_id

-        'and populate objLPU old->new relation object

-        

-        MergeLPU objLPU, rep_file, rm_file, new_rep_id

-        'insert quarter data using new rep_id

-        MergeQTR rep_file, rm_file, new_rep_id

-        

-        

-        ' and.... insert all another data (5 tables excl version and hw)

-        'using objLPU old->new relation object

-        MergeLPURelated objLPU, rep_file, rm_file

-    

-    

-    Next i

-    

-End Sub

-

-Function GetDBList(MyPath() As String, ByRef dblist() As String) As Integer

-    Dim i As Integer

-    Dim MyName, MyMask

-    MyMask = MyPath(0) & MyPath(1) & PROGRAM_DATAEXT

-    i = 0

-    MyName = Dir(MyMask)      ' Retrieve the first entry.

-    Do While MyName <> ""    ' Start the loop.

-        ' Ignore the current directory and the encompassing directory.

-        If MyName <> "." And MyName <> ".." Then

-            ' Use bitwise comparison to make sure MyName is a directory.

-            i = i + 1

-            ReDim Preserve dblist(i)

-            dblist(i) = MyPath(0) & MyName

-        End If

-        MyName = Dir    ' Get next entry.

-    Loop

-    GetDBList = i

-End Function

-

-<<<<<<
-======================
-dlgImprtDB
->>>>>>
-Attribute VB_Name = "dlgImprtDB"

-Attribute VB_Base = "0{D5892870-2C88-40C8-A817-AC9B1CF37C2C}{9853EBEA-4E48-41F9-89C0-6F753EB6A0C2}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Private Sub btSelAll_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = True

-    Next i

-End Sub

-

-Private Sub btUnselect_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = False

-    Next i

-End Sub

-<<<<<<
-======================
-dbQTR_RM
->>>>>>
-Attribute VB_Name = "dbQTR_RM"

-Option Explicit

-

-Public Type tQTRRM

-    id As Long

-    entry_date As String

-    rm_id As Long

-    sale_PLAN As Long

-End Type

-

-

-Sub Insert_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objQTRRM.id <> 0 Then

-        dbUpdate_QTRRM_Record dbConnection, objQTRRM

-    Else

-        dbInsert_QTRRM_Record dbConnection, objQTRRM

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-Function Get_QTRRM_Record(ent_date As String) As tQTRRM

-    Dim dbConnection As Object

-    Dim allQTRRM() As tQTRRM

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    i = dbGetAll_QTRRM_Records(dbConnection, allQTRRM, ent_date)

-    If i <> 0 Then

-        Get_QTRRM_Record = allQTRRM(1)

-    End If

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTRRM_Records(ByRef all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_QTRRM_Records = dbGetAll_QTRRM_Records(dbConnection, all_QTRRM, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_QTRRM_Record dbConnection, objQTRRM

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objQTRRM.ID <> 0 then updatre else insert

-Sub dbInsert_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "quarter_rm", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objQTRRM

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("sale_plan") = .sale_PLAN

-        dbRecordset("rm_id") = .rm_id

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objQTRRM.id = dbRecordset("id")

-

-End Sub

-

-Sub dbUpdate_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim Update_SQL As String

-    

-    With objQTRRM

-        Update_SQL = "UPDATE quarter_rm SET " & _

-            "entry_date='" & .entry_date & "'" & "," & _

-            "rm_id=" & .rm_id & "," & _

-            "sale_plan=" & .sale_PLAN & "," & _

-            " WHERE id=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if ent_date = % then all_records

-Function dbGetAll_QTRRM_Records(dbConnection As Object, all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    

-    Dim getCount_QTRRM_SQL As String

-    Dim getAll_QTRRM_SQL As String

-    Dim QTRRM_Count As Long

-    QTRRM_Count = 0

-    

-    getCount_QTRRM_SQL = "SELECT COUNT(*) AS QTRRM_TOTAL FROM quarter_rm WHERE entry_date like '" & ent_date & "'"

-    getAll_QTRRM_SQL = "SELECT * FROM quarter_rm WHERE entry_date like '" & ent_date & "' ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTRRM_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTRRM_Count = dbRecordset("QTRRM_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_QTRRM_Records = QTRRM_Count

-    

-    If QTRRM_Count > 0 Then

-        'we have records

-        ReDim all_QTRRM(1 To QTRRM_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTRRM_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTRRM As tQTRRM

-                 With tmp_QTRRM

-                    .entry_date = dbRecordset("entry_date")

-                    .rm_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .id = dbRecordset("id")

-                 End With

-                 

-                 all_QTRRM(index) = tmp_QTRRM

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM quarter_rm " & _

-    "WHERE id=" & objQTRRM.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-    

-    'delete related budget entries

-    MsgBox "remember delete related"

-'    dbDelete_BDGT_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Hir_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Ter_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_ACS_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-       

-End Sub

-

-

-<<<<<<
-======================
-REP_LIST
->>>>>>
-Attribute VB_Name = "REP_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentREP_ID() As Long

-    Dim r As Range

-

-    With Worksheets("REP_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CREP_ID)

-    End With

-

-    getCurrentREP_ID = r

-End Function

-

-Public Sub REP_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Rep_Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Rep_Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Rep_Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Rep_Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectREP_LPU(rep_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim r_id As Long

-    

-    Range("JUMP") = "LPU_LIST"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-        .Range("ent_date") = ent_date

-    End With

-End Sub

-

-Public Sub SelectREP_QTR(rep_id As Long)

-    Dim vo As Boolean

-    Dim r_id As Long

-    

-    Range("JUMP") = "REP_QTR"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("REP_QTR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateREPList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim rep_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CREP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CREP_AREA).row, CREP_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    rep_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CREP_AREA).Column

-    

-    If i < 4 Then

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 1

-    Else

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 2

-    End If

-    

-    If rep_id = 0 Then

-        Range("LAST_FOCUS") = Range(CREP_AREA).address

-    End If

-

-    If rep_id = 0 Then

-        i = CREP_NAME

-        Range("JUMP") = ""

-    Else

-        btREP_LIST_DO_IT

-    End If

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateREPList()

-    Dim rcd() As tREPID_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-

-    ent_date = getEnt_date

-

-    i = Get_REP_CommonList_by_QTR(rcd, ent_date)

-

-    With ThisWorkbook.Worksheets("REP_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(rcd)

-            r.Offset(i - 1, CREP_NAME) = rcd(i).rep.FirstName & " " & rcd(i).rep.LastName

-            r.Offset(i - 1, CREP_ID) = rcd(i).rep.rep_id

-            r.Offset(i - 1, CREP_BEDS) = rcd(i).qtrs(1).c_beds

-

-            r.Offset(i - 1, CREP_NFG) = rcd(i).qtrs(1).c_bdgt_NFG

-            r.Offset(i - 1, CREP_NMG) = rcd(i).qtrs(1).c_bdgt_NMG

-

-            r.Offset(i - 1, CREP_PLAN) = rcd(i).qtrs(1).qtr.sale_PLAN

-

-            r.Offset(i - 1, CREP_HIR) = rcd(i).qtrs(1).c_pat_HIR

-            r.Offset(i - 1, CREP_TER) = rcd(i).qtrs(1).c_pat_TER

-            r.Offset(i - 1, CREP_CAR) = rcd(i).qtrs(1).c_pat_CRD

-            r.Offset(i - 1, CREP_FACT) = rcd(i).qtrs(1).c_sale_ALL

-            r.Offset(i - 1, CREP_PAT_LPU) = rcd(i).qtrs(1).c_pat_LPU

-            r.Offset(i - 1, CREP_BDGT) = rcd(i).qtrs(1).c_bdgt_LPU

-            If rcd(i).qtrs(1).c_bdgt_LPU > 0 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = rcd(i).qtrs(1).c_sale_ALL / rcd(i).qtrs(1).c_bdgt_LPU

-            End If

-            If r.Offset(i - 1, CREP_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-

-

-<<<<<<
-======================
-mREP_LIST
->>>>>>
-Attribute VB_Name = "mREP_LIST"

-Option Explicit

-

-Public Const CREP_AREA As String = "B12"

-Public Const CREP_NAME As Integer = 0

-Public Const CREP_NAME1 As Integer = 1

-Public Const CREP_NAME2 As Integer = 2

-Public Const CREP_ID As Integer = 3

-Public Const CREP_BEDS As Integer = 4

-Public Const CREP_NFG As Integer = 5

-Public Const CREP_NMG As Integer = 6

-Public Const CREP_HIR As Integer = 7

-Public Const CREP_TER As Integer = 8

-Public Const CREP_CAR As Integer = 9

-Public Const CREP_FACT As Integer = 10

-Public Const CREP_PLAN As Integer = 11

-Public Const CREP_PAT_LPU As Integer = 16

-Public Const CREP_BDGT As Integer = 17

-Public Const CREP_PAT_ALL As Integer = 16

-

-

-

-Sub EditREP(cRep As tREPID, ent_date As String)

-    NoFunc

-End Sub

-

-Sub Rep_Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btREP_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = "RM_QTR"

-    End With

-    ThisWorkbook.Worksheets("RM_QTR").Activate

-End Sub

-

-

-Sub btREP_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim rep_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("REP_LST_DETALS")

-    With Worksheets("REP_LIST")

-        rep_id = .getCurrentREP_ID

-        

-        Select Case i

-            Case 1:

-                .SelectREP_QTR rep_id

-            Case 2:

-                ent_date = .getEnt_date()

-                .SelectREP_LPU rep_id, ent_date

-        End Select

-    End With

-    

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-

-

-

-<<<<<<
-======================
-cdbREP
->>>>>>
-Attribute VB_Name = "cdbREP"

-Option Explicit

-

-Public Type tREPID_COMMON

-    rep As tREPID

-    i_qtrs As Integer

-    qtrs() As tQTR_COMMON

-End Type

-

-Function Get_REP_CommonList_by_QTR(ByRef rcd() As tREPID_COMMON, ent_date As String) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_REP_CommonList_by_QTR = dbGet_REP_CommonList_by_QTR(dbConnection, rcd, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_REP_CommonList_by_QTR(dbConnection As Object, ByRef rcd() As tREPID_COMMON, ent_date As String) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim k As Long

-    Dim allREPID() As tREPID

-    

-    i = dbGetAll_REPID_Records_by_QTR(dbConnection, allREPID, ent_date)

-    dbGet_REP_CommonList_by_QTR = i

-    If i > 0 Then

-        ReDim rcd(i)

-        For i = 1 To UBound(allREPID)

-            rcd(i).rep = allREPID(i)

-            rcd(i).i_qtrs = Get_QTR_CommonList_by_REP(rcd(i).qtrs, ent_date, allREPID(i).rep_id)

-        Next i

-    End If

-End Function

-

-

-

-<<<<<<
-======================
-CHRT_PAT_LPU_A
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU_A"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-cdbRegion
->>>>>>
-Attribute VB_Name = "cdbRegion"

-Option Explicit

-

-Type tREGION

-    ent_date As String

-    total_SALE As Long ' общий объем продаж

-    total_BDGT As Long ' бюджет всех ЛПУ

-    total_BDGT_NMG As Long ' бюджет всех ЛПУ на НМГ

-    total_LPU As Long ' число ЛПУ

-    total_REP   As Long ' число репов

-    total_BEDS As Long ' общее число коек

-    total_HIR As Long '  общее число пациентов на клексане в хирургии

-    total_TER As Long '  общее число пациентов на клексане в терапии

-    total_ACS As Long '  общее число пациентов на клексане в кардиологии

-    sale_PLAN As Long '  план продаж Авентиса

-End Type

-

-Function GetRGN_COMM_DATA(ByRef reg_data() As tREGION) As Integer

-    Dim q_date() As String

-    Dim q_count As Integer, i As Integer

-    

-    q_count = getAllQTRNames(q_date)

-    If q_count > 0 Then

-        ReDim reg_data(q_count)

-        For i = 1 To q_count

-            Dim current_rep_count As Integer

-            current_rep_count = getREGION_by_QTR(q_date(i), reg_data(i))

-        Next i

-    End If

-    

-    GetRGN_COMM_DATA = q_count

-End Function

-

-Function getAllQTRNames(ByRef qtr_lst() As String) As Integer

-    

-    Dim sql As String

-    Dim i As Integer

-    Dim db As Object, rs As Object

-    

-    

-    sql = "SELECT DISTINCT entry_date FROM lpu_budget"

-    i = 0

-    

-    dbOpenConnection db

-    Set rs = CreateObject("ADODB.Recordset")

-    

-    rs.Open sql, db

-        

-        If Not rs.BOF Then

-            Do While Not rs.EOF

-                i = i + 1

-                ReDim Preserve qtr_lst(i)

-                qtr_lst(i) = rs("entry_date")

-                rs.MoveNext

-            Loop

-        Else

-            getAllQTRNames = 0

-            Exit Function

-        End If

-    getAllQTRNames = i

-    dbCloseConnection db

-End Function

-

-Function getREGION_by_QTR(ent_date As String, treg As tREGION) As Integer

-    Dim rep_count As Integer

-    rep_count = 0

-    

-    Dim reps() As tREPID_COMMON

-    rep_count = Get_REP_CommonList_by_QTR(reps, ent_date)

-    

-    treg.ent_date = ent_date

-    treg.total_BDGT = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.total_BDGT_NMG = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.sale_PLAN = 0 ' quarter.sale_plan

-    treg.total_SALE = 0 'summ of

-    ' hir = (amb40+st40)*pr40 + (amb20+st20)*pr20

-    'ter (amb_clx+stat_clx)*price

-    ' acs xxx

-    'price per rep

-    treg.total_HIR = 0 'patiens clxn

-    treg.total_TER = 0 'patiens clxn

-    treg.total_ACS = 0 'patiens clxn

-    treg.total_LPU = 0 'lpu

-    treg.total_BEDS = 0 'lpu.beds

-    treg.total_REP = 0 '

-    

-    If rep_count > 0 Then

-        Dim i As Integer

-        

-        For i = 1 To UBound(reps)

-            ' current rep is reps(i)

-            With reps(i)

-                treg.total_BDGT = treg.total_BDGT + .qtrs(1).c_bdgt_NFG + .qtrs(1).c_bdgt_NMG

-                treg.total_BDGT_NMG = treg.total_BDGT_NMG + .qtrs(1).c_bdgt_NMG

-                treg.sale_PLAN = treg.sale_PLAN + .qtrs(1).c_sale_PLAN

-                treg.total_SALE = treg.total_SALE + .qtrs(1).c_sale_ALL

-                treg.total_HIR = treg.total_HIR + .qtrs(1).c_pat_HIR

-                treg.total_TER = treg.total_TER + .qtrs(1).c_pat_TER

-                treg.total_ACS = treg.total_ACS + .qtrs(1).c_pat_CRD

-                treg.total_LPU = treg.total_LPU + .qtrs(1).i_lcd

-                treg.total_BEDS = treg.total_BEDS + .qtrs(1).c_beds

-                treg.total_REP = treg.total_REP + 1

-            End With

-            

-        Next i

-        

-    End If

-    

-    getREGION_by_QTR = treg.total_REP

-End Function

-

-<<<<<<
-======================
-mRM_QTR
->>>>>>
-Attribute VB_Name = "mRM_QTR"

-Option Explicit

-

-Sub btRM_QTR_Do_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    

-    idx = Worksheets(VAR_SHEET).Range("RM_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            ImportData

-        Case 2

-            Worksheets("REP_LIST").Select

-        Case 3

-            cmExport

-    End Select

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-End Sub

-

-Sub ImportData()

-    Dim i As Integer

-    Dim def_dir As String

-    Dim flist() As String

-    

-    def_dir = GetWBPath(ThisWorkbook.FullName)

-    If GetImportDirectory(def_dir, flist) Then

-        Dim ImpMask() As String

-        ImpMask = Split(flist(1), Chr(95), Compare:=vbBinaryCompare)

-        flist(1) = ImpMask(0) & "*"

-        Dim db_list() As String

-        i = GetDBList(flist(), db_list)

-        If i > 0 Then

-            Merge_BackUp_All_Data

-            MergeGlobal db_list, GetWBPath(ThisWorkbook.FullName) & "clexane-rm.mdb"

-        End If

-    End If

-    Worksheets(RM_QTR_SHEET).update_history

-End Sub

-<<<<<<
-======================
-mImport
->>>>>>
-Attribute VB_Name = "mImport"

-    Option Explicit

-

-Const OFN_ALLOWMULTISELECT As Long = 512

-Const OFN_EXPLORER As Long = 524288

-Const OFN_HIDEREADONLY As Long = 4

-Const OFN_NONETWORKBUTTON As Long = 131072

-Const OFN_READONLY As Long = 1

-       

-Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _

-    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

-

-Private Type OPENFILENAME

-    lStructSize As Long

-    hWndOwner As Long

-    hInstance As Long

-    lpstrFilter As String

-    lpstrCustomFilter As String

-    nMaxCustFilter As Long

-    nFilterIndex As Long

-    lpstrFile As String

-    nMaxFile As Long

-    lpstrFileTitle As String

-    nMaxFileTitle As Long

-    lpstrInitialDir As String

-    lpstrTitle As String

-    flags As Long

-    nFileOffset As Integer

-    nFileExtension As Integer

-    lpstrDefExt As String

-    lCustData As Long

-    lpfnHook As Long

-    lpTemplateName As String

-End Type

-

-Function GetImportDirectory(DB_dir As String, flist() As String) As Boolean

-    Dim OpenFile As OPENFILENAME

-    Dim lReturn As Long

-    Dim sFilter As String

-    

-    OpenFile.lStructSize = Len(OpenFile)

-    '         OpenFile.hwndOwner = Form1.hWnd

-    '         OpenFile.hInstance = App.hInstance

-    sFilter = "Clexane Data Files" & Chr(0) & "mr*.mdb" & Chr(0)

-    OpenFile.lpstrFilter = sFilter

-    OpenFile.nFilterIndex = 1

-    OpenFile.lpstrFile = String(257, 0)

-    OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1

-    OpenFile.lpstrFileTitle = OpenFile.lpstrFile

-    OpenFile.nMaxFileTitle = OpenFile.nMaxFile

-    OpenFile.lpstrInitialDir = DB_dir

-    OpenFile.lpstrTitle = "Импорт данных"

-    OpenFile.flags = OFN_HIDEREADONLY + OFN_EXPLORER

-    lReturn = GetOpenFileName(OpenFile)

-    If lReturn = 0 Then

-        GetImportDirectory = False

-    Else

-        GetImportDirectory = True

-        flist = Split(OpenFile.lpstrFile, Chr(0), Compare:=vbBinaryCompare)

-        Dim i As Integer

-        i = 0

-        Do While flist(i) <> ""

-            i = i + 1

-        Loop

-        If i = 1 Then

-            flist(1) = flist(0)

-            flist(0) = GetWBPath(flist(1))

-            flist(1) = GetWBName(flist(1))

-        Else

-            flist(0) = flist(0) & "\"

-        End If

-    End If

-End Function

-<<<<<<
-Project Name : 'ClexaneMR'
-Quirk - duff tag length======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).ClearRepName

-    

-    Application.EnableEvents = True

-    Set MyAppEvents.app = Application

-    

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    

-    MyAppEvents.CheckWorkBooksArround ThisWorkbook

-    

-    cmSetStandaloneMode

-    

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-    

-    Application.ScreenUpdating = True

-    

-    If CheckUser Then

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-        ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-        ThisWorkbook.Worksheets(REP_QTR_SHEET).update_history

-        Application.Calculate

-    End If

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    

-    Dim RestMode As Boolean

-    RestMode = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE")

-    

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-'        If RestMode Then

-            ThisWorkbook.Saved = True

-'        Else

-'            ThisWorkbook.Save

-'        End If

-    End If

-    If RestMode Then

-        xlRestoreView

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    End If

-    Application.Caption = Empty

-    Application.CommandBars(STDBAR_NAME).Reset

-    

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-    Dim MaxX, MaxY As Integer

-    With ThisWorkbook.Worksheets(REP_QTR_SHEET)

-        MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-        MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-    End With

-

-    With ThisWorkbook.Application

-        .ScreenUpdating = False

-        .WindowState = xlNormal

-        .Height = MaxY

-        .Width = MaxX

-    End With

-End Sub

-

-

-

-

-

-<<<<<<
-======================
-REP_QTR
->>>>>>
-Attribute VB_Name = "REP_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CQTR_QT As Integer = 0

-Const CQTR_ID As Integer = 1

-Const CQTR_PLN As Integer = 2

-Const CQTR_FCT As Integer = 3

-Const CQTR_BDG As Integer = 4

-Const CQTR_CNT As Integer = 5

-Const CQTR_BEDS As Integer = 6

-Const CQTR_HIR As Integer = 7

-Const CQTR_TER As Integer = 8

-Const CQTR_CRD As Integer = 9

-Const CQTR_CLXN_BDG As Integer = 10

-Const CQTR_CLXN_NMG As Integer = 11

-Const CQTR_PAT_ALL As Integer = 16

-Const CQTR_BDGT_ALL As Integer = 17

-

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub ClearRepName()

-    Unprotect

-    Range("D4") = ""

-    Range("D5") = ""

-    Range("H4") = ""

-    Range("H5") = ""

-End Sub

-

-Sub update_history()

-    Dim objQTR() As tQTR

-    Dim i As Long

-    Dim r As Range

-    Dim cRep As tREP

-    

-    cRep = GetREPRecord

-    Range("D4") = cRep.LastName

-    Range("D5") = cRep.FirstName

-    

-    Range("H4") = GetRegionName(cRep.Region)

-    Range("H5") = GetCityName(cRep.Region, cRep.City)

-    

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    i = GetAll_QTR_Records(objQTR, "%")

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CQTR_QT) = objQTR(i).entry_date

-        Next i

-    End If

-    Dim qcd() As tQTR_COMMON

-    i = Get_QTR_CommonList(qcd)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(qcd)

-            r.Offset(i - 1, CQTR_QT) = qcd(i).qtr.entry_date

-            r.Offset(i - 1, CQTR_ID) = qcd(i).qtr.id

-            r.Offset(i - 1, CQTR_PLN) = qcd(i).qtr.sale_plan

-            r.Offset(i - 1, CQTR_FCT) = qcd(i).c_sale_ALL

-            r.Offset(i - 1, CQTR_BDG) = qcd(i).c_bdgt_LPU

-            r.Offset(i - 1, CQTR_CNT) = qcd(i).i_lcd

-            r.Offset(i - 1, CQTR_BEDS) = qcd(i).c_beds

-            r.Offset(i - 1, CQTR_HIR) = qcd(i).c_pat_HIR

-            r.Offset(i - 1, CQTR_TER) = qcd(i).c_pat_TER

-            r.Offset(i - 1, CQTR_CRD) = qcd(i).c_pat_CRD

-            If qcd(i).c_bdgt_LPU <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_BDG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_LPU

-            End If

-            If qcd(i).c_bdgt_NMG <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_NMG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_BBL_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-

-End Sub

-

-Sub Draw_PAT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CQTR_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRepQtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-

-Private Sub Worksheet_Activate()

-  

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-    

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.Count > 1 And r_sel.Columns.Count < CRow_Width Or r_sel.Rows.Count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.Count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.Count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.Count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CQTR_ID + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    i = currRange.Column - Range(CINP_AREA).Column

-    

-    QTR_ID = r

-

-    If QTR_ID = 0 Then

-        Worksheets(VAR_SHEET).Range("USER_ACTION") = 1

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        If i > CQTR_FCT Then

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-            Range("LAST_FOCUS") = currRange.address

-        Else

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 3

-            Range("LAST_FOCUS") = currRange.address

-        End If

-    End If

-    Cancel = True

-    btHomeDo_IT

-End Sub

-

-<<<<<<
-======================
-mRep_QTR
->>>>>>
-Attribute VB_Name = "mRep_QTR"

-Option Explicit

-

-Sub DO_New_qtr()

-    Dim res As Variant

-    Dim objQTR As tQTR

-    Dim s As String

-    s = GetLastQtr

-    objQTR.entry_date = GetNextQTR(s)

-    

-    If objQTR.entry_date = "" Then

-        Exit Sub

-    End If

-    

-    DO_Price_qtr objQTR.entry_date

-

-End Sub

-

-Sub DO_Price_qtr(ent_date As String)

-    If ent_date = "" Then

-        DO_New_qtr

-    Else

-        Dim qtr As tQTR

-        Dim res As Integer

-        

-        qtr = Get_QTR_Record(ent_date)

-        

-        If qtr.id = 0 Then

-            qtr.entry_date = ent_date

-    

-            With Worksheets(VAR_SHEET)

-                qtr.ClxnH20mg = .Range("ClxnH20mg")

-                qtr.ClxnH40mg = .Range("ClxnH40mg")

-                qtr.ClxnT40mg = .Range("ClxnT40mg")

-                qtr.ClxnC_ACS = .Range("ClxnC_ACS")

-                qtr.ClxnC_IM = .Range("ClxnC_IM")

-            End With

-        End If

-        

-        Dim dlg_nq As dlg_nextQTR

-        Set dlg_nq = New dlg_nextQTR

-        

-        With dlg_nq

-            .tb_qtr_name = qtr.entry_date

-            .tb_bdgt_avts = qtr.sale_plan

-            .tb_qtr_name = qtr.entry_date

-            .tb_ClxnH20mg = qtr.ClxnH20mg

-            .tb_ClxnH40mg = qtr.ClxnH40mg

-            .tb_ClxnT40mg = qtr.ClxnT40mg

-            .tb_ClxnC_ACS = qtr.ClxnC_ACS

-            .tb_ClxnC_IM = qtr.ClxnC_IM

-        End With

-        

-        dlg_nq.Show

-        res = dlg_nq.Tag

-        

-        If res = vbOK Then

-            With dlg_nq

-                If Not IsNumeric(.tb_bdgt_avts) Then

-                    MsgBox "Введите план продаж", vbOK, PROGRAM_NAME

-                Else

-                    If .tb_bdgt_avts = 0 Then

-                        MsgBox "Введите план продаж", vbOK, PROGRAM_NAME

-                        Exit Sub

-                    End If

-                End If

-                Dim bool As Boolean

-                bool = IsNumeric(.tb_ClxnH20mg) _

-                    And IsNumeric(.tb_ClxnH40mg) _

-                    And IsNumeric(.tb_ClxnT40mg) _

-                    And IsNumeric(.tb_ClxnC_ACS) _

-                    And IsNumeric(.tb_ClxnC_IM)

-                If Not bool Then

-                    MsgBox "Вводите правильно цыфры", vbOK, PROGRAM_NAME

-                    Exit Sub

-                End If

-                qtr.sale_plan = .tb_bdgt_avts

-                qtr.entry_date = .tb_qtr_name

-                qtr.ClxnH20mg = .tb_ClxnH20mg

-                qtr.ClxnH40mg = .tb_ClxnH40mg

-                qtr.ClxnT40mg = .tb_ClxnT40mg

-                qtr.ClxnC_ACS = .tb_ClxnC_ACS

-                qtr.ClxnC_IM = .tb_ClxnC_IM

-            End With

-            Insert_QTR_Record qtr

-        End If

-    End If

-End Sub

-

-Sub DO_Edit_qtr(ent_date As String)

-    If ent_date = "" Then

-        DO_New_qtr

-    Else

-        With ThisWorkbook.Worksheets("LPU_LIST")

-            .Range("VIEW_ONLY") = False

-            .Range("ent_date") = ent_date

-            .Select

-        End With

-    End If

-End Sub

-

-Sub DO_Delete_qtr(ent_date As String)

-    If ent_date <> "" Then

-        Dim i As Integer

-        i = MsgBox("Удалить данные за период [" & ent_date & "]?", vbDefaultButton2 + vbOKCancel, PROGRAM_NAME)

-        If i = vbOK Then

-            Dim objQTR As tQTR

-            If ent_date <> "" Then

-                objQTR.entry_date = ent_date

-                objQTR = Get_QTR_Record(ent_date)

-                Delete_QTR_Record objQTR

-                Worksheets(TITLE_SHEET).Select

-                Worksheets(REP_QTR_SHEET).Select

-            End If

-        End If

-    End If

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-

-Sub btHomeDo_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    idx = Worksheets(VAR_SHEET).Range("USER_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            DO_New_qtr

-            ' Обновляем экран

-        Case 2

-            DO_Edit_qtr ent_date

-        Case 3

-            DO_Price_qtr ent_date

-        Case 4

-            dbExport

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    End Select

-    If idx <> 2 Then

-        With ThisWorkbook

-            .Worksheets(TITLE_SHEET).Select

-            .Worksheets(REP_QTR_SHEET).Select

-        End With

-    End If

-End Sub

-

-Sub Delete_qtr()

-    Dim ent_date As String

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    DO_Delete_qtr ent_date

-End Sub

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane[MR]"

-Public Const PROGRAM_VERSION As String = "version 1.6"

-Public Const PROGRAM_FILENAME As String = "clexane-mr"

-Public Const PROGRAM_EXPORTNAME As String = "mr-ex-"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20030329

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "O40"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-End Sub

-

-Function Double2Str(ByVal d As Double, ByVal precision As Integer, Optional Delim As String = ".") As String

-    Dim s As String

-    If Not precision > 0 Then

-        s = Round(d)

-    Else

-        Dim i As Integer

-        i = Fix(d)

-        s = i & Delim

-        d = Abs(d - i)

-        Do

-            precision = precision - 1

-            d = d * 10

-            If precision > 0 Then

-                i = Fix(d)

-            Else

-                i = Round(d)

-            End If

-            If i < 1 Then

-                s = s & "0"

-            Else

-                s = s & i

-                d = d - i

-            End If

-        Loop While precision > 0

-    End If

-    Double2Str = s

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.Count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.name = VAR_SHEET Or sh.name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-<<<<<<
-======================
-Var
->>>>>>
-Attribute VB_Name = "Var"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-title
->>>>>>
-Attribute VB_Name = "title"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LPU_LIST
->>>>>>
-Attribute VB_Name = "LPU_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentLPU_ID() As Long

-    Dim r As Range

-    

-    With Worksheets("LPU_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CLPU_ID)

-    End With

-    

-    getCurrentLPU_ID = r

-End Function

-

-Public Sub LPU_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectLPU_NAME(lpu_id As Long, ent_date As String)

-    If Range("VIEW_ONLY") = True Then

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    Dim cLPU As tLPU

-    If lpu_id = 0 Then

-        cLPU.id = 0

-        cLPU.rep_id = 0

-        cLPU.address = ""

-        cLPU.name = ""

-    Else

-        cLPU = Get_LPU_Record(lpu_id)

-    End If

-    EditLPU cLPU, getEnt_date

-    Worksheet_Activate

-End Sub

-        

-Sub SelectLPU_BDGT(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    If lpu_id = 0 Then

-        SelectLPU_NAME lpu_id, ent_date

-    Else

-        With ThisWorkbook.Worksheets("LPU_BDGT")

-            .Range("VIEW_ONLY") = vo

-            .Range("ret_addr") = "LPU_LIST"

-            .Range("ent_date") = ent_date

-            .Range("lpu_id") = lpu_id

-        End With

-    End If

-End Sub

-

-Sub SelectLPU_HIR(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_CLSN_HIR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-                   

-Sub SelectLPU_TER(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_CLSN_TER")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-       

-Sub SelectLPU_C_ACS(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_CLSN_C_ACS")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateLPUList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.Count > 1 And r_sel.Columns.Count < CINP_WIDTH Or r_sel.Rows.Count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.Count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.Count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.Count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim lpu_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-    

-    ent_date = getEnt_date

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-    

-    Set r = Range(CINP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CINP_AREA).row, CLPU_ID)

-        

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-    

-    lpu_id = r

-    

-    i = Range(Range("LAST_FOCUS")).Column - Range(CINP_AREA).Column

-    

-    If lpu_id = 0 Then

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    End If

-    

-    If lpu_id = 0 Then

-        i = CLPU_NAME

-        Range("JUMP") = ""

-    End If

-    Select Case i

-        Case CLPU_NAME, CLPU_NAME1, CLPU_NAME2, CLPU_BEDS

-            SelectLPU_NAME lpu_id, ent_date

-            Range("JUMP") = ""

-

-        Case CLPU_NMG, CLPU_NFG, CLPU_PLAN, CLPU_FACT

-            SelectLPU_BDGT lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-            

-        Case CLPU_HIR

-            SelectLPU_HIR lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_HIR"

-        

-        Case CLPU_TER

-            SelectLPU_TER lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_TER"

-        

-        Case CLPU_CAR

-            SelectLPU_C_ACS lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_C_ACS"

-        

-        Case Else

-            Range("JUMP") = ""

-    End Select

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-    

-    is_input_range = INPUT_NO

-    

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateLPUList()

-    Dim lcd() As tLPU_COMMON

-    

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-    Dim objQTR As tQTR

-    Dim cRep As tREP

-    

-    ' ent_date = "%" ' % - all records

-    ent_date = getEnt_date

-    

-    objQTR = Get_QTR_Record(ent_date)

-    i = Get_LPU_CommonQTR(lcd, objQTR)

-     

-    ' стираем ФИО

-    Range("C3:C4").ClearContents

-    cRep = GetREPRecord

-    

-    Range("C3") = cRep.LastName

-    Range("C4") = cRep.FirstName

-    Range("G3") = GetRegionName(cRep.Region)

-    Range("G4") = GetCityName(cRep.Region, cRep.City)

-    Range("G5") = objQTR.sale_plan

-    

-

-    

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-        

-        For i = 1 To UBound(lcd)

-            r.Offset(i - 1, CLPU_NAME) = lcd(i).lpu.name

-            r.Offset(i - 1, CLPU_ID) = lcd(i).lpu.id

-            r.Offset(i - 1, CLPU_BEDS) = lcd(i).lpu.beds

-            

-         

-            r.Offset(i - 1, CLPU_NFG) = lcd(i).bdgt.bdgt_NFG

-            r.Offset(i - 1, CLPU_NMG) = lcd(i).bdgt.bdgt_NMG

-            r.Offset(i - 1, CLPU_PLAN) = lcd(i).bdgt.sale_plan

-            

-            r.Offset(i - 1, CLPU_HIR) = lcd(i).pat_HIR

-            r.Offset(i - 1, CLPU_TER) = lcd(i).pat_TER

-            r.Offset(i - 1, CLPU_CAR) = lcd(i).pat_CRD

-            r.Offset(i - 1, CLPU_FACT) = lcd(i).sale_ALL

-            r.Offset(i - 1, CLPU_PAT_LPU) = lcd(i).pat_LPU

-            r.Offset(i - 1, CLPU_BDGT) = lcd(i).bdgt_LPU

-            If lcd(i).bdgt_LPU > 0 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = lcd(i).sale_ALL / lcd(i).bdgt_LPU

-            End If

-            If r.Offset(i - 1, CLPU_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = 1

-            End If

-            

-        Next i

-    End If

-End Sub

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{566B33D6-957A-43E4-8444-D8EA3889700C}{42EE65B8-F8C6-4F95-9F52-7738BF6FCEAD}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-dbACS
->>>>>>
-Attribute VB_Name = "dbACS"

-Option Explicit

-

-Public Type tACS

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    patients_with_geparins As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objACS.ID <> 0 then updatre else insert

-Sub Insert_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objACS.id <> 0 Then

-        dbUpdate_ACS_Record dbConnection, objACS

-    Else

-        dbInsert_ACS_Record dbConnection, objACS

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_ACS_RecordsByLPU_ID(ByRef all_ACS_() As tACS, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_ACS_RecordsByLPU_ID = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, all_ACS_, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_ACS_Record dbConnection, objACS

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub dbInsert_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_acs", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objACS

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("patients_with_geparins") = .patients_with_geparins

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objACS.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim Update_SQL As String

-    

-    With objACS

-        Update_SQL = "UPDATE lpu_acs SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "patients_with_geparins=" & .patients_with_geparins & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_ACS_RecordsbyLPU_ID(dbConnection As Object, all_ACS() As tACS, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_ACS_SQL As String

-    Dim getAll_ACS_SQL As String

-    Dim ACS_Count As Long

-    ACS_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_ACS_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        ACS_Count = dbRecordset("ACS_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_ACS_RecordsbyLPU_ID = ACS_Count

-    

-    If ACS_Count > 0 Then

-        'we have records

-        ReDim all_ACS(1 To ACS_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_ACS_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_ACS As tACS

-                 With tmp_ACS

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .patients_with_geparins = dbRecordset("patients_with_geparins")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 all_ACS(index) = tmp_ACS

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE ID=" & objACS.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_ACS_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_HIR
->>>>>>
-Attribute VB_Name = "LPU_CLSN_HIR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-    

-        Dim objHir As tHIRURGIA

-        

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objHir

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .operations_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L9")

-                .patients_ambulator_clexan_20mg = Range("L10")

-                .patients_ambulator_clexan_40mg = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L19")

-                .patients_stationar_clexan_20mg = Range("L20")

-                .patients_stationar_clexan_40mg = Range("L21")

-            End With

-            Insert_Hir_Record objHir

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objHir.id = Range("rec_id")

-                    If objHir.id <> 0 Then

-                        Delete_Hir_Record objHir

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objHir As tHIRURGIA)

-    Dim qtr As tQTR

-    Dim formula As String

-

-    With objHir

-        Range("rec_id") = .id

-        Range("F6") = .operations_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L9") = .patients_ambulator_clexan

-        Range("L10") = .patients_ambulator_clexan_20mg

-        Range("I21") = .patients_stationar_nmg

-        Range("L19") = .patients_stationar_clexan

-        Range("L20") = .patients_stationar_clexan_20mg

-        

-        qtr = Get_QTR_Record(.entry_date)

-        formula = "=" & qtr.ClxnH20mg & "*($L$10+$L$20)+" & qtr.ClxnH40mg & "*($L$11+$L$21)"

-        Range("F11").formula = formula

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-    

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Range("h_DepFlag") = False

-    

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objHir() As tHIRURGIA

-        Dim i As Integer

-        i = GetAll_Hir_RecordsByLPU_ID(objHir, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.3

-        Else

-            SetupData objHir(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-mSapes
->>>>>>
-Attribute VB_Name = "mSapes"

-Option Explicit

-

-Const SHAPE_COLOR As Integer = 1

-Const SHAPE_NAME As Integer = 2

-

-

-Sub ShapeView(r_sh_finite_state As Range)

-    Dim chk As Range

-    Dim s As String

-    Dim c, idx As Integer

-    For Each chk In r_sh_finite_state

-        idx = 0

-        If chk = "+" Then

-            c = chk.Offset(0, idx + SHAPE_COLOR)

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While c <> 0

-                ShapeFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s)), c

-                idx = idx + 2

-                c = chk.Offset(0, idx + SHAPE_COLOR)

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        Else

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While s <> ""

-                ShapeUnFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s))

-                idx = idx + 2

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        End If

-    Next chk

-End Sub

-

-Sub ShapeFill(sh As ShapeRange, ByVal color As Integer)

-    sh.Fill.Visible = msoTrue

-    sh.Fill.Solid

-    sh.Fill.ForeColor.SchemeColor = color

-    sh.Fill.Transparency = 0#

-End Sub

-

-Sub ShapeUnFill(sh As ShapeRange)

-    sh.Fill.Visible = msoFalse

-    sh.Fill.Transparency = 0#

-End Sub

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Public Const INPUT_NO = 0

-Public Const INPUT_NUMBER = 1

-Public Const INPUT_PERCENT = 2

-Public Const INPUT_STRING = 3

-Public Const INPUT_CHECK = 4

-

-Public Const INP_IDX_TYPE = 1

-Public Const INP_IDX_NEXT = 2

-Public Const INP_IDX_MIN = 3

-Public Const INP_IDX_MAX = 4

-Public Const INP_IDX_DEP = 5

-Public Const INP_IDX_ALT = 7

-

-

-Public Type tInputSet

-    vType As Integer

-    vMin As Long

-    vMax As Long

-    rChk As String

-End Type

-

-Function is_input_cell(ByVal Target As Range, inputs As Range) As tInputSet

-    Dim t As Range

-    Dim iset As tInputSet

-    Dim test As Range

-    iset.vType = INPUT_NO

-    iset.vMin = 0

-    iset.vMax = 0

-    iset.rChk = ""

-    is_input_cell = iset

-

-' Закоментировать следующую сточку для работы

-'  Exit Function

-

-    Set test = Target.Cells(1, 1)

-    For Each t In inputs

-        If Range(t).Column = test.Column And Range(t).row = test.row Then

-            iset.vType = t.Offset(0, INP_IDX_TYPE).Value

-            Select Case iset.vType

-                Case INPUT_CHECK

-                    iset.rChk = t.Offset(0, INP_IDX_ALT)

-                Case INPUT_NUMBER, INPUT_PERCENT

-                    iset.vMin = t.Offset(0, INP_IDX_MIN).Value

-                    iset.vMax = t.Offset(0, INP_IDX_MAX).Value

-            End Select

-            is_input_cell = iset

-            Exit Function

-        End If

-    Next t

-End Function

-

-Function GetFocusAddress(ByVal r As Range, f_next As Range) As String

-    Dim chk, t As Range

-    

-    For Each chk In f_next

-        For Each t In r

-            If t.address = chk Then

-                GetFocusAddress = chk

-                Exit Function

-            End If

-            If Range(chk).Column = t.Column - 1 And Range(chk).row = t.row _

-            Or Range(chk).Column = t.Column And Range(chk).row = t.row - 1 _

-            Then

-                If Range(chk) <> "" Then

-                    If Range(chk) = 0 Then

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_ALT)).address

-                    Else

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_NEXT)).address

-                    End If

-                Else

-                    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-                End If

-                Exit Function

-            End If

-        Next t

-    Next chk

-    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-End Function

-

-Sub SetDependet(r As Range, inputs As Range)

-    Dim chk As Range

-    Dim s, serr As String

-    Dim idx As Integer

-    Dim iset As tInputSet

-    Dim err_found As Boolean

-    

-    If r.Count > 1 Then

-        Exit Sub

-    End If

-    

-    err_found = False

-    For Each chk In inputs

-        idx = INP_IDX_DEP

-        

-        

-        iset.vType = chk.Offset(0, INP_IDX_TYPE).Value

-        Select Case iset.vType

-            Case INPUT_NUMBER, INPUT_PERCENT

-                iset.vMin = chk.Offset(0, INP_IDX_MIN).Value

-                iset.vMax = chk.Offset(0, INP_IDX_MAX).Value

-                

-                If Range(chk) > iset.vMax Then

-                    err_found = True

-                    Range(chk) = iset.vMax

-                    serr = "Выход за дозволенный диапазон [" & iset.vMin & ".." & iset.vMax & "]! Данные скорректированы."

-                End If

-                

-                If Range(chk) = "" Then

-                    s = chk.Offset(0, idx)

-                    Do While s <> ""

-                        Range(s) = ""

-                        idx = idx + 1

-                        s = chk.Offset(0, idx)

-                    Loop

-                End If

-        End Select

-    Next chk

-    If err_found Then

-        MsgBox serr, vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Function CheckInputData(inputs As Range) As Boolean

-    Dim r As Range

-    

-    CheckInputData = True

-    For Each r In inputs

-        If Range(r) = "" Then

-            CheckInputData = False

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100.", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Sub Check_Int_Number(Target As Range, Def_Val As Long)

-    Dim err As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    err = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                err = True

-            End If

-        End If

-    Next r

-    If err Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_TER
->>>>>>
-Attribute VB_Name = "LPU_CLSN_TER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim objTer As tTERAPIA

-        

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objTer

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .patients_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L20")

-            End With

-            Insert_Ter_Record objTer

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objTer.id = Range("rec_id")

-                    If objTer.id <> 0 Then

-                        Delete_Ter_Record objTer

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objTer As tTERAPIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    With objTer

-        Range("rec_id") = .id

-        Range("F6") = .patients_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L11") = .patients_ambulator_clexan

-        Range("I21") = .patients_stationar_nmg

-        Range("L20") = .patients_stationar_clexan

-        

-        qtr = Get_QTR_Record(.entry_date)

-        formula = "=" & qtr.ClxnT40mg & "*($L$12+$L$20)"

-        Range("F11").formula = formula

-        

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-    

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Range("h_DepFlag") = False

-    

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objTer() As tTERAPIA

-        Dim i As Integer

-        i = GetAll_Ter_RecordsByLPU_ID(objTer, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.25

-        Else

-            SetupData objTer(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-    

-    Dim s As String

-    Dim iset As tInputSet

-    

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    

-    Select Case iset.vType

-        Case INPUT_NO

-        

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-            

-            Application.ScreenUpdating = False

-            

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-            

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-        

-        Case INPUT_STRING

-        

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{EBA94131-180E-4709-A2A3-B60D48987620}{47A860A1-BF92-4EBB-A333-AB7E83FAB868}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-LPU_BDGT
->>>>>>
-Attribute VB_Name = "LPU_BDGT"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub SetDefFocus()

-    Range(Range("DEF_FOCUS")).Select

-End Sub

-

-Public Sub ClearData()

-    ClearSheetData

-End Sub

-

-Sub ClearSheetData()

-    If Range("F10") = 0 And Range("F13") = 0 Then

-        Range("F11:F18") = ""

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("F11:F13") = ""

-    End If

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim bdgt As tBUDGET

-        Dim sum As Long

-        Dim test As Boolean

-        With bdgt

-            .lpu_id = Range("lpu_id")

-            .id = Range("rec_id")

-            .entry_date = Range("ent_date")

-            .bdgt_NMG = Round(Range("F11").Value, 0)

-            .bdgt_NFG = Round(Range("F12").Value, 0)

-            .sale_plan = Round(Range("F13").Value, 0)

-            

-            sum = .bdgt_NFG + .bdgt_NMG - .sale_plan

-            test = .bdgt_NFG <> 0 Or .bdgt_NMG <> 0 Or .sale_plan <> 0

-        End With

-        If test Then

-            If sum < 0 Then

-                MsgBox _

-                    "Ваш план превышает выделенный на гепарины бюджет. Сохранить данные?", _

-                    vbOKOnly, PROGRAM_NAME

-            End If

-            If test Then

-                Insert_BDGT_Record bdgt

-            End If

-        Else

-            If bdgt.id <> 0 Then

-                If vbYes = MsgBox("Сохранить нулевые значения?", vbYesNo, PROGRAM_NAME) Then

-                    Insert_BDGT_Record bdgt

-                End If

-                ret_back Range("DEF_FOCUS").Worksheet

-                Exit Sub

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-    End If

-    

-   ClearData

-   ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(cLPU As tLPU_COMMON)

-    Dim t_sum As Long

-    t_sum = 0

-' Setup budget data

-    Range("F11") = cLPU.bdgt.bdgt_NMG

-    Range("F12") = cLPU.bdgt.bdgt_NFG

-    Range("F13") = cLPU.bdgt.sale_plan

-    

-    With cLPU

-        Range("F14") = .pat_ALL

-        Range("F15") = .pat_HIR

-        Range("F16") = .pat_TER

-        Range("F17") = .pat_CRD

-        Range("F18") = .sale_ALL

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    ws_activate

-End Sub

-

-

-Sub ws_activate()

-    Dim cLPU As tLPU_COMMON

-    Dim objQTR As tQTR

-    Dim objLPU As tLPU

-    Dim ent_date As String

-    Dim id As Long

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    id = Range("lpu_id").Value

-    ent_date = Range("ent_date")

-    objQTR = Get_QTR_Record(ent_date)

-    objLPU = Get_LPU_Record(id)

-    Get_LPU_Common cLPU, objLPU, objQTR

-    

-    If cLPU.lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = cLPU.lpu.beds

-        Range("lpu_name") = cLPU.lpu.name

-        Range("lpu_addr") = cLPU.lpu.address

-        Range("rec_id") = cLPU.bdgt.id

-        

-        SetupData cLPU

-        

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-'    MsgBox Target.address

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Dim s As String

-    Dim iset As tInputSet

-    

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    

-    Select Case iset.vType

-        Case INPUT_NO

-        

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-            

-        Case INPUT_PERCENT

-        

-        Case INPUT_STRING

-        

-        Case INPUT_CHECK

-            

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{E3F10C5A-A4B4-42FF-A2C9-6F8198210A07}{563D0F3D-F79D-48F1-AFE4-A2136809B982}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mSheets
->>>>>>
-Attribute VB_Name = "mSheets"

-Option Explicit

-

-Function am_load_now() As Boolean

-    am_load_now = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE")

-End Function

-

-Sub Wks_select(RetSheet As String)

-    Dim sheet As Worksheet

-    For Each sheet In ThisWorkbook.Worksheets

-        If sheet.name = RetSheet Then

-            ThisWorkbook.Worksheets(RetSheet).Select

-            Exit Sub

-        End If

-    Next sheet

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub ret_back(sh As Worksheet)

-    Dim RetSheet As String

-    RetSheet = sh.Range("ret_addr")

-    sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    sh.Range("ret_addr") = ""

-    sh.Range("rec_id") = ""

-    sh.Range("lpu_id") = ""

-    sh.Range("ent_date") = ""

-    sh.Range("lpu_name") = ""

-    sh.Range("lpu_addr") = ""

-    sh.Range("lpu_beds") = ""

-    Wks_select RetSheet

-End Sub

-

-Sub ClearSheetData(r_start As Range)

-    If r_start <> "" Then

-        r_start.Worksheet.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        r_start = ""

-    Else

-        ret_back r_start.Worksheet

-    End If

-End Sub

-

-Sub wks_sel_chng(iset As tInputSet, ByVal Target As Range, sh As Worksheet)

-    Dim DebugMode As Boolean

-    Dim in_range As Range

-    

-    DebugMode = Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-

-    If DebugMode Then

-        sh.Unprotect

-    Else

-        sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    End If

-

-    If iset.vType = INPUT_CHECK Then

-        Set in_range = Target.Worksheet.Range(iset.rChk)

-    Else

-        Set in_range = Target

-    End If

-    

-    Dim str As String

-    str = GetFocusAddress(in_range, sh.Range("h_inputs"))

-

-'    MsgBox Target.Address & "; " & str

-    If str <> Target.address Then

-        sh.Range(str).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-Dlg_lpu_card
->>>>>>
-Attribute VB_Name = "Dlg_lpu_card"

-Attribute VB_Base = "0{137EDDE5-3DB4-4BAD-A245-324DC31ABB36}{3BD7159A-BF6C-403F-B3DF-4834FA9E4D92}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbLPU_List_Change()

-    Dim src As Range

-    Dim idx_src As Integer

-    

-    Set src = Worksheets(VAR_SHEET).Range(Me.cbLPU_List.RowSource)

-    idx_src = Me.cbLPU_List.ListIndex + 1

-    Me.tb_lpu_name.Text = src.Cells(idx_src, 1)

-    Me.tb_lpu_address.Text = src.Cells(idx_src, 2)

-    Me.tbBedsCount.Text = src.Cells(idx_src, 3)

-End Sub

-

-

-Private Sub cbxLPU_List_Enable_Click()

-    

-    If Me.cbxLPU_List_Enable Then

-        

-        Me.tb_lpu_name.Text = ""

-        Me.tb_lpu_name.Enabled = False

-        

-        Me.tb_lpu_address.Text = ""

-        Me.tb_lpu_address.Enabled = False

-        

-        Me.tbBedsCount.Text = ""

-        Me.tbBedsCount.Enabled = False

-        

-        Me.cbLPU_List.Enabled = True

-        cbLPU_List_Change

-    Else

-        Me.tb_lpu_name.Enabled = True

-        Me.tb_lpu_name.Text = ""

-        

-        Me.tb_lpu_address.Enabled = True

-        Me.tb_lpu_address.Text = ""

-        

-        Me.tbBedsCount.Enabled = True

-        Me.tbBedsCount.Text = ""

-        

-        Me.cbLPU_List.Enabled = False

-    End If

-End Sub

-

-<<<<<<
-======================
-UserInfo
->>>>>>
-Attribute VB_Name = "UserInfo"

-Attribute VB_Base = "0{8EB80D4C-3476-421A-A370-6332A07DE509}{A7542905-C9F8-4F39-AD67-B62A88F8F4E6}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Tag = vbOK

-End Sub

-

-Private Sub cbCity_Change()

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_CITY") = Me.cbCity.ListIndex

-        .Calculate

-    End With

-End Sub

-

-Private Sub cbRegion_Change()

-    Dim LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        NewRangeOffsetCol = cbRegion.Value * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).address

-        NewSumRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).address

-        .Calculate

-        .Range("IDX_CITY") = 0

-        cbCity.RowSource = NewCbxRange

-

-    End With

-    cbCity.ListIndex = 0

-End Sub

-

-<<<<<<
-======================
-mREP
->>>>>>
-Attribute VB_Name = "mREP"

-Option Explicit

-

-Sub hwnew()

-    Dim rs As Range

-    Dim re As Object

-    

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    HWReset

-    ReSetREPRecord

-    With Worksheets("REP_QTR")

-        .ClearRepName

-        .Range("REP_QTR_INPUT_DATA").ClearContents

-        .Range("QTR_SEL") = ""

-    End With

-    Worksheets(TITLE_SHEET).Select

-    With Application

-        .DisplayAlerts = False

-        .ThisWorkbook.Save

-        .Quit

-    End With

-End Sub

-

-Function CheckUser() As Boolean

-    Dim objHW() As Long

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    

-    GetHWInfo objHW()

-    i = GetHWRecords(objHW_DB)

-    

-    If i = 0 Then ' First time

-        StoreHWInfo objHW()

-        Worksheets("REP_QTR").Range("QTR_SEL") = ""

-    End If

-    If CheckHWInfo(objHW()) <> True Then

-        CheckUser = False

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    Else

-        CheckUser = SetupUser

-    End If

-End Function

-

-Function SetupUser() As Boolean

-    Dim cUser As tREP

-    Dim idx As Integer

-    Dim dlg_ui As UserInfo

-    

-    Set dlg_ui = New UserInfo

-    

-    cUser = GetREPRecord()

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_REGION") = cUser.Region

-        .Range("IDX_CITY") = cUser.City

-    End With

-        

-    With dlg_ui

-        .cbRegion = cUser.Region

-        .cbCity = cUser.City

-        .tbFName = cUser.FirstName

-        .tbLName = cUser.LastName

-    End With

-    

-    Worksheets(REGS_SHEET).Calculate

-    

-    Dim test_Ok As Boolean

-    test_Ok = False

-    

-    On Error GoTo l1

-

-    Do

-        dlg_ui.Show

-        If dlg_ui.Tag = vbOK Then

-            test_Ok = dlg_ui.tbFName.Value <> "" And dlg_ui.tbLName <> ""

-            If test_Ok Then

-                Exit Do

-            Else

-                MsgBox "Введите имя и фамилию", vbOKOnly, PROGRAM_NAME

-            End If

-        Else

-            Exit Do

-        End If

-    Loop Until False

-l1:

-    If test_Ok Then

-        With cUser

-            .Region = dlg_ui.cbRegion.Value

-            .City = dlg_ui.cbCity.Value

-            .FirstName = dlg_ui.tbFName.Value

-            .LastName = dlg_ui.tbLName.Value

-        End With

-        SetREPRecord cUser

-    Else

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .ThisWorkbook.Saved = True

-            .Quit

-        End With

-    End If

-    SetupUser = test_Ok

-End Function

-

-Sub GetHWInfo(objHW() As Long)

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    i = 1

-    For Each d In dc

-        If d.drivetype = 2 Then ' 2 - HardDisk

-            ReDim Preserve objHW(i)

-            objHW(i) = d.SerialNumber

-            i = i + 1

-        End If

-    Next

-    SortHW objHW

-End Sub

-

-Sub StoreHWInfo(objHW() As Long)

-    UpdateHWRecords objHW

-End Sub

-

-Sub SortHW(objHW() As Long)

-    Dim r As Range

-    Dim rs As Range

-    Dim re As Object

-    Dim i As Integer

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    For i = 1 To UBound(objHW)

-        r = objHW(i)

-        Set r = r.Offset(1, 0)

-    Next i

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).Sort _

-            Key1:=.Range("HW_Number"), _

-            Order1:=xlDescending, _

-            Header:=xlGuess, _

-            OrderCustom:=1, _

-            MatchCase:=False, _

-            Orientation:=xlTopToBottom

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    i = 1

-    Do While r <> ""

-        objHW(i) = r

-        Set r = r.Offset(1, 0)

-        i = i + 1

-    Loop

-End Sub

-

-Function CheckHWInfo(objHW() As Long)

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    CheckHWInfo = False

-        

-    i = GetHWRecords(objHW_DB)

-    If i > 0 Then

-        SortHW objHW_DB

-    End If

-    If UBound(objHW) = UBound(objHW_DB) Then

-        For i = 1 To UBound(objHW)

-            If objHW(i) <> objHW_DB(i) Then

-                Exit Function

-            End If

-        Next i

-        CheckHWInfo = True

-    End If

-End Function

-<<<<<<
-======================
-dbBudget
->>>>>>
-Attribute VB_Name = "dbBudget"

-Option Explicit

-

-Public Type tBUDGET

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    bdgt_NMG As Long

-    bdgt_NFG As Long

-    sale_plan As Long

-End Type

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function GetAll_BDGT_RecordsByLPU_ID(ByRef allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_BDGT_RecordsByLPU_ID = dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection, allBDGT, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function Get_BDGT_Record(ByVal lpu_id As Long, ByVal ent_date As String) As tBUDGET

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    Get_BDGT_Record = dbGet_BDGT_Record(dbConnection, lpu_id, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objBDGT.ID <> 0 then updatre else insert

-Public Sub Insert_BDGT_Record(objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    If objBDGT.id <> 0 Then

-        dbUpdate_BDGT_Record dbConnection, objBDGT

-    Else

-        dbInsert_BDGT_Record dbConnection, objBDGT

-    End If

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Public Sub Delete_BDGT_Record(ByRef objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    dbDelete_BDGT_Record dbConnection, objBDGT

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_BDGT_Record(dbConnection As Object, ByVal lpu_id As Long, ent_date As String) As tBUDGET

-    

-    Dim SQL As String

-    Dim objBDGT As tBUDGET

-    

-    With objBDGT

-        .id = 0

-        .lpu_id = lpu_id

-        .entry_date = ent_date

-        .bdgt_NMG = 0

-        .bdgt_NFG = 0

-        .sale_plan = 0

-    End With

-        

-    

-    SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        With objBDGT

-            .entry_date = dbRecordset("entry_date")

-            .id = dbRecordset("id")

-            .lpu_id = dbRecordset("lpu_id")

-            .bdgt_NFG = dbRecordset("bdgt_NFG")

-            .bdgt_NMG = dbRecordset("bdgt_NMG")

-            .sale_plan = dbRecordset("sale_PLAN")

-        End With

-    End If

-    

-    dbGet_BDGT_Record = objBDGT

-End Function

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection As Object, allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_BDGT_SQL As String

-    Dim getAll_BDGT_SQL As String

-    Dim BDGT_Count As Long

-    BDGT_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_BDGT_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        BDGT_Count = dbRecordset("BDGT_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_BDGT_RecordsbyLPU_ID = BDGT_Count

-    

-    If BDGT_Count > 0 Then

-        'we have records

-        ReDim allBDGT(1 To BDGT_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_BDGT_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpBDGT As tBUDGET

-                 With tmpBDGT

-                    .entry_date = dbRecordset("entry_date")

-                    .id = dbRecordset("id")

-                    .lpu_id = dbRecordset("lpu_id")

-                    .bdgt_NFG = dbRecordset("bdgt_NFG")

-                    .bdgt_NMG = dbRecordset("bdgt_NMG")

-                    .sale_plan = dbRecordset("sale_PLAN")

-                 End With

-                 

-                 allBDGT(index) = tmpBDGT

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbInsert_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "lpu_budget", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    dbRecordset("entry_date") = objBDGT.entry_date

-    dbRecordset("lpu_id") = objBDGT.lpu_id

-    dbRecordset("bdgt_NMG") = objBDGT.bdgt_NMG

-    dbRecordset("bdgt_NFG") = objBDGT.bdgt_NFG

-    dbRecordset("sale_PLAN") = objBDGT.sale_plan

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objBDGT.id = dbRecordset("id")

-  

-End Sub

-

-Public Sub dbUpdate_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu_budget SET " & _

-    "entry_date='" & objBDGT.entry_date & "'," & _

-    "lpu_id=" & objBDGT.lpu_id & "," & _

-    "bdgt_NMG=" & objBDGT.bdgt_NMG & "," & _

-    "bdgt_NFG=" & objBDGT.bdgt_NFG & "," & _

-    "sale_PLAN=" & objBDGT.sale_plan & _

-    " WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-Public Sub dbDelete_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_BDGT_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbDatabase
->>>>>>
-Attribute VB_Name = "dbDatabase"

-Option Explicit

-

-

-Sub dbOpenConnection(dbConnection As Object)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, SQL As String)

-    dbConnection.Execute (SQL)

-End Sub

-

-<<<<<<
-======================
-dbLPU
->>>>>>
-Attribute VB_Name = "dbLPU"

-Option Explicit

-

-Public Type tLPU

-    id As Long

-    rep_id As Long

-    name As String

-    address As String

-    beds As Integer

-End Type

-

-Function Get_LPU_Record(ByVal lpu_id As Long) As tLPU

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_LPU_Record = dbGet_LPU_Record(dbConnection, lpu_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAllLPU(allLPU() As tLPU) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAllLPU = dbGetAllLPU(dbConnection, allLPU)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAllLPUbyQTR(allLPU() As tLPU, ent_date As String) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAllLPUbyQTR = dbGetAllLPUbyQTR(dbConnection, allLPU, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objLPU.id = 0 then insert else update

-Sub Insert_LPU_Record(ByRef objLPU As tLPU)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    If objLPU.id = 0 Then

-        dbInsert_LPU_Record dbConnection, objLPU

-    Else

-        dbUpdate_LPU_Record dbConnection, objLPU

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub Delete_LPU_Record(ByRef objLPU As tLPU)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDelete_LPU_Record dbConnection, objLPU

-    dbCloseConnection dbConnection

-End Sub

-

-Sub Delete_LPU_RecordQTR(ByRef objLPU As tLPU, ent_date As String)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Hir_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Ter_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_ACS_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    

-    dbCloseConnection dbConnection

-    

-End Sub

-

-Function dbGet_LPU_Record(dbConnection As Object, ByVal lpu_id As Long) As tLPU

-    

-    Dim SQL As String

-    Dim objLPU As tLPU

-    

-    objLPU.id = lpu_id

-    objLPU.name = ""

-    objLPU.address = ""

-    

-    SQL = "SELECT * FROM lpu WHERE id=" & lpu_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objLPU.name = dbRecordset("name")

-        objLPU.address = dbRecordset("address")

-        objLPU.rep_id = dbRecordset("rep_id")

-        objLPU.beds = dbRecordset("beds")

-    End If

-    

-    dbGet_LPU_Record = objLPU

-

-End Function

-

-Sub dbInsert_LPU_Record(dbConnection As Object, ByRef objLPU As tLPU)

-  

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu", dbConnection, 2, 2

-    dbRecordset.addnew

-    dbRecordset("name") = objLPU.name

-    dbRecordset("address") = objLPU.address

-    dbRecordset("rep_id") = objLPU.rep_id

-    dbRecordset("beds") = objLPU.beds

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objLPU.id = dbRecordset("id")

-  

-End Sub

-

-Sub dbUpdate_LPU_Record(dbConnection As Object, ByRef objLPU As tLPU)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu SET " & _

-    "name='" & objLPU.name & "'," & _

-    "address='" & objLPU.address & "'," & _

-    "beds=" & objLPU.beds & "," & _

-    "rep_id=" & objLPU.rep_id& & _

-    " WHERE id=" & objLPU.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-

-Function dbGetAllLPU(dbConnection As Object, allLPU() As tLPU) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu"

-    getAll_LPU_SQL = "SELECT * FROM lpu"

-

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAllLPU = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-Function dbGetAllLPUbyQTR(dbConnection As Object, allLPU() As tLPU, ent_date As String) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    Dim where As String

-    where = "WHERE lpu_budget.entry_date like '" & ent_date & "'"

-    

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu_budget " & where

-    

-    getAll_LPU_SQL = "SELECT lpu.id as id, lpu.rep_id as rep_id, lpu.name as name, lpu.address as address, lpu.beds AS beds " & _

-    "FROM lpu, lpu_budget " & where & " AND lpu.id=lpu_budget.lpu_id"

-    

-

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAllLPUbyQTR = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-Sub dbDelete_LPU_Record(dbConnection As Object, ByRef objLPU As tLPU)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu " & _

-    "WHERE id=" & objLPU.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByLPU_ID dbConnection, objLPU.id

-    dbDelete_Hir_RecordsByLPU_ID dbConnection, objLPU.id

-    dbDelete_Ter_RecordsByLPU_ID dbConnection, objLPU.id

-    dbDelete_ACS_RecordsByLPU_ID dbConnection, objLPU.id

-    

-End Sub

-

-Sub dbDelete_LPU_RecordQTR(dbConnection As Object, ByRef objLPU As tLPU, ent_date As String)

-    

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Hir_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Ter_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_ACS_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    

-End Sub

-

-<<<<<<
-======================
-dbREP
->>>>>>
-Attribute VB_Name = "dbREP"

-Option Explicit

-

-Public Type tREP

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function GetREPRecord() As tREP

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetREPRecord = dbGetREPRecord(dbConnection)

-    dbCloseConnection dbConnection

-End Function

-

-Sub SetREPRecord(cUser As tREP)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbSetREPRecord dbConnection, cUser

-    dbCloseConnection dbConnection

-End Sub

-

-Sub ReSetREPRecord()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbReSetREPRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGetREPRecord(dbConnection As Object) As tREP

-    

-    Dim SQL As String

-    Dim objREP As tREP

-    

-    objREP.FirstName = ""

-    objREP.LastName = ""

-    objREP.Region = 0

-    objREP.City = 0

-    SQL = "SELECT firstname, lastname, region, city FROM " & _

-          "rep"

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open SQL, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREP.FirstName = dbRecordset("firstname")

-        objREP.LastName = dbRecordset("lastname")

-        objREP.Region = dbRecordset("region")

-        objREP.City = dbRecordset("city")

-        

-    End If

-    

-    dbGetREPRecord = objREP

-        

-End Function

-

-Public Sub dbSetREPRecord(dbConnection As Object, ByRef objREP As tREP)

-  

-    Dim DeleteSQL As String

-    Dim InsertSQL As String

-    

-    DeleteSQL = "DELETE FROM rep"

-    InsertSQL = "INSERT INTO rep (firstname, lastname, region, city) VALUES (" & _

-    "'" & objREP.FirstName & "', " & _

-    "'" & objREP.LastName & "', " & _

-    objREP.Region & ", " & _

-    objREP.City & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    dbRecordset.Open InsertSQL, dbConnection

-End Sub

-

-Public Sub dbReSetREPRecord(dbConnection As Object)

-  

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM rep"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    CheckWorkBooksArround Wb

-End Sub

-

-

-Sub CheckWorkBooksArround(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If app.Workbooks.Count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKOnly, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-        Exit Sub

-    End If

-

-End Sub

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub SaveExcelState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-        ActiveWorkbook.DisplayDrawingObjects = xlDisplayShapes

-        

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.Count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars(STDBAR_NAME).Visible = False

-End Sub

-

-

-Public Sub RestoreExcelState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars(STDBAR_NAME).Visible = True

-End Sub

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Public Const STDBAR_NAME = "Worksheet Menu Bar"

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Export"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 620

-                        .OnAction = "cmExport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Exit && Restore Excel"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 548

-                        .OnAction = "cmExitRestore"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(flag As Boolean)

-    If flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars(STDBAR_NAME)

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmExport()

-    dbExport

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    Dim dlg As dlgAbout

-    Set dlg = New dlgAbout

-    

-    dlg.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlg.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlg.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlg.Show

-End Sub

-

-Sub cmMail2Support()

-    Dim err_description As String

-    Dim dlg_msg As dlg_Mail

-    Set dlg_msg = New dlg_Mail

-    With dlg_msg

-        .Show

-        If .Tag = vbOK Then

-            ThisWorkbook.Worksheets(VAR_SHEET).Range("ERR_MESSAGE") _

-                = .tbMessage.Text

-            ThisWorkbook.Save

-            ThisWorkbook.SendMail Recipients:="infra@i-rs.ru", Subject:=PROGRAM_NAME & " ver.:" & PROGRAM_VERSION

-            MsgBox "Сообщение об ошибке отправлено. Перезагрузите программу.", vbOKOnly, PROGRAM_NAME

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-    End With

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-'        helppath = "hh.exe " & .Path & "\Telfast.chm"

-'        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub set_work_mode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetupEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-End Sub

-

-Sub cmSetStandaloneMode()

-    set_work_mode

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    Dim dlg As dlgGetPwd

-    rp = common_pwd

-    

-    Set dlg = New dlgGetPwd

-    dlg.edPwd = ""

-    dlg.Show

-    

-    If dlg.edPwd = rp Then

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmHomePage()

-    ThisWorkbook.Worksheets("REP_QTR").Select

-End Sub

-

-Sub cmExitRestore()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = True

-    Application.Quit

-End Sub

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    Dim dlg_prn As dlgPrint

-    

-    Set dlg_prn = New dlgPrint

-    

-    With dlg_prn

-        .cbMainReport = True

-        .cbMainBudget = False

-        .cbSrcData = False

-        .cbAllSheets = False

-    

-        .Show

-    

-        If .Tag = vbCancel Then

-            Exit Sub

-        End If

-    End With

-    

-    Dim PrnIdx As Integer

-    

-    With dlg_prn

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("REP_QTR", "budget", "Final")

-    Case 1111

-        plist = Array("REP_QTR", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("REP_QTR")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Clexane bar"

-Public Const common_pwd As String = "crdjhxtyjr"

-

-

-Sub SetupEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    Wb.Worksheets(TITLE_SHEET).Select

-    With Application

-        .Caption = PROGRAM_NAME & " " & PROGRAM_VERSION

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .SaveExcelState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = False

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Wb.Worksheets(TITLE_SHEET).Select

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-'                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    If cWindow.Type = xlWorkbook Then

-                        cWindow.DisplayHeadings = True

-                    End If

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu True

-        End If

-        With mobjAppState

-            .RestoreExcelState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Worksheets(TITLE_SHEET).Select

-'        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Option Explicit

-

-Sub UpdateHWRecords(objHW() As Long)

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    dbUpdateHWRecords dbConnection, objHW

-    dbCloseConnection dbConnection

-End Sub

-

-Function GetHWRecords(objHW() As Long) As Integer

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    GetHWRecords = dbGetHWRecords(dbConnection, objHW)

-    dbCloseConnection dbConnection

-End Function

-

-Sub HWReset()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbInsertHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    

-    Dim dbRecordset As Object

-    Dim i As Long

-    

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "hw", dbConnection, 2, 2

-    

-    For i = 1 To UBound(objHW)

-        dbRecordset.addnew

-        dbRecordset("num") = objHW(i)

-        dbRecordset.Update

-    Next i

-    

-End Sub

-

-Sub dbUpdateHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    dbDeleteHWRecord dbConnection

-    dbInsertHWRecords dbConnection, objHW

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-dbHir
->>>>>>
-Attribute VB_Name = "dbHir"

-Option Explicit

-

-Public Type tHIRURGIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    operations_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_ambulator_clexan_40mg As Integer

-    patients_ambulator_clexan_20mg As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-    patients_stationar_clexan_40mg As Integer

-    patients_stationar_clexan_20mg As Integer

-End Type

-

-' if objHir.ID <> 0 then updatre else insert

-Sub Insert_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objHir.id <> 0 Then

-        dbUpdate_Hir_Record dbConnection, objHir

-    Else

-        dbInsert_Hir_Record dbConnection, objHir

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Hir_RecordsByLPU_ID(ByRef allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Hir_RecordsByLPU_ID = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, allHir, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Hir_Record dbConnection, objHir

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objHir.ID <> 0 then updatre else insert

-

-Sub dbInsert_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_hir", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objHir

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("operations_per_quarter") = .operations_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_ambulator_clexan_20mg") = .patients_ambulator_clexan_20mg

-        dbRecordset("patients_ambulator_clexan_40mg") = .patients_ambulator_clexan_40mg

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-        dbRecordset("patients_stationar_clexan_20mg") = .patients_stationar_clexan_20mg

-        dbRecordset("patients_stationar_clexan_40mg") = .patients_stationar_clexan_40mg

-        

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objHir.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim UpdateSQL As String

-    

-    With objHir

-        UpdateSQL = "UPDATE lpu_hir SET " & _

-            "entry_date='" & objHir.entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "operations_per_quarter=" & .operations_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_ambulator_clexan_20mg=" & .patients_ambulator_clexan_20mg & "," & _

-            "patients_ambulator_clexan_40mg=" & .patients_ambulator_clexan_40mg & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & "," & _

-            "patients_stationar_clexan_20mg=" & .patients_stationar_clexan_20mg & "," & _

-            "patients_stationar_clexan_40mg=" & .patients_stationar_clexan_40mg & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_Hir_RecordsbyLPU_ID(dbConnection As Object, allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Hir_SQL As String

-    Dim getAll_Hir_SQL As String

-    Dim Hir_Count As Long

-    Hir_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Hir_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Hir_Count = dbRecordset("HIR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Hir_RecordsbyLPU_ID = Hir_Count

-    

-    If Hir_Count > 0 Then

-        'we have records

-        ReDim allHir(1 To Hir_Count)

-        Dim index As Integer

-        index = 1

-        dbRecordset.Open getAll_Hir_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpHir As tHIRURGIA

-                 With tmpHir

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .operations_per_quarter = dbRecordset("operations_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_ambulator_clexan_20mg = dbRecordset("patients_ambulator_clexan_20mg")

-                    .patients_ambulator_clexan_40mg = dbRecordset("patients_ambulator_clexan_40mg")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                    .patients_stationar_clexan_20mg = dbRecordset("patients_stationar_clexan_20mg")

-                    .patients_stationar_clexan_40mg = dbRecordset("patients_stationar_clexan_40mg")

-                 End With

-                 

-                 allHir(index) = tmpHir

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE ID=" & objHir.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Hir_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbTer
->>>>>>
-Attribute VB_Name = "dbTer"

-Option Explicit

-

-Public Type tTERAPIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objTer.ID <> 0 then updatre else insert

-Sub Insert_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objTer.id <> 0 Then

-        dbUpdate_Ter_Record dbConnection, objTer

-    Else

-        dbInsert_Ter_Record dbConnection, objTer

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Ter_RecordsByLPU_ID(ByRef allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Ter_RecordsByLPU_ID = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, allTer, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Ter_Record dbConnection, objTer

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objTer.ID <> 0 then updatre else insert

-

-Sub dbInsert_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_ter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objTer

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("risk_percent") = Double2Str(.risk_percent, 3)

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objTer.id = dbRecordset("ID")

-

-End Sub

-

-Sub test()

-    Dim s As String

-    Dim d As Single

-    d = 1235.6789

-    s = Format(d, "####0,00")

-    MsgBox s

-End Sub

-

-Sub dbUpdate_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim Update_SQL As String

-    

-    With objTer

-        Update_SQL = "UPDATE lpu_ter SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_Ter_RecordsbyLPU_ID(dbConnection As Object, allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Ter_SQL As String

-    Dim getAll_Ter_SQL As String

-    Dim Ter_Count As Long

-    Ter_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Ter_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Ter_Count = dbRecordset("TER_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Ter_RecordsbyLPU_ID = Ter_Count

-    

-    If Ter_Count > 0 Then

-        'we have records

-        ReDim allTer(1 To Ter_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_Ter_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpTer As tTERAPIA

-                 With tmpTer

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 allTer(index) = tmpTer

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE ID=" & objTer.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Ter_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-mLPU_LIST
->>>>>>
-Attribute VB_Name = "mLPU_LIST"

-Option Explicit

-

-Public Const CINP_AREA As String = "B12"

-Public Const CLPU_NAME As Integer = 0

-Public Const CLPU_NAME1 As Integer = 1

-Public Const CLPU_NAME2 As Integer = 2

-Public Const CLPU_ID As Integer = 3

-Public Const CLPU_BEDS As Integer = 4

-Public Const CLPU_NFG As Integer = 5

-Public Const CLPU_NMG As Integer = 6

-Public Const CLPU_HIR As Integer = 7

-Public Const CLPU_TER As Integer = 8

-Public Const CLPU_CAR As Integer = 9

-Public Const CLPU_FACT As Integer = 10

-Public Const CLPU_PLAN As Integer = 11

-Public Const CLPU_PAT_LPU As Integer = 16

-Public Const CLPU_BDGT As Integer = 17

-Public Const CLPU_PAT_ALL As Integer = 16

-

-

-

-Sub EditLPU(cLPU As tLPU, ent_date As String)

-    Dim del_request As Integer

-    Dim allLPU() As tLPU

-    Dim lpu_count As Integer

-    Dim i As Integer

-    Dim tmp_LPU_List As Range

-    Dim tmp_LPU_List_Addr As String

-    Dim r_end As Range

-    Dim dlg As Dlg_lpu_card

-    

-    Set dlg = New Dlg_lpu_card

-    

-    lpu_count = GetAllLPU(allLPU)

-    With Worksheets(VAR_SHEET)

-        Set tmp_LPU_List = .Range("tmp_LPU_List")

-        Set r_end = .Range(tmp_LPU_List, tmp_LPU_List.End(xlDown))

-        Set r_end = .Range(r_end, r_end.End(xlToRight))

-        .Range(tmp_LPU_List, r_end).ClearContents

-    End With

-        

-    If lpu_count <> 0 Then

-        dlg.cbxLPU_List_Enable.Enabled = True

-        For i = 1 To UBound(allLPU)

-            tmp_LPU_List.Cells(i, 1) = allLPU(i).name

-            tmp_LPU_List.Cells(i, 2) = allLPU(i).address

-            tmp_LPU_List.Cells(i, 3) = allLPU(i).beds

-            tmp_LPU_List.Cells(i, 4) = allLPU(i).id

-        Next i

-    Else

-        dlg.cbxLPU_List_Enable.Enabled = False

-    End If

-    

-    tmp_LPU_List_Addr = Worksheets(VAR_SHEET).name & "!" & _

-            Worksheets(VAR_SHEET).Range(tmp_LPU_List, tmp_LPU_List.End(xlDown)).address

-

-    With dlg

-        .cbLPU_List.RowSource = tmp_LPU_List_Addr

-        .cbLPU_List.ListIndex = 0

-        .cbxLPU_List_Enable = False

-        .cbLPU_List.Enabled = False

-        If cLPU.id <> 0 Then

-            .cbxLPU_List_Enable.Enabled = False

-        Else

-            If lpu_count <> 0 Then

-                .cbxLPU_List_Enable.Enabled = True

-            Else

-                .cbxLPU_List_Enable.Enabled = False

-            End If

-        End If

-        .tb_lpu_name.Text = cLPU.name

-        .tb_lpu_address.Text = cLPU.address

-        .tbBedsCount = cLPU.beds

-

-        .Tag = vbCancel

-    End With

-    

-    dlg.Show

-    

-    If Not IsNumeric(dlg.Tag) Then

-        Exit Sub

-    End If

-    

-    If dlg.Tag = vbOK Then

-        Dim n As Variant

-        Dim test As Integer

-        test = 0

-        n = dlg.tbBedsCount.Value

-        If Not IsNumeric(n) Then

-            test = 1

-        Else

-            If n = 0 Then

-                test = 1

-            End If

-        End If

-        If test = 0 Then

-            

-            cLPU.name = dlg.tb_lpu_name.Text

-            cLPU.address = dlg.tb_lpu_address.Text

-            cLPU.beds = dlg.tbBedsCount.Value

-                                    

-            If cLPU.name = "" Or cLPU.address = "" Then

-                test = 2

-            End If

-        End If

-        Select Case test

-            Case 0

-                If dlg.cbxLPU_List_Enable.Value = True Then

-                    cLPU.id = tmp_LPU_List.Cells(dlg.cbLPU_List.ListIndex + 1, 4)

-                End If

-                Insert_LPU_Record cLPU

-                ' Проверить наличие данных для ЛПУ в квартале

-                Dim bdgt As tBUDGET

-                bdgt = Get_BDGT_Record(cLPU.id, ent_date)

-                ' Записи нет: создать пустую запись в lpu_budget

-                If bdgt.id = 0 Then

-                    bdgt.lpu_id = cLPU.id

-                    bdgt.entry_date = ent_date

-                    Insert_BDGT_Record bdgt

-                End If

-            Case 1

-                MsgBox "Коечная мощьность измеряется числом более чем 1!", vbOKOnly, PROGRAM_NAME

-            Case 2

-                MsgBox "Наименование и адрес ЛПУ не должны быть пустыми!", vbOKOnly, PROGRAM_NAME

-        End Select

-    End If

-End Sub

-

-Sub Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-

-End Sub

-

-Sub Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btLPU_DEL_IT()

-    Dim cLPU As tLPU

-    Dim ent_date As String

-    Dim delete_all As Integer

-    Dim dlg_del As dlg_LPU_delete

-    

-    With Worksheets("LPU_LIST")

-        ent_date = .Range("ent_date")

-        cLPU.id = .getCurrentLPU_ID()

-    End With

-    

-    If cLPU.id = 0 Then

-        MsgBox "Укажите удаляемый объект", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    cLPU = Get_LPU_Record(cLPU.id)

-    

-    Set dlg_del = New dlg_LPU_delete

-    With dlg_del

-        .chbDeleteQTR.Value = True

-        .chbDeleteAll.Value = False

-        .lComment = ent_date & ": Удаление ЛПУ '" _

-        & cLPU.name & "', расположенного по адресу:" _

-        & cLPU.address & "."

-        .Show

-        

-        If .Tag = vbOK Then

-            If .chbDeleteAll.Value Then

-                delete_all = _

-                    MsgBox("Все записи об ЛПУ с именем '" & cLPU.name & _

-                    "' будут удалены навсегда.", vbOK, PROGRAM_NAME)

-                If delete_all = vbOK Then

-                    Delete_LPU_Record cLPU

-                End If

-            Else

-                Delete_LPU_RecordQTR cLPU, ent_date

-            End If

-        End If

-    End With

-    

-    With ThisWorkbook

-        .Worksheets(TITLE_SHEET).Select

-        .Worksheets("LPU_LIST").Select

-    End With

-End Sub

-

-Sub btLPU_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Activate

-End Sub

-

-

-Sub btLPU_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim lpu_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("QTR_ACTION").Value

-    With Worksheets("LPU_LIST")

-        ent_date = .getEnt_date()

-        

-    

-        lpu_id = .getCurrentLPU_ID

-        If lpu_id <> 0 And i = 1 Then

-            lpu_id = 0

-        End If

-        If lpu_id = 0 Then

-            i = 1

-        End If

-        Select Case i

-            Case 1, 6

-                .SelectLPU_NAME lpu_id, ent_date

-                .Range("JUMP") = ""

-            Case 2

-                If lpu_id <> 0 Then

-                    .SelectLPU_BDGT lpu_id, ent_date

-                    .Range("JUMP") = "LPU_BDGT"

-                End If

-            Case 3

-                If lpu_id <> 0 Then

-                    .SelectLPU_HIR lpu_id, ent_date

-                    .Range("JUMP") = "LPU_CLSN_HIR"

-                End If

-            Case 4

-                If lpu_id <> 0 Then

-                    .SelectLPU_TER lpu_id, ent_date

-                    .Range("JUMP") = "LPU_CLSN_TER"

-                End If

-            Case 5

-                If lpu_id <> 0 Then

-                    .SelectLPU_C_ACS lpu_id, ent_date

-                    .Range("JUMP") = "LPU_CLSN_C_ACS"

-                End If

-        End Select

-    End With

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-dbQTR
->>>>>>
-Attribute VB_Name = "dbQTR"

-Option Explicit

-

-Public Type tQTR

-    id As Long

-    entry_date As String

-    rep_id As Long

-    sale_plan As Long

-    ClxnH20mg As Long

-    ClxnH40mg As Long

-    ClxnT40mg As Long

-    ClxnC_IM As Long

-    ClxnC_ACS As Long

-End Type

-

-

-Function GetLastQTR_fromDB() As String

-    Dim dbConnection As Object

-    Dim getCount_QTR_SQL As String

-    Dim getLast_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter"

-    getLast_QTR_SQL = "SELECT MAX(entry_date) as ent_date FROM quarter"

-    

-    dbOpenConnection dbConnection

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    If QTR_Count > 0 Then

-        'we have records

-        dbRecordset.Open getLast_QTR_SQL, dbConnection

-        getLast_QTR_SQL = dbRecordset("ent_date")

-    Else

-        getLast_QTR_SQL = ""

-    End If

-    

-    GetLastQTR_fromDB = getLast_QTR_SQL

-    dbCloseConnection dbConnection

-End Function

-

-Sub Insert_QTR_Record(ByRef objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objQTR.id <> 0 Then

-        dbUpdate_QTR_Record dbConnection, objQTR

-    Else

-        dbInsert_QTR_Record dbConnection, objQTR

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-Function Get_QTR_Record(ent_date As String) As tQTR

-    Dim dbConnection As Object

-    Dim allQTR() As tQTR

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    i = dbGetAll_QTR_Records(dbConnection, allQTR, ent_date)

-    If i <> 0 Then

-        Get_QTR_Record = allQTR(1)

-    End If

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTR_Records(ByRef All_QTR() As tQTR, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_QTR_Records = dbGetAll_QTR_Records(dbConnection, All_QTR, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_QTR_Record(ByRef objQTR As tQTR)

-    Dim dbConnection As Object

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_QTR_Record dbConnection, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objQTR.ID <> 0 then updatre else insert

-Sub dbInsert_QTR_Record(dbConnection As Object, ByRef objQTR As tQTR)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "quarter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objQTR

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("sale_plan") = .sale_plan

-        dbRecordset("rep_id") = .rep_id

-        dbRecordset("ClxnH20mg") = .ClxnH20mg

-        dbRecordset("ClxnH40mg") = .ClxnH40mg

-        dbRecordset("ClxnT40mg") = .ClxnT40mg

-        dbRecordset("ClxnC_IM") = .ClxnC_IM

-        dbRecordset("ClxnC_ACS") = .ClxnC_ACS

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objQTR.id = dbRecordset("id")

-

-End Sub

-

-Sub dbUpdate_QTR_Record(dbConnection As Object, ByRef objQTR As tQTR)

-    Dim Update_SQL As String

-    

-    With objQTR

-        Update_SQL = "UPDATE quarter SET " & _

-            "entry_date='" & .entry_date & "'" & "," & _

-            "rep_id=" & .rep_id & "," & _

-            "sale_plan=" & .sale_plan & "," & _

-            "ClxnH20mg=" & .ClxnH20mg & "," & _

-            "ClxnH40mg=" & .ClxnH40mg & "," & _

-            "ClxnT40mg=" & .ClxnT40mg & "," & _

-            "ClxnC_IM=" & .ClxnC_IM & "," & _

-            "ClxnC_ACS=" & .ClxnC_ACS & _

-            " WHERE id=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if ent_date = % then all_records

-Function dbGetAll_QTR_Records(dbConnection As Object, All_QTR() As tQTR, ent_date As String) As Integer

-    

-    Dim getCount_QTR_SQL As String

-    Dim getAll_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter WHERE entry_date like '" & ent_date & "'"

-    getAll_QTR_SQL = "SELECT * FROM quarter WHERE entry_date like '" & ent_date & "' ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_QTR_Records = QTR_Count

-    

-    If QTR_Count > 0 Then

-        'we have records

-        ReDim All_QTR(1 To QTR_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTR_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTR As tQTR

-                 With tmp_QTR

-                    .entry_date = dbRecordset("entry_date")

-                    .rep_id = dbRecordset("rep_id")

-                    .sale_plan = dbRecordset("sale_plan")

-                    .ClxnH20mg = dbRecordset("ClxnH20mg")

-                    .ClxnH40mg = dbRecordset("ClxnH40mg")

-                    .ClxnT40mg = dbRecordset("ClxnT40mg")

-                    .ClxnC_IM = dbRecordset("ClxnC_IM")

-                    .ClxnC_ACS = dbRecordset("ClxnC_ACS")

-                    .id = dbRecordset("id")

-                 End With

-                 

-                 All_QTR(index) = tmp_QTR

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_QTR_Record(dbConnection As Object, ByRef objQTR As tQTR)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM quarter " & _

-    "WHERE id=" & objQTR.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByQTR dbConnection, objQTR.entry_date

-    dbDelete_Hir_RecordsByQTR dbConnection, objQTR.entry_date

-    dbDelete_Ter_RecordsByQTR dbConnection, objQTR.entry_date

-    dbDelete_ACS_RecordsByQTR dbConnection, objQTR.entry_date

-       

-End Sub

-<<<<<<
-======================
-cdbQTR
->>>>>>
-Attribute VB_Name = "cdbQTR"

-Option Explicit

-

-Public Type tQTR_COMMON

-    qtr As tQTR

-    i_lcd As Long           ' число ЛПУ в СПИСКЕ

-    lcd() As tLPU_COMMON    ' список ЛПУ

-    c_beds As Long          ' сумма коек

-    c_bdgt_NFG As Long      ' общий бюджет на НФГ

-    c_bdgt_NMG As Long      ' общий бюджет на НМГ

-    c_bdgt_LPU As Long      ' общий бюджет на гепарины

-    c_sale_PLAN As Long     ' план продаж репа

-    c_sale_ALL As Long      ' продажи

-    c_sale_HIR As Long      ' в хирургии

-    c_sale_TER  As Long     ' в терапии

-    c_sale_CRD  As Long     ' в кардиологии

-    c_pat_HIR   As Long     ' пациенты

-    c_pat_TER   As Long     '

-    c_pat_CRD   As Long     '

-    c_pat_ALL   As Long     '

-    c_pat_LPU   As Long     ' Всего операций

-End Type

-

-Function Get_QTR_CommonList(ByRef qcd() As tQTR_COMMON) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_QTR_CommonList = dbGet_QTR_CommonList(dbConnection, qcd)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_CommonList(dbConnection As Object, ByRef qcd() As tQTR_COMMON) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim allQTR() As tQTR

-    i = dbGetAll_QTR_Records(dbConnection, allQTR, "%")

-    dbGet_QTR_CommonList = i

-    If i > 0 Then

-        ReDim qcd(i)

-        For i = 1 To UBound(allQTR)

-            With qcd(i)

-                .qtr = allQTR(i)

-                .c_beds = 0

-                .c_bdgt_NFG = 0

-                .c_bdgt_NMG = 0

-                .c_bdgt_LPU = 0

-                .c_sale_PLAN = 0

-                .c_pat_HIR = 0

-                .c_pat_TER = 0

-                .c_pat_CRD = 0

-                .c_pat_ALL = 0

-                .c_sale_HIR = 0

-                .c_sale_TER = 0

-                .c_sale_CRD = 0

-                .c_sale_ALL = 0

-                .c_pat_LPU = 0

-                

-                j = dbGet_LPU_CommonQTR(dbConnection, .lcd, .qtr)

-                .i_lcd = j

-                If j > 0 Then

-                    For j = 1 To UBound(.lcd)

-                        .c_beds = .c_beds + .lcd(j).lpu.beds

-                        .c_bdgt_NFG = .c_bdgt_NFG + .lcd(j).bdgt.bdgt_NFG

-                        .c_bdgt_NMG = .c_bdgt_NMG + .lcd(j).bdgt.bdgt_NMG

-                        .c_bdgt_LPU = .c_bdgt_LPU + .lcd(j).bdgt_LPU

-                        .c_sale_PLAN = .c_sale_PLAN + .lcd(j).bdgt.sale_plan

-                        .c_pat_HIR = .c_pat_HIR + .lcd(j).pat_HIR

-                        .c_pat_TER = .c_pat_TER + .lcd(j).pat_TER

-                        .c_pat_CRD = .c_pat_CRD + .lcd(j).pat_CRD

-                        .c_pat_ALL = .c_pat_ALL + .lcd(j).pat_ALL

-                        .c_sale_HIR = .c_sale_HIR + .lcd(j).sale_HIR

-                        .c_sale_TER = .c_sale_TER + .lcd(j).sale_TER

-                        .c_sale_CRD = .c_sale_CRD + .lcd(j).sale_CRD

-                        .c_sale_ALL = .c_sale_ALL + .lcd(j).sale_ALL

-                        .c_pat_LPU = .c_pat_LPU + .lcd(j).pat_LPU

-                    Next j

-                    

-                End If

-            End With

-        Next i

-    End If

-End Function

-

-Function GetLastQtr() As String

-    Dim s As String

-    Dim r As Range

-    Set r = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Do While r.Cells(1, 1) <> ""

-        s = r.Cells(1, 1)

-        Set r = r.Cells.Offset(1, 0)

-    Loop

-    GetLastQtr = s

-End Function

-

-Function GetNextQTR(ent_date As String) As String

-    Dim rd As Range

-    Dim idx As Integer

-    Dim b As Variant

-    Dim dlg As dlg_newQTR

-    Set dlg = New dlg_newQTR

-    

-    On Error GoTo l_exit

-    If ent_date = "" Then

-        Dim ir As Variant

-        idx = 0

-        dlg.Show

-        b = dlg.Tag

-            

-        If IsNumeric(b) Then

-            GetNextQTR = dlg.cbQTR

-        Else

-            GetNextQTR = ""

-        End If

-    Else

-        Set rd = Worksheets(VAR_SHEET).Range("Date_Lst")

-        idx = WorksheetFunction.Match(ent_date, rd, 0)

-        GetNextQTR = WorksheetFunction.index(rd, idx + 1, 1)

-    End If

-l_exit:

-End Function

-<<<<<<
-======================
-mRestView
->>>>>>
-Attribute VB_Name = "mRestView"

-Option Explicit

-

-Sub xlRestoreView()

-Attribute xlRestoreView.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute xlRestoreView.VB_ProcData.VB_Invoke_Func = " \n14"

-    With Application

-        .CommandBars("Standard").Visible = True

-        .CommandBars("Formatting").Visible = True

-        .DisplayFormulaBar = True

-        .DisplayStatusBar = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = True

-        .EditDirectlyInCell = True

-    End With

-End Sub

-<<<<<<
-======================
-dlg_newQTR
->>>>>>
-Attribute VB_Name = "dlg_newQTR"

-Attribute VB_Base = "0{2FC04B4C-EB99-433E-ACDB-A920D02B9B5B}{777B85CC-ADE3-4188-94C8-9E07DA8B5076}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mDec2TS
->>>>>>
-Attribute VB_Name = "mDec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-CHRT_LPU_BBL
->>>>>>
-Attribute VB_Name = "CHRT_LPU_BBL"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Unprotect

-    Range("view_key") = True

-    On Error Resume Next

-    ChangeLabels

-    Range("A1").Select

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Unprotect

-    Dim s As String

-    s = Range("ret_addr")

-    Protect UserInterfaceOnly:=True

-    Wks_select (s)

-End Sub

-

-Sub BCLabelChng_Click()

-    Unprotect

-    If Range("view_key") Then

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать названия"

-    Else

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать объемы"

-    End If

-    Range("view_key") = Not Range("view_key")

-    ChangeLabels

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub ChangeLabels()

-    Dim i As Integer

-    Dim offset_text As Integer

-    Dim src As Range

-    Set src = Range("CHRT_BBL_DATA")

-    

-    offset_text = 3

-    If Range("view_key") Then

-        offset_text = 4

-    End If

-    

-    On Error GoTo ExitLabel

-    

-    With ChartObjects(1).Chart

-        With .SeriesCollection(1)

-            For i = 1 To .Points.Count

-                On Error Resume Next

-                .Points(i).DataLabel.Characters.Text = Format(src.Cells(i, offset_text))

-            Next i

-        End With

-    End With

-ExitLabel:

-End Sub

-

-<<<<<<
-======================
-CHRT_PAT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PAT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-<<<<<<
-======================
-CHRT_PAT_LPU
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_nextQTR
->>>>>>
-Attribute VB_Name = "dlg_nextQTR"

-Attribute VB_Base = "0{3F7D7D75-90F6-4829-9E24-CA5391BB2A03}{A1A0F296-0D28-4123-8E38-82FA6EE6F2EF}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-

-<<<<<<
-======================
-cdbLPU
->>>>>>
-Attribute VB_Name = "cdbLPU"

-Option Explicit

-

-Public Type tLPU_COMMON

-    lpu As tLPU

-    bdgt As tBUDGET

-    i_hir As Long

-    hir() As tHIRURGIA

-    i_ter As Long

-    ter() As tTERAPIA

-    i_ACS As Long

-    ACS() As tACS

-    bdgt_LPU As Long

-    sale_HIR As Long

-    sale_TER As Long

-    sale_CRD As Long

-    sale_ALL As Long

-    pat_HIR As Long

-    pat_TER As Long

-    pat_CRD As Long

-    pat_ALL As Long     ' Сумма всех пациентов на клексане

-    pat_LPU As Long     ' Число потенциальных пациентов для продаж клексана

-End Type

-

-Function Get_LPU_CommonQTR(ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    Get_LPU_CommonQTR = dbGet_LPU_CommonQTR(dbConnection, lcd, objQTR)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_CommonQTR(dbConnection As Object, ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    i = dbGetAllLPUbyQTR(dbConnection, allLPU, objQTR.entry_date)

-    dbGet_LPU_CommonQTR = i

-    If i > 0 Then

-        ReDim lcd(i)

-        For i = 1 To UBound(allLPU)

-            dbGet_LPU_Common dbConnection, lcd(i), allLPU(i), objQTR

-        Next i

-    End If

-End Function

-

-Sub Get_LPU_Common(ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    dbGet_LPU_Common dbConnection, lcd, cLPU, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbGet_LPU_Common(dbConnection As Object, ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-

-    lcd.lpu = cLPU

-    lcd.bdgt = dbGet_BDGT_Record(dbConnection, cLPU.id, objQTR.entry_date)

-    lcd.i_hir = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, lcd.hir, cLPU.id, objQTR.entry_date)

-    lcd.i_ter = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, lcd.ter, cLPU.id, objQTR.entry_date)

-    lcd.i_ACS = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, lcd.ACS, cLPU.id, objQTR.entry_date)

-    With lcd

-        .bdgt_LPU = .bdgt.bdgt_NFG + .bdgt.bdgt_NMG

-        .pat_LPU = 0

-        If .i_hir > 0 Then

-            .pat_HIR = .hir(1).patients_ambulator_clexan + .hir(1).patients_stationar_clexan

-            .sale_HIR = objQTR.ClxnH20mg * (.hir(1).patients_ambulator_clexan_20mg + .hir(1).patients_stationar_clexan_20mg)

-            .sale_HIR = .sale_HIR + objQTR.ClxnH40mg * (.hir(1).patients_ambulator_clexan_40mg + .hir(1).patients_stationar_clexan_40mg)

-            .pat_LPU = .pat_LPU + .hir(1).operations_per_quarter

-        End If

-        If .i_ter > 0 Then

-            .pat_TER = .ter(1).patients_ambulator_clexan + .ter(1).patients_stationar_clexan

-            .sale_TER = .pat_TER * objQTR.ClxnT40mg

-            .pat_LPU = .pat_LPU + .ter(1).patients_per_quarter

-        End If

-        If .i_ACS > 0 Then

-            .pat_CRD = .ACS(1).patients_stationar_clexan

-            .sale_CRD = .pat_CRD * objQTR.ClxnC_ACS

-            .pat_LPU = .pat_LPU + .ACS(1).patients_per_quarter

-        End If

-        .pat_ALL = .pat_HIR + .pat_TER + .pat_CRD

-        .sale_ALL = .sale_HIR + .sale_TER + .sale_CRD

-    End With

-End Sub

-

-<<<<<<
-======================
-CHRT_PIE
->>>>>>
-Attribute VB_Name = "CHRT_PIE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-   

-    Unprotect

-    On Error Resume Next

-    Range("P5:Q24").Sort _

-        Key1:=Range("Q5"), _

-        Order1:=xlDescending, _

-        Header:=xlGuess, _

-        OrderCustom:=1, _

-        MatchCase:=False, _

-        Orientation:=xlTopToBottom

-        

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PLN_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PLN_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_BDGT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_BDGT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_LPU_delete
->>>>>>
-Attribute VB_Name = "dlg_LPU_delete"

-Attribute VB_Base = "0{91AE5FA0-01C7-4C10-9E5F-D1D2DDF29401}{5726592A-BC0A-4E79-A963-35D354045716}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlg_Mail
->>>>>>
-Attribute VB_Name = "dlg_Mail"

-Attribute VB_Base = "0{FB055133-927F-41FF-BC90-442833A40591}{11BCAB43-1EDD-440B-AB0E-20CD6E42E11A}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dbREP_id
->>>>>>
-Attribute VB_Name = "dbREP_id"

-Public Type tID_REP

-    id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Public Type tID_REP_COMMON

-    id_rep As tID_REP

-    i_qtr As Long

-    qtrs As tQTR_COMMON

-End Type

-<<<<<<
-======================
-cdbExport
->>>>>>
-Attribute VB_Name = "cdbExport"

-Option Explicit

-

-Function GetDBSN() As String

-    Dim n As Long

-    Randomize Timer

-    n = Int((100000000 - 1000000 + 1) * Rnd + 1000000)

-    GetDBSN = Dec2ThirtySix(n)

-End Function

-

-Sub dbExport()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim last_qtr As String

-    

-    On Error GoTo ErrHandler

-    

-    last_qtr = GetLastQTR_fromDB

-    If last_qtr = "" Then

-        MsgBox "Нет записей в базе данных. Экспорт невозможен.", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & last_qtr & "_" & GetDBSN() & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Данные экспортированы в файл:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для передачи", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-Exit Sub

-

-ErrHandler:

-    If err.number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-<<<<<<
-======================
-mRegs
->>>>>>
-Attribute VB_Name = "mRegs"

-Option Explicit

-

-Function GetRegionName(idx As Integer) As String

-    GetRegionName = Worksheets(REGS_SHEET).Range("LST_REGIONS").Cells(idx + 1, 1).Text

-End Function

-

-Function GetCityName(idx_reg As Integer, idx_city As Integer) As String

-    GetCityName = Worksheets(REGS_SHEET).Range("CITY_TABLES").Offset(idx_city + 1, idx_reg * 2).Text

-End Function

-

-Sub t()

-    Dim r As Integer

-    Dim c As Integer

-    Dim s As String

-    

-    r = 3

-    c = 3

-    s = GetRegionName(r)

-    s = s & ", " & GetCityName(r, c)

-    MsgBox s

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Private Sub Workbook_Open()

-    xlRestoreView

-End Sub

-

-Sub xlRestoreView()

-    Application.CommandBars("Standard").Visible = True

-    Application.CommandBars("Formatting").Visible = True

-    Application.DisplayFormulaBar = True

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Function GetRegion(idx As Integer) As String

-    GetRegion = Range("LST_REGIONS").Offset(i, 0)

-End Function

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    Call CleanUp

-End Sub

-

-Private Sub Workbook_Open()

-    Call CreateFormBar

-    frmFaceID.Show

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-'Global variables hold preious choices

-'for begining and ending FaceID numbers

-Public glbLastFirstID As Long

-Public glbLastLastID As Long

-

-

-Function CBShowButtonFaceIDs(lngIDStart As Long, _

-                             lngIDStop As Long)

-    ' This procedure creates a toolbar with buttons that display the

-    ' images associated with the values starting at lngIDStart and

-    ' ending at lngIDStop.

-    

-    Dim cbrNewToolbar   As CommandBar

-    Dim cmdNewButton    As CommandBarButton

-    Dim intCntr         As Integer

-    

-    ' Delete existing ShowFaceIds toolbar if it exists.

-    On Error Resume Next

-    Application.CommandBars("ShowFaceIds").Delete

-    frmFaceID.MousePointer = fmMousePointerHourGlass

-    ' Create a new toolbar.

-    Set cbrNewToolbar = Application.CommandBars.Add _

-        (Name:="ShowFaceIds", temporary:=True)

-    

-    ' Create a new button with an image matching the FaceId property value

-    ' indicated by intCntr.

-    For intCntr = lngIDStart To lngIDStop

-        Set cmdNewButton = cbrNewToolbar.Controls.Add(Type:=msoControlButton)

-        With cmdNewButton

-            ' Setting the FaceId property value specifies the appearance

-            ' but not the functionality of the button.

-            .FaceId = intCntr

-            .Caption = "FaceId = " & intCntr

-        End With

-    Next intCntr

-    

-    ' Show the images on the toolbar.

-    With cbrNewToolbar

-        .Width = 600

-        .Left = 100

-        .Top = 200

-        .Visible = True

-    End With

-    frmFaceID.MousePointer = fmMousePointerDefault

-End Function

-

-

-

-Public Function Validate()

-Dim lngTempNumber As Long

-

-'Procedure to check data entered by user

-With frmFaceID

-'If the first number requested < last number

-'then reverse them and rationalize

-'display next time form opens

-    If .txtFirstID Or .txtLastID > 0 Then

-        If CLng(.txtFirstID) > CLng(.txtLastID) Then

-           lngTempNumber = .txtFirstID

-           .txtFirstID = .txtLastID

-           .txtLastID = lngTempNumber

-         glbLastFirstID = .txtFirstID

-         glbLastLastID = .txtLastID

-        End If

- 'Only allow 200 FaceIDs per operation

- 'Call procedure to create FaceID values

- 'Take form out of memory

- 

-        If (.txtLastID - .txtFirstID) <= 200 Then

-            Call CBShowButtonFaceIDs(.txtFirstID, .txtLastID)

-            Unload frmFaceID

-        Else

-            MsgBox "Please request less than 200 FaceID's ", , "FaceID Number Finder"

-        End If

-    Else

-            .txtFirstID.SetFocus

-    End If

-End With

-End Function

-

-Public Function CleanUp()

-    On Error Resume Next

-   

-    Application.CommandBars("ShowFaceIds").Delete

-    Application.CommandBars("ShowForm").Delete

-      

-        

-End Function

-

-Public Function CreateFormBar()

-    Dim cmdBar As CommandBar

-    Dim btnForm As CommandBarButton

-'Delete the object if it already exists

-    On Error Resume Next

-    Application.CommandBars("ShowForm").Delete

-'Set the commandbar object variable

-    Set cmdBar = Application.CommandBars.Add

-        cmdBar.Name = "ShowForm"

-'Add a button

-    With cmdBar.Controls

-        

-        Set btnForm = .Add(msoControlButton)

-        

-    End With

-'Set the new button's properties

-    With btnForm

-        .Style = msoButtonIconAndCaption

-        .Caption = "Show FaceId Finder Form"

-        .FaceId = 2104

-        .OnAction = "OpenForm"

-        .TooltipText = "Show FaceID Form"

-    End With

-  ' Made visible in the form terminate event

-

-End Function

-

-Public Function OpenForm()

-'OnAction event procedure of ShowForm toolbar

-    frmFaceID.Show

-End Function

-

-

-<<<<<<
-======================
-frmFaceID
->>>>>>
-Attribute VB_Name = "frmFaceID"

-Attribute VB_Base = "0{5F1D3654-0CF0-11D2-B619-00AA00BBB974}{5F1D3641-0CF0-11D2-B619-00AA00BBB974}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-

-Private Sub cmdFaceId_Click()

-  

-  Dim strDefaultStatus As String

- 'Set up global variables with current requested values

-    glbLastFirstID = txtFirstID

-    glbLastLastID = txtLastID

- 'Detect current status bar value

- 'Set status bar message while FaceId's are generated

-    strDefaultStatus = Application.DisplayStatusBar

-    Application.DisplayStatusBar = True

-    Application.StatusBar = "Working on FaceID display please wait"

-    

-'Call validation procedure

-   

-    Call Validate

- 'Put Status bar back as it was

-    Application.DisplayStatusBar = False

-    Application.StatusBar = strDefaultStatus

-End Sub

-

-

-Private Sub txtFirstID_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)

-   'Test for non numeric entry then cancel or convert to long

-    If IsNumeric(txtFirstID) = False Then

-       txtFirstID = ""

-       Cancel = True

-    Else

-        txtFirstID = CLng(txtFirstID)

-    End If

-    

-End Sub

-

-

-Private Sub txtLastID_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)

-    'Test for non numeric entry then cancel or convert to long

-    If IsNumeric(txtLastID) = False Then

-       txtLastID = ""

-       Cancel = True

-    Else

-        txtLastID = CLng(txtLastID)

-    End If

-    

-End Sub

-

-Private Sub UserForm_Activate()

- 'Set up form with last requested values

- 'Make toolbar not visible

- On Error Resume Next

-    txtFirstID = glbLastFirstID

-    txtLastID = glbLastLastID

-    Application.CommandBars("ShowForm").Visible = False

-End Sub

-

-

-

-Private Sub UserForm_Terminate()

-    'Show toolbar if form is unloaded in

-    'Validate procedure of if X is clicked

-    Application.CommandBars("ShowForm").Visible = True

-End Sub

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Workbook_Activate()

-    Worksheets("Home").Select

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub ExportCopy()

-    ChartObjects("Chart 1").CopyPicture xlScreen, xlBitmap

-End Sub

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub ExportCopy()

-    Range("C4:G30").CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub ExportCopy()

-    Range("D44:H59").CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-PPExport
->>>>>>
-Attribute VB_Name = "PPExport"

-Option Explicit

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Sub ViewReport()

-    Dim ReportDoc As PowerPoint.Presentation

-    Set ReportDoc = GetObject(GetWBPath(ThisWorkbook.FullName) + "report.ppt")

-    ReportDoc.Application.Visible = True

-End Sub

-

-Sub CreateReportSlide(ReportDoc As PowerPoint.Presentation, Title As String)

-    Dim ReportPage As PowerPoint.Slide

-    

-    Set ReportPage = ReportDoc.Slides.Add(ReportDoc.Slides.Count + 1, ppLayoutBlank)

-    ReportPage.Shapes.Paste

-    ReportPage.Shapes.AddLabel(msoTextOrientationHorizontal, 20, 20, 640, 40) _

-      .TextFrame.TextRange.Text = Title

-End Sub

-

-Sub CreateReport()

-    Dim ReportApp As PowerPoint.Application

-    Dim ReportDoc As PowerPoint.Presentation

-    

-    Set ReportApp = CreateObject("PowerPoint.Application")

-    Set ReportDoc = ReportApp.Presentations.Add

-    

-    Dim i As Integer

-    For i = 1 To 4

-        ThisWorkbook.Worksheets("Sheet" + Format(i)).ExportCopy

-        CreateReportSlide ReportDoc, "Create slide name #" + Format(i)

-    Next i

-    

-    ReportDoc.SaveAs GetWBPath(ThisWorkbook.FullName) + "report"

-    ReportApp.Quit

-End Sub

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub ExportCopy()

-    ChartObjects("Chart 1").CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Unprotect "password"

-    ThisWorkbook.Save

-End Sub

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Protect password:="password"

-    Worksheets("Calc").Protect password:="password", userInterfaceonly:=True

-    Worksheets("Calc").Select

-    Worksheets("Calc").Range("A7").Select

-End Sub

-<<<<<<
-======================
-Calc
->>>>>>
-Attribute VB_Name = "Calc"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Sub SelectAll()

-    Dim Sh As Shape

-    For Each Sh In Shapes

-        If InStr(1, Sh.Name, "Check") Then

-            Sh.Select

-            Selection.Value = xlOn

-        End If

-    Next Sh

-    Range("A7").Select

-End Sub

-

-Sub ClearAll()

-    Dim Sh As Shape

-    For Each Sh In Shapes

-        If InStr(1, Sh.Name, "Check") Then

-            Sh.Select

-            Selection.Value = xlOff

-        End If

-    Next Sh

-    Range("A7").Select

-    Worksheets("Data").Range("K2") = 1

-    Worksheets("Calc").Range("E58") = 1

-End Sub

-

-<<<<<<
-======================
-Data
->>>>>>
-Attribute VB_Name = "Data"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-GCircle
->>>>>>
-Attribute VB_Name = "GCircle"

-Const MIN_FLOAT As Double = 0.00001

-Const PI As Double = 3.14159265358979

-Const PI_div_2 As Double = PI / 2

-

-

-Function arctg(dx As Double, dy As Double) As Double

-        If Abs(dx) < MIN_FLOAT Then

-            If Abs(dy) < MIN_FLOAT Then

-                arctg = 0#

-            Else

-                If dy > 0# Then

-                    arctg = PI_div_2

-                Else

-                    arctg = 3# * PI_div_2

-                End If

-            End If

-        Else

-            If Abs(dy) < MIN_FLOAT Then

-                If dx > 0# Then

-                    arctg = 0#

-                Else

-                    arctg = PI

-                End If

-            Else

-                If dx > 0# Then

-                    If dy > 0# Then

-                        arctg = Atn(dy / dx)

-                    Else

-                        arctg = 2# * PI + Atn(dy / dx)

-                    End If

-                Else

-                    arctg = PI + Atn(dy / dx)

-                End If

-            End If

-        End If

-End Function

-

-

-Sub test_line()

-    Dim stp As Range

-    Dim wksname As Range

-    Dim wks As Worksheet

-    Dim r As Range

-    Dim st As Range

-    

-    Set wksname = Worksheets("~test").Range("WksList")

-    

-    ClearTable Worksheets("~test").Range("WksList").Offset(2, 0)

-    While wksname <> ""

-        Set stp = Worksheets("~test").Range("Steps")

-        Set wks = Worksheets(wksname.Value2)

-        Set r = wksname.Offset(2, 0)

-        While stp <> ""

-            wks.Range("Steps") = stp

-            wks.Select

-            makeData wks

-            Set st = wks.Range(wks.Range("Table")).Offset(-2, 5)

-            r.Offset(0, 0) = st / wks.Range("Ro")

-            r.Offset(0, 0).NumberFormat = "0.000%; [Red]-0.000%"

-            Set st = st.Offset(-1, 0)

-            r.Offset(0, 1) = Abs(st / wks.Range("Ro"))

-            r.Offset(0, 1).NumberFormat = st.NumberFormat

-            Set st = st.Offset(-1, 2)

-            r.Offset(0, 2) = st

-            r.Offset(0, 2).NumberFormat = st.NumberFormat

-            Set r = r.Offset(1, 0)

-            Set stp = stp.Offset(1, 0)

-        Wend

-        Set wksname = wksname.Offset(0, 3)

-    Wend

-    Worksheets("~test").Select

-End Sub

-

-Sub recalc_all()

-    Dim wks As Worksheet

-    Dim stp As Integer

-    stp = Worksheets("~common").Range("Steps")

-    For Each wks In Worksheets

-        If Left(wks.Name, 1) <> "~" Then

-            wks.Select

-            wks.Range("Steps") = stp

-            makeData wks

-        End If

-    Next wks

-    Worksheets("~common").Select

-    make_common

-End Sub

-

-Sub make_common()

-    Dim wks As Worksheet

-    Dim r As Range

-    Dim st As Range

-    Worksheets("~common").Select

-    Set r = Range(Range("Table"))

-    ClearTable r

-    For Each wks In Worksheets

-        If Left(wks.Name, 1) <> "~" Then

-            r = wks.Name

-            ActiveSheet.Hyperlinks.Add Anchor:=r, Address:="", SubAddress:= _

-            "'" & wks.Name & "'!A1", TextToDisplay:=wks.Name

-

-            r.Offset(0, 1) = wks.Range("Segs")

-            r.Offset(0, 2) = wks.Range("Steps")

-            Set st = wks.Range(wks.Range("Table")).Offset(-5, 5)

-            For i = 0 To 3

-                r.Offset(0, 3 + i) = st.Offset(i, 0)

-                r.Offset(0, 3 + i).NumberFormat = st.Offset(i, 0).NumberFormat

-            Next i

-            For i = 0 To 3

-                r.Offset(0, 7 + i) = st.Offset(i, 3)

-                r.Offset(0, 7 + i).NumberFormat = st.Offset(i, 3).NumberFormat

-            Next i

-            For i = 2 To 3

-                r.Offset(0, 9 + i) = st.Offset(i, 5)

-                r.Offset(0, 9 + i).NumberFormat = st.Offset(i, 5).NumberFormat

-            Next i

-            

-            Set r = r.Offset(1, 0)

-            

-        End If

-    Next wks

-    Range("B4").Select

-    Range(Selection, Selection.End(xlToRight)).Select

-    Range(Selection, Selection.End(xlDown)).Select

-    Selection.Sort Key1:=Range("h5"), Order1:=xlAscending, Header:=xlGuess, _

-        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

-    Range("a1").Select

-

-End Sub

-

-Function GetCirclePoint(r As Range, T As Double) As Double

-    With ActiveSheet

-        Dim seg_count, seg_number As Integer

-        Dim ctrl As Range

-        seg_count = Range("Segs")

-        seg_number = 0

-        

-        Select Case seg_count

-            Case 1:

-                Set ctrl = r

-            Case 2:

-                If Abs(T - 1) < 0.000001 Then

-                    T = 1

-                    seg_number = 1

-                Else

-                    seg_number = Int(seg_count * T)

-                    T = T * seg_count - seg_number

-                End If

-                Set ctrl = r.Offset(seg_number * 2, 0)

-            Case 4:

-                If Abs(T - 1) < 0.000001 Then

-                    T = 1

-                    seg_number = 3

-                Else

-                    seg_number = Int(seg_count * T)

-                    T = T * seg_count - seg_number

-                End If

-                Select Case seg_number

-                    Case 0:

-                        Set ctrl = r

-                    Case 1:

-                        Set ctrl = r.Offset(0, 3)

-                    Case 2:

-                        Set ctrl = r.Offset(2, 0)

-                    Case 3:

-                        Set ctrl = r.Offset(2, 3)

-                End Select

-        End Select

-        

-        If seg_count > 1 Then

-        End If

-        GetCirclePoint = GetBezierPath(ctrl, T)

-    End With

-End Function

-

-Private Function GetBezierPath(r As Range, T As Double) As Double

-    Dim LAST_IDX As Integer

-    

-    LAST_IDX = r.Cells.Count

-    

-    Dim pnts() As Double

-    ReDim pnts(LAST_IDX)

-    

-    Dim i As Integer

-    Dim j As Integer

-    Dim k As Integer

-    For i = 1 To LAST_IDX

-        pnts(i) = r(i)

-    Next i

-    i = LAST_IDX

-    Do While i > 1

-        j = LAST_IDX

-        k = i

-        Do While k > 1

-            pnts(j) = pnts(j) * T + pnts(j - 1) * (1 - T)

-            j = j - 1

-            k = k - 1

-        Loop

-        i = i - 1

-    Loop

-    GetBezierPath = pnts(LAST_IDX)

-End Function

-

-Sub makeCircleData()

-    makeData ActiveSheet

-End Sub

-

-Sub ClearTable(r As Range)

-        r.Select

-        r.Worksheet.Range(Selection, Selection.End(xlToRight)).Select

-        r.Worksheet.Range(Selection, Selection.End(xlDown)).Select

-        Selection.ClearContents

-End Sub

-

-Sub makeData(wks As Worksheet)

-    With wks

-    

-        wks.EnableCalculation = False

-        

-        Dim cutoffs As Integer

-        Dim step_b, sb As Double

-        Dim step_g, sg As Double

-        Dim s As String

-        Dim rs As Range

-        Dim st As Range

-        Dim astep As Range

-                

-        cutoffs = wks.Range("Steps")

-        step_g = 360 / cutoffs

-        step_b = step_g / 360

-        

-        Set rs = wks.Range(wks.Range("Table"))

-        Set st = rs.Offset(-5, 5)

-        Set astep = wks.Range("A_Step")

-        

-        ClearTable rs

-    

-        sg = 0 + step_g

-        sb = 0 + step_b

-        For i = 1 To cutoffs

-            rs.Offset(0, 0) = sg

-            rs.Offset(0, 0).NumberFormat = "0.00"

-            rs.Offset(0, 1) = sb

-            rs.Offset(0, 1).NumberFormat = "0.000_ ;[Red]-0.000 "

-            

-            rs.Offset(0, 2).FormulaLocal = "=GetCirclePoint(Xs0;" + rs.Offset(0, 1).Address + ")"

-            rs.Offset(0, 2).NumberFormat = "0.000_ ;[Red]-0.000 "

-            

-            rs.Offset(0, 3).FormulaLocal = "=GetCirclePoint(Ys0;" + rs.Offset(0, 1).Address + ")"

-            rs.Offset(0, 3).NumberFormat = "0.000_ ;[Red]-0.000 "

-            

-            rs.Offset(0, 4).FormulaLocal = "=SQRT((Xo - " + rs.Offset(0, 2).Address + ")^2 + (Yo - " + rs.Offset(0, 3).Address + ")^2)"

-            rs.Offset(0, 4).NumberFormat = "0.000_ ;[Red]-0.000 "

-            

-            rs.Offset(0, 5).FormulaLocal = "=Ro - " + rs.Offset(0, 4).Address

-            rs.Offset(0, 5).NumberFormat = "0.000_ ;[Red]-0.000 "

-            

-            If i <> 1 Then

-                rs.Offset(0, 6).FormulaLocal = "=SQRT((" _

-                        + rs.Offset(0, 2).Address _

-                        + "-" _

-                        + rs.Offset(-1, 2).Address _

-                        + ")^2 + (" _

-                        + rs.Offset(0, 3).Address _

-                        + "-" _

-                        + rs.Offset(-1, 3).Address _

-                        + ")^2)"

-            Else

-                rs.Offset(0, 6).FormulaLocal = "=SQRT((" _

-                        + rs.Offset(0, 2).Address _

-                        + "-" _

-                        + rs.Offset(-2, 2).Address _

-                        + ")^2 + (" _

-                        + rs.Offset(0, 3).Address _

-                        + "-" _

-                        + rs.Offset(-2, 3).Address _

-                        + ")^2)"

-            End If

-            rs.Offset(0, 6).NumberFormat = "0.000_ ;[Red]-0.000 "

-            

-            rs.Offset(0, 7).FormulaLocal = "=(" _

-                + rs.Offset(0, 6).Address _

-                + "-" _

-                + st.Offset(2, 1).Address _

-                + ") / " _

-                + st.Offset(2, 1).Address

-            rs.Offset(0, 7).NumberFormat = "0.000%; [Red]-0.000%"

-            rs.Offset(0, 8).FormulaLocal = "=ABS(" _

-                + rs.Offset(0, 7).Address _

-                + ")"

-            rs.Offset(0, 8).NumberFormat = "0.000%; [Red]-0.000%"

-            

-            If i < cutoffs Then

-                rs.Offset(0, 9).FormulaLocal = "=arctg(" _

-                    + rs.Offset(0, 2).Address _

-                    + "-Xo;" _

-                    + rs.Offset(0, 3).Address _

-                    + "-Yo)*180/Pi() - " _

-                    + rs.Offset(0, 0).Address

-            Else

-                rs.Offset(0, 9) = 0

-            End If

-            rs.Offset(0, 9).NumberFormat = "0.000; [Red]-0.000"

-            rs.Offset(0, 10).FormulaLocal = "=ABS(" _

-                + rs.Offset(0, 9).Address _

-                + ")/" _

-                + "360" 'astep.Address

-            rs.Offset(0, 10).NumberFormat = "0.000%; [Red]-0.000%"

-            Set rs = rs.Offset(1, 0)

-            sg = sg + step_g

-            sb = sb + step_b

-        Next i

-        

-        Set rs = wks.Range(wks.Range("Table")).Offset(0, 5)

-        For i = 1 To 6

-        

-            rs.Select

-            

-            wks.Range(Selection, Selection.End(xlDown)).Select

-            

-            st.Offset(0, 0).FormulaLocal = "=min(" + Selection.Address + ")"

-            st.Offset(0, 0).NumberFormat = Selection.NumberFormat

-            st.Offset(1, 0).FormulaLocal = "=max(" + Selection.Address + ")"

-            st.Offset(1, 0).NumberFormat = Selection.NumberFormat

-            st.Offset(2, 0).FormulaLocal = "=average(" + Selection.Address + ")"

-            st.Offset(2, 0).NumberFormat = Selection.NumberFormat

-            st.Offset(3, 0).FormulaLocal = "=" + st.Offset(1, 0).Address + "-" + st.Offset(0, 0).Address

-            st.Offset(3, 0).NumberFormat = Selection.NumberFormat

-            Set rs = rs.Offset(0, 1)

-            Set st = st.Offset(0, 1)

-        Next i

-        wks.Range("A1").Select

-        wks.EnableCalculation = True

-        wks.Calculate

-    End With

-End Sub

-

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet19
->>>>>>
-Attribute VB_Name = "Sheet19"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const RAW_DATA_SHEET As String = "Raw_data"

-Public Const RAW_DATA_RANGE As String = "B3"

-Public Const RAW_DATA_RANGE_COL As Integer = 2

-Public Const RAW_DATA_RANGE_COL_S As String = "B"

-Public Const RAW_DATA_RANGE_ROW As Integer = 3

-

-' Fields indexes in IN_TABLES

-Public Const IN_ACCOUNT_IDX As Integer = 0

-Public Const IN_TYPE_IDX As Integer = 1

-Public Const IN_STORAGE_IDX As Integer = 2

-Public Const IN_LAST_IDX As Integer = 3

-Public Const IN_IP_IDX As Integer = 4

-

-' Report lists names

-Public Const STA_USER_FEM As String = "Female_Users"

-Public Const STA_USER_MAL As String = "Male_Users"

-Public Const STA_USER_SML As String = "SendMail_Users"

-Public Const STA_USER_TOT As String = "Total_Users"

-Public Const BAD_USER_FEM As String = "Female_Bad_Users"

-Public Const BAD_USER_MAL As String = "Male_Bad_Users"

-Public Const BAD_USER_SML As String = "SendMail_Bad_Users"

-Public Const MAINTAIN_USER_LST As String = "STICKLY"

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mStatUser
->>>>>>
-Attribute VB_Name = "mStatUser"

-Option Explicit

-' Fields indexes in STAT_TABLES

-Public Const BAD_HEADER_RANGE As String = "A2"

-Public Const BAD_DATA_RANGE As String = "A3"

-Public Const BAD_DATA_RANGE_COL As Integer = 1

-Public Const BAD_DATA_RANGE_ROW As Integer = 3

-

-Public Const STA_DATA_RANGE As String = "A3"

-Public Const STA_DATA_RANGE_COL As Integer = 1

-Public Const STA_DATA_RANGE_ROW As Integer = 3

-

-Public Const STA_DATE_IDX As Integer = 0

-Public Const STA_TIME_IDX As Integer = 1

-

-Public Const STA_USERS_IDX As Integer = STA_TIME_IDX + 1

-Public Const STA_NEW_USERS_IDX As Integer = STA_TIME_IDX + 2

-Public Const STA_BAD_USERS_IDX As Integer = STA_TIME_IDX + 3

-

-Public Const STA_DISK_COMMON_IDX As Integer = STA_BAD_USERS_IDX + 1

-Public Const STA_DISK_MAX_IDX As Integer = STA_BAD_USERS_IDX + 2

-Public Const STA_DISK_AVR_IDX As Integer = STA_BAD_USERS_IDX + 3

-Public Const STA_DISK_BAD_MAX_IDX As Integer = STA_BAD_USERS_IDX + 4

-Public Const STA_DISK_BAD_AVR_IDX As Integer = STA_BAD_USERS_IDX + 5

-

-Public Const STA_DISK_HIS_0_IDX As Integer = STA_DISK_BAD_AVR_IDX + 1

-Public Const STA_DISK_HIS_30_IDX As Integer = STA_DISK_BAD_AVR_IDX + 2

-Public Const STA_DISK_HIS_100_IDX As Integer = STA_DISK_BAD_AVR_IDX + 3

-Public Const STA_DISK_HIS_300_IDX As Integer = STA_DISK_BAD_AVR_IDX + 4

-Public Const STA_DISK_HIS_1000_IDX As Integer = STA_DISK_BAD_AVR_IDX + 5

-Public Const STA_DISK_HIS_3000_IDX As Integer = STA_DISK_BAD_AVR_IDX + 6

-Public Const STA_DISK_HIS_BIG_IDX As Integer = STA_DISK_BAD_AVR_IDX + 7

-

-Public Const STA_TIME_HIS_0D_IDX As Integer = STA_DISK_HIS_BIG_IDX + 1

-Public Const STA_TIME_HIS_3D_IDX As Integer = STA_DISK_HIS_BIG_IDX + 2

-Public Const STA_TIME_HIS_1W_IDX As Integer = STA_DISK_HIS_BIG_IDX + 3

-Public Const STA_TIME_HIS_2W_IDX As Integer = STA_DISK_HIS_BIG_IDX + 4

-Public Const STA_TIME_HIS_1M_IDX As Integer = STA_DISK_HIS_BIG_IDX + 5

-Public Const STA_TIME_HIS_2M_IDX As Integer = STA_DISK_HIS_BIG_IDX + 6

-

-Private Const DISK_RANG_0 As Integer = 0

-Private Const DISK_RANG_30 As Integer = 30

-Private Const DISK_RANG_100 As Integer = 100

-Private Const DISK_RANG_300 As Integer = 300

-Private Const DISK_RANG_1000 As Integer = 1000

-Private Const DISK_RANG_3000 As Integer = 3000

-

-Private Const TIME_RANG_0D As Integer = 0

-Private Const TIME_RANG_3D As Integer = 2

-Private Const TIME_RANG_1W As Integer = 7

-Private Const TIME_RANG_2W As Integer = 14

-Private Const TIME_RANG_1M As Integer = 30

-Private Const TIME_RANG_2M As Integer = 60

-

-Private Const FEMALE_GOOD_RANGE_COL As Integer = "2"

-Private Const MALE_GOOD_RANGE_COL As Integer = "3"

-Private Const SENDMAIL_GOOD_RANGE_COL As Integer = "4"

-Private Const GOOD_RANGE_ROW As Integer = "3"

-

-' Common data types

-Type TUserStatData

-    theDate As Date

-    theTime As Date

-    lUsersCount As Long

-    lUsersNew As Long

-    lUsersBad As Long

-    lDiskTotal As Long

-    lDiskMax As Long

-    lDiskAvr As Long

-    lDiskBad As Long

-    lDiskBadAvr As Long

-    lDisk_0 As Long

-    lDisk_30 As Long

-    lDisk_100 As Long

-    lDisk_300 As Long

-    lDisk_1000 As Long

-    lDisk_3000 As Long

-    lDisk_Big As Long

-    lTime_0D As Long

-    lTime_3D As Long

-    lTime_1W As Long

-    lTime_2W As Long

-    lTime_1M As Long

-    lTime_2M As Long

-End Type

-

-Type TBadUser

-    theName As String

-    lLast As Date

-    lDiskSize As Long

-End Type

-

-' Comon data declaration

-Public UserStat As TUserStatData

-Public BadUserList() As TBadUser

-

-Sub GetUserStat(ws As Worksheet, us As TUserStatData, bu() As TBadUser, DOMEN_Idx As String)

-    Dim Location, GoodList As Range

-    Dim GoodRangeCollounm As Integer

-    

-    

-    With us

-        .theDate = Now

-        .theTime = Now

-        .lUsersCount = 0

-        .lUsersNew = 0

-        .lUsersBad = 0

-        .lDiskTotal = 0

-        .lDiskMax = 0

-        .lDiskAvr = 0

-        .lDiskBad = 0

-        .lDiskBadAvr = 0

-        .lDisk_0 = 0

-        .lDisk_30 = 0

-        .lDisk_100 = 0

-        .lDisk_300 = 0

-        .lDisk_1000 = 0

-        .lDisk_3000 = 0

-        .lDisk_Big = 0

-        .lTime_0D = 0

-        .lTime_3D = 0

-        .lTime_1W = 0

-        .lTime_2W = 0

-        .lTime_1M = 0

-        .lTime_2M = 0

-    End With

-    

-    With ws

-        us.lUsersCount = GetLinesCount(.Range(RAW_DATA_RANGE).Offset(1, 0))

-        Set Location = .Range( _

-            .Cells(RAW_DATA_RANGE_ROW + 1, RAW_DATA_RANGE_COL + IN_STORAGE_IDX), _

-            .Cells(RAW_DATA_RANGE_ROW + us.lUsersCount, RAW_DATA_RANGE_COL + IN_STORAGE_IDX) _

-        )

-        Dim c, d As Variant

-        

-        For Each c In Location

-            us.lDiskTotal = us.lDiskTotal + c.Value

-            If us.lDiskMax < c.Value Then

-                us.lDiskMax = c.Value

-            End If

-            If c.Value = DISK_RANG_0 Then

-                us.lDisk_0 = us.lDisk_0 + 1

-            Else

-                If c.Value < DISK_RANG_30 Then

-                    us.lDisk_30 = us.lDisk_30 + 1

-                Else

-                    If c.Value < DISK_RANG_100 Then

-                        us.lDisk_100 = us.lDisk_100 + 1

-                    Else

-                        If c.Value < DISK_RANG_300 Then

-                            us.lDisk_300 = us.lDisk_300 + 1

-                        Else

-                            If c.Value < DISK_RANG_1000 Then

-                                us.lDisk_1000 = us.lDisk_1000 + 1

-                            Else

-                                If c.Value < DISK_RANG_3000 Then

-                                    us.lDisk_3000 = us.lDisk_3000 + 1

-                                Else

-                                    us.lDisk_Big = us.lDisk_Big + 1

-                                End If

-                            End If

-                        End If

-                    End If

-                End If

-            End If

-        Next c

-        us.lDiskAvr = us.lDiskTotal / us.lUsersCount

-        

-        Set Location = .Range( _

-            .Cells(RAW_DATA_RANGE_ROW + 1, RAW_DATA_RANGE_COL + IN_LAST_IDX), _

-            .Cells(RAW_DATA_RANGE_ROW + us.lUsersCount, RAW_DATA_RANGE_COL + IN_LAST_IDX) _

-        )

-        

-        Dim HowLong As Integer

-        ReDim bu(us.lUsersCount) As TBadUser

-        Dim i_bad As Long

-        i_bad = LBound(bu)

-                

-        If DOMEN_Idx = STA_USER_SML Then

-            GoodRangeCollounm = SENDMAIL_GOOD_RANGE_COL

-        Else

-            If DOMEN_Idx = STA_USER_MAL Then

-                GoodRangeCollounm = MALE_GOOD_RANGE_COL

-            Else

-                GoodRangeCollounm = FEMALE_GOOD_RANGE_COL

-            End If

-        End If

-        

-        With Worksheets(MAINTAIN_USER_LST)

-            Set GoodList = .Range( _

-                .Cells(GOOD_RANGE_ROW, GoodRangeCollounm), _

-                .Cells(GOOD_RANGE_ROW, GoodRangeCollounm) _

-            )

-        End With

-        

-        For Each c In Location

-            If IsDate(c.Value) Then

-                HowLong = -DateDiff("d", Now, c.Value)

-                If HowLong = TIME_RANG_0D Then

-                    us.lTime_0D = us.lTime_0D + 1

-                Else

-                    If HowLong <= TIME_RANG_3D Then

-                        us.lTime_3D = us.lTime_3D + 1

-                    Else

-                        If HowLong <= TIME_RANG_1W Then

-                            us.lTime_1W = us.lTime_1W + 1

-                        Else

-                            If HowLong <= TIME_RANG_2W Then

-                                us.lTime_2W = us.lTime_2W + 1

-                            Else

-                                If HowLong <= TIME_RANG_1M Then

-                                    us.lTime_1M = us.lTime_1M + 1

-                                Else

-                                    If HowLong <= TIME_RANG_2M Then

-                                        us.lTime_2M = us.lTime_2M + 1

-                                    Else

-                                        If Not NameInGoodUserList(GoodList, c.Offset(0, -3).Value) Then

-                                            us.lUsersBad = us.lUsersBad + 1

-                                            bu(i_bad).theName = c.Offset(0, -3).Value

-                                            bu(i_bad).lLast = c.Value

-                                            bu(i_bad).lDiskSize = c.Offset(0, -1).Value

-                                            us.lDiskBad = us.lDiskBad + c.Offset(0, -1).Value

-                                            i_bad = i_bad + 1

-                                        End If

-                                    End If

-                                End If

-                            End If

-                        End If

-                    End If

-                End If

-            Else

-                us.lTime_0D = us.lTime_0D + 1

-            End If

-        Next c

-        ReDim bad_users(i_bad)

-        

-        us.lDiskBadAvr = us.lDiskBad / i_bad

-        

-    End With ' with ws

-End Sub

-

-Sub WriteResultUsers(ws As Worksheet, us As TUserStatData)

-    Dim curline As Integer

-    Dim Location As Range

-    With ws

-        Set Location = .Range( _

-                .Cells(STA_DATA_RANGE_ROW, STA_DATA_RANGE_COL), _

-                .Cells(STA_DATA_RANGE_ROW, STA_DATA_RANGE_COL) _

-            )

-        curline = GetLinesCount(Location)

-        With .Range( _

-                .Cells(STA_DATA_RANGE_ROW + curline, STA_DATA_RANGE_COL), _

-                .Cells(STA_DATA_RANGE_ROW + curline, STA_DATA_RANGE_COL) _

-            )

-            .Offset(0, STA_DATE_IDX).Value = us.theDate

-            .Offset(0, STA_DATE_IDX).NumberFormat = "dd-mmm-yy"

-            

-            .Offset(0, STA_TIME_IDX).Value = us.theTime

-            .Offset(0, STA_TIME_IDX).NumberFormat = "hh:mm"

-            

-            .Offset(0, STA_USERS_IDX).Value = us.lUsersCount

-            If curline > 0 Then

-                us.lUsersNew = us.lUsersCount - .Offset(-1, STA_USERS_IDX).Value

-            End If

-            .Offset(0, STA_NEW_USERS_IDX).Value = us.lUsersNew

-            .Offset(0, STA_BAD_USERS_IDX).Value = us.lUsersBad

-            .Offset(0, STA_DISK_COMMON_IDX).Value = us.lDiskTotal

-            .Offset(0, STA_DISK_MAX_IDX).Value = us.lDiskMax

-            .Offset(0, STA_DISK_AVR_IDX).Value = us.lDiskAvr

-            .Offset(0, STA_DISK_BAD_MAX_IDX).Value = us.lDiskBad

-            .Offset(0, STA_DISK_BAD_AVR_IDX).Value = us.lDiskBadAvr

-            .Offset(0, STA_DISK_HIS_0_IDX).Value = us.lDisk_0

-            .Offset(0, STA_DISK_HIS_30_IDX).Value = us.lDisk_30

-            .Offset(0, STA_DISK_HIS_100_IDX).Value = us.lDisk_100

-            .Offset(0, STA_DISK_HIS_300_IDX).Value = us.lDisk_300

-            .Offset(0, STA_DISK_HIS_1000_IDX).Value = us.lDisk_1000

-            .Offset(0, STA_DISK_HIS_3000_IDX).Value = us.lDisk_3000

-            .Offset(0, STA_DISK_HIS_BIG_IDX).Value = us.lDisk_Big

-            .Offset(0, STA_TIME_HIS_0D_IDX).Value = us.lTime_0D

-            .Offset(0, STA_TIME_HIS_3D_IDX).Value = us.lTime_3D

-            .Offset(0, STA_TIME_HIS_1W_IDX).Value = us.lTime_1W

-            .Offset(0, STA_TIME_HIS_2W_IDX).Value = us.lTime_2W

-            .Offset(0, STA_TIME_HIS_1M_IDX).Value = us.lTime_1M

-            .Offset(0, STA_TIME_HIS_2M_IDX).Value = us.lTime_2M

-        End With 'With .Range( _

-

-    End With 'With ws

-End Sub

-

-Sub WriteCommonResult(ws As Worksheet)

-    Dim LastLine As Integer

-    Dim Location As Range

-    Set Location = ws.Range(STA_DATA_RANGE)

-    LastLine = GetLinesCount(Location)

-    Set Location = Location.Offset(LastLine, 0)

-    While Not IsEmpty(Location.Offset(-1, 0))

-        Location.Fo = Location.Offset(-1, 0)

-        ' ws.Paste

-        Set Location = Location.Offset(0, 1)

-    Wend

-End Sub

-

-Sub WriteBadUsers(ws As Worksheet, bad_users() As TBadUser)

-    Dim Location As Range

-    

-    With ws

-        .Parent.Application.DisplayAlerts = False

-        .Range( _

-            .Cells(BAD_DATA_RANGE_ROW, BAD_DATA_RANGE_COL), _

-            .Cells(65535, BAD_DATA_RANGE_COL + 3) _

-        ).ClearContents

-

-        Set Location = .Range( _

-                .Cells(BAD_DATA_RANGE_ROW, BAD_DATA_RANGE_COL), _

-                .Cells(BAD_DATA_RANGE_ROW, BAD_DATA_RANGE_COL) _

-            )

-        

-        Dim i As Integer

-        

-        For i = LBound(bad_users()) To UBound(bad_users())

-            If bad_users(i).theName = "" Then

-                Exit For

-            End If

-            Location.Offset(i, 0).Value = bad_users(i).theName

-            Location.Offset(i, 1).Value = bad_users(i).lLast

-            Location.Offset(i, 1).NumberFormat = "dd-mmm-yy"

-            Location.Offset(i, 2).Value = bad_users(i).lDiskSize

-        Next i

-        

-        Set Location = .Range( _

-                .Cells(BAD_DATA_RANGE_ROW - 1, BAD_DATA_RANGE_COL), _

-                .Cells(BAD_DATA_RANGE_ROW + i, BAD_DATA_RANGE_COL + 2) _

-            )

-        

-        Location.Sort _

-            Key1:=.Range(BAD_HEADER_RANGE).Offset(0, 1), _

-            Order1:=xlAscending, _

-            Header:=xlGuess, _

-            OrderCustom:=1, _

-            MatchCase:=False, _

-            Orientation:=xlTopToBottom

-        

-        ReDim bad_users(0)

-    End With

-End Sub

-

-Function NameInGoodUserList(GoodList As Range, uname As String) As Boolean

-    Dim i, maxLines As Integer

-    maxLines = GetLinesCount(GoodList) + 1

-    

-    NameInGoodUserList = False

-    

-    For i = 0 To maxLines

-        If GoodList.Offset(i, 0).Value = uname Then

-            NameInGoodUserList = True

-            Exit For

-        End If

-    Next i

-    

-End Function

-<<<<<<
-======================
-mFileOpen
->>>>>>
-Attribute VB_Name = "mFileOpen"

-Option Explicit

-

-Public Const MAX_LOAD_DATA_LINES As Integer = 16000

-

-Public Const MSG_FILE_INVALID_FORMAT As String = "Неверный формат файла"

-

-Public Const FUNCRES_FILE_OK As Integer = 0

-Public Const FUNCRES_FILE_VERY_SMALL As Integer = -1

-Public Const FUNCRES_FILE_INVALID_FORMAT As Integer = -2

-

-Public Const HOME_PAGE_NAME As String = "HomePage"

-Public Const DOMAIN_NAME_IDX As String = "D5"

-

-Public Const FEMALE_NAME_IDX As String = "1"

-Public Const MALE_NAME_IDX As String = "2"

-Public Const SMAIL_NAME_IDX As String = "3"

-

-Public Const FEMALE_FILE_NAME_ADR As String = "E3"

-Public Const MALE_FILE_NAME_ADR As String = "E5"

-Public Const SMAIL_FILE_NAME_ADR As String = "E7"

-

-

-

-Function UpdateHistoryFromFile(wb As Workbook, FileToOpen As String) As Integer

-    Dim DestRangeName As String

-    Dim ResultLength As Integer

-    Dim Location As Range

-

-    Dim SingleFileLine As String

-    Dim FileHandler As Integer

-    Dim i, row_idx As Integer

-    

-    UpdateHistoryFromFile = FUNCRES_FILE_INVALID_FORMAT

-    With wb

-'        .Application.ScreenUpdating = False

-        With .Worksheets(RAW_DATA_SHEET)

-            'Clear table include temp area

-            .Parent.Application.DisplayAlerts = False

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW - 1, RAW_DATA_RANGE_COL - 1), _

-                .Cells(65535, RAW_DATA_RANGE_COL + IN_IP_IDX + 3) _

-            ).ClearContents

-            Set Location = .Range(RAW_DATA_RANGE).Offset(-1, 0)

-            

-            ' Reading data from file

-            FileHandler = FreeFile

-            row_idx = 0

-            Open FileToOpen For Input As #FileHandler

-            Do While Not EOF(FileHandler) And row_idx < MAX_LOAD_DATA_LINES

-                Line Input #FileHandler, SingleFileLine

-                .Range(RAW_DATA_RANGE).Offset(row_idx, 0) = SingleFileLine

-                row_idx = row_idx + 1

-            Loop

-            Close #FileHandler

-            

-            ' Parsing data

-            DestRangeName = "=" & RAW_DATA_SHEET & "!" & RAW_DATA_RANGE & _

-                            ":" & RAW_DATA_RANGE_COL_S & (RAW_DATA_RANGE_ROW + row_idx)

-            ResultLength = row_idx

-            

-            .Range(DestRangeName).TextToColumns _

-                Destination:=.Range(DestRangeName), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=True, _

-                Semicolon:=True, _

-                Comma:=True, _

-                Space:=True, _

-                Other:=False, _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 1), _

-                                Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1))

-            

-            .Parent.Application.DisplayAlerts = True

-            Dim CurrentDate As String

-            Dim RawData As Range

-            

-            Set RawData = .Range(RAW_DATA_RANGE)

-            

-            row_idx = row_idx - 1

-            Set Location = .Range( _

-                .Cells(RAW_DATA_RANGE_ROW + 1, RAW_DATA_RANGE_COL + IN_STORAGE_IDX), _

-                .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + IN_STORAGE_IDX) _

-            )

-            Dim c As Variant

-            For Each c In Location

-                c.Value = ChkAccountSize(c.Value)

-            Next c

-        End With ' With .Worksheets(RAW_DATA_SHEET)

-    End With ' wb

-    UpdateHistoryFromFile = FUNCRES_FILE_OK

-End Function

-

-Function ChkAccountSize(strSize As String) As Long

-    Dim ChNum As Long

-    ChNum = InStr(strSize, "K")

-    If ChNum = 0 Then

-        ChNum = InStr(strSize, "M")

-        If ChNum = 0 Then

-            ChkAccountSize = Val(strSize) / 1024

-        Else

-            strSize = Left(strSize, ChNum - 1)

-            ChNum = Val(strSize)

-            ChkAccountSize = ChNum * 1024

-        End If

-    Else

-        strSize = Left(strSize, ChNum - 1)

-        ChNum = Val(strSize)

-        ChkAccountSize = ChNum

-    End If

-End Function

-

-Sub SetFile()

-    Dim FileToOpen As Variant

-    Dim DomainIdx As Range

-    Dim WSh As Worksheet

-    

-    FileToOpen = Application.GetOpenFilename("Text Files (*.txt), *.txt")

-    If FileToOpen = False Then

-        MsgBox "No file select"

-    Else

-        MsgBox "Selected file is :" & FileToOpen

-    End If

-    Set WSh = ThisWorkbook.Sheets(HOME_PAGE_NAME)

-    With WSh

-        If .Range(DOMAIN_NAME_IDX) = FEMALE_NAME_IDX Then

-            Set DomainIdx = .Range(FEMALE_FILE_NAME_ADR)

-        Else

-            If .Range(DOMAIN_NAME_IDX) = MALE_NAME_IDX Then

-                Set DomainIdx = .Range(MALE_FILE_NAME_ADR)

-            Else

-                Set DomainIdx = .Range(SMAIL_FILE_NAME_ADR)

-            End If

-        End If

-        DomainIdx = FileToOpen

-        With DomainIdx.Font

-            .Name = "Arial"

-            .FontStyle = "Bold"

-            .Size = 10

-            .Strikethrough = False

-            .Superscript = False

-            .Subscript = False

-            .OutlineFont = False

-            .Shadow = False

-            .Underline = xlUnderlineStyleNone

-            .ColorIndex = xlAutomatic

-        End With 'DomainIdx

-    End With ' WSh

-End Sub

-

-<<<<<<
-======================
-mPrg
->>>>>>
-Attribute VB_Name = "mPrg"

-Option Explicit

-

-Sub ReCalc()

-    Dim wb As Workbook

-    Dim FileToOpen As String

-    Set wb = ThisWorkbook

-    

-    wb.Sheets(HOME_PAGE_NAME).EnableCalculation = False

-    

-    FileToOpen = wb.Sheets(HOME_PAGE_NAME).Range(FEMALE_FILE_NAME_ADR)

-    

-    UpdateHistoryFromFile wb, FileToOpen

-    GetUserStat wb.Sheets(RAW_DATA_SHEET), UserStat, BadUserList, STA_USER_FEM

-    WriteResultUsers wb.Sheets(STA_USER_FEM), UserStat

-    WriteBadUsers wb.Sheets(BAD_USER_FEM), BadUserList

-

-    FileToOpen = wb.Sheets(HOME_PAGE_NAME).Range(MALE_FILE_NAME_ADR)

-    UpdateHistoryFromFile wb, FileToOpen

-    GetUserStat wb.Sheets(RAW_DATA_SHEET), UserStat, BadUserList, STA_USER_MAL

-    WriteResultUsers wb.Sheets(STA_USER_MAL), UserStat

-    WriteBadUsers wb.Sheets(BAD_USER_MAL), BadUserList

-

-    FileToOpen = wb.Sheets(HOME_PAGE_NAME).Range(SMAIL_FILE_NAME_ADR)

-    UpdateHistoryFromFile wb, FileToOpen

-    GetUserStat wb.Sheets(RAW_DATA_SHEET), UserStat, BadUserList, STA_USER_SML

-    WriteResultUsers wb.Sheets(STA_USER_SML), UserStat

-    WriteBadUsers wb.Sheets(BAD_USER_SML), BadUserList

-    

-'    WriteCommonResult wb.Sheets(STA_USER_TOT)

-    

-    wb.Sheets(HOME_PAGE_NAME).EnableCalculation = True

-    Application.Calculate

-    

-    

-End Sub

-

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const RAW_DATA_SHEET As String = "Raw_data"

-Public Const RAW_DATA_RANGE As String = "B3"

-Public Const RAW_DATA_RANGE_COL As Integer = 2

-Public Const RAW_DATA_RANGE_COL_S As String = "B"

-Public Const RAW_DATA_RANGE_ROW As Integer = 3

-

-' Fields indexes in IN_TABLES

-Public Const IN_ACCOUNT_IDX As Integer = 0

-Public Const IN_TYPE_IDX As Integer = 1

-Public Const IN_STORAGE_IDX As Integer = 2

-Public Const IN_LAST_IDX As Integer = 3

-Public Const IN_IP_IDX As Integer = 4

-

-' Report lists names

-Public Const STA_USER_FEM As String = "Female_Users"

-Public Const STA_USER_MAL As String = "Male_Users"

-Public Const STA_USER_SML As String = "SendMail_Users"

-Public Const STA_USER_TOT As String = "Total_Users"

-Public Const BAD_USER_FEM As String = "Female_Bad_Users"

-Public Const BAD_USER_MAL As String = "Male_Bad_Users"

-Public Const BAD_USER_SML As String = "SendMail_Bad_Users"

-Public Const MAINTAIN_USER_LST As String = "STICKLY"

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mStatUser
->>>>>>
-Attribute VB_Name = "mStatUser"

-Option Explicit

-' Fields indexes in STAT_TABLES

-Public Const BAD_HEADER_RANGE As String = "A2"

-Public Const BAD_DATA_RANGE As String = "A3"

-Public Const BAD_DATA_RANGE_COL As Integer = 1

-Public Const BAD_DATA_RANGE_ROW As Integer = 3

-

-Public Const STA_DATA_RANGE As String = "A3"

-Public Const STA_DATA_RANGE_COL As Integer = 1

-Public Const STA_DATA_RANGE_ROW As Integer = 3

-

-Public Const STA_DATE_IDX As Integer = 0

-Public Const STA_TIME_IDX As Integer = 1

-

-Public Const STA_USERS_IDX As Integer = STA_TIME_IDX + 1

-Public Const STA_NEW_USERS_IDX As Integer = STA_TIME_IDX + 2

-Public Const STA_BAD_USERS_IDX As Integer = STA_TIME_IDX + 3

-

-Public Const STA_DISK_COMMON_IDX As Integer = STA_BAD_USERS_IDX + 1

-Public Const STA_DISK_MAX_IDX As Integer = STA_BAD_USERS_IDX + 2

-Public Const STA_DISK_AVR_IDX As Integer = STA_BAD_USERS_IDX + 3

-Public Const STA_DISK_BAD_MAX_IDX As Integer = STA_BAD_USERS_IDX + 4

-Public Const STA_DISK_BAD_AVR_IDX As Integer = STA_BAD_USERS_IDX + 5

-

-Public Const STA_DISK_HIS_0_IDX As Integer = STA_DISK_BAD_AVR_IDX + 1

-Public Const STA_DISK_HIS_30_IDX As Integer = STA_DISK_BAD_AVR_IDX + 2

-Public Const STA_DISK_HIS_100_IDX As Integer = STA_DISK_BAD_AVR_IDX + 3

-Public Const STA_DISK_HIS_300_IDX As Integer = STA_DISK_BAD_AVR_IDX + 4

-Public Const STA_DISK_HIS_1000_IDX As Integer = STA_DISK_BAD_AVR_IDX + 5

-Public Const STA_DISK_HIS_3000_IDX As Integer = STA_DISK_BAD_AVR_IDX + 6

-Public Const STA_DISK_HIS_BIG_IDX As Integer = STA_DISK_BAD_AVR_IDX + 7

-

-Public Const STA_TIME_HIS_0D_IDX As Integer = STA_DISK_HIS_BIG_IDX + 1

-Public Const STA_TIME_HIS_3D_IDX As Integer = STA_DISK_HIS_BIG_IDX + 2

-Public Const STA_TIME_HIS_1W_IDX As Integer = STA_DISK_HIS_BIG_IDX + 3

-Public Const STA_TIME_HIS_2W_IDX As Integer = STA_DISK_HIS_BIG_IDX + 4

-Public Const STA_TIME_HIS_1M_IDX As Integer = STA_DISK_HIS_BIG_IDX + 5

-Public Const STA_TIME_HIS_2M_IDX As Integer = STA_DISK_HIS_BIG_IDX + 6

-

-Private Const DISK_RANG_0 As Integer = 0

-Private Const DISK_RANG_30 As Integer = 30

-Private Const DISK_RANG_100 As Integer = 100

-Private Const DISK_RANG_300 As Integer = 300

-Private Const DISK_RANG_1000 As Integer = 1000

-Private Const DISK_RANG_3000 As Integer = 3000

-

-Private Const TIME_RANG_0D As Integer = 0

-Private Const TIME_RANG_3D As Integer = 2

-Private Const TIME_RANG_1W As Integer = 7

-Private Const TIME_RANG_2W As Integer = 14

-Private Const TIME_RANG_1M As Integer = 30

-Private Const TIME_RANG_2M As Integer = 60

-

-Private Const FEMALE_GOOD_RANGE_COL As Integer = "2"

-Private Const MALE_GOOD_RANGE_COL As Integer = "3"

-Private Const SENDMAIL_GOOD_RANGE_COL As Integer = "4"

-Private Const GOOD_RANGE_ROW As Integer = "3"

-

-' Common data types

-Type TUserStatData

-    theDate As Date

-    theTime As Date

-    lUsersCount As Long

-    lUsersNew As Long

-    lUsersBad As Long

-    lDiskTotal As Long

-    lDiskMax As Long

-    lDiskAvr As Long

-    lDiskBad As Long

-    lDiskBadAvr As Long

-    lDisk_0 As Long

-    lDisk_30 As Long

-    lDisk_100 As Long

-    lDisk_300 As Long

-    lDisk_1000 As Long

-    lDisk_3000 As Long

-    lDisk_Big As Long

-    lTime_0D As Long

-    lTime_3D As Long

-    lTime_1W As Long

-    lTime_2W As Long

-    lTime_1M As Long

-    lTime_2M As Long

-End Type

-

-Type TBadUser

-    theName As String

-    lLast As Date

-    lDiskSize As Long

-End Type

-

-' Comon data declaration

-Public UserStat As TUserStatData

-Public BadUserList() As TBadUser

-

-Sub GetUserStat(ws As Worksheet, us As TUserStatData, bu() As TBadUser, DOMEN_Idx As String)

-    Dim Location, GoodList As Range

-    Dim GoodRangeCollounm As Integer

-    

-    

-    With us

-        .theDate = Now

-        .theTime = Now

-        .lUsersCount = 0

-        .lUsersNew = 0

-        .lUsersBad = 0

-        .lDiskTotal = 0

-        .lDiskMax = 0

-        .lDiskAvr = 0

-        .lDiskBad = 0

-        .lDiskBadAvr = 0

-        .lDisk_0 = 0

-        .lDisk_30 = 0

-        .lDisk_100 = 0

-        .lDisk_300 = 0

-        .lDisk_1000 = 0

-        .lDisk_3000 = 0

-        .lDisk_Big = 0

-        .lTime_0D = 0

-        .lTime_3D = 0

-        .lTime_1W = 0

-        .lTime_2W = 0

-        .lTime_1M = 0

-        .lTime_2M = 0

-    End With

-    

-    With ws

-        us.lUsersCount = GetLinesCount(.Range(RAW_DATA_RANGE).Offset(1, 0))

-        Set Location = .Range( _

-            .Cells(RAW_DATA_RANGE_ROW + 1, RAW_DATA_RANGE_COL + IN_STORAGE_IDX), _

-            .Cells(RAW_DATA_RANGE_ROW + us.lUsersCount, RAW_DATA_RANGE_COL + IN_STORAGE_IDX) _

-        )

-        Dim c, d As Variant

-        

-        For Each c In Location

-            us.lDiskTotal = us.lDiskTotal + c.Value

-            If us.lDiskMax < c.Value Then

-                us.lDiskMax = c.Value

-            End If

-            If c.Value = DISK_RANG_0 Then

-                us.lDisk_0 = us.lDisk_0 + 1

-            Else

-                If c.Value < DISK_RANG_30 Then

-                    us.lDisk_30 = us.lDisk_30 + 1

-                Else

-                    If c.Value < DISK_RANG_100 Then

-                        us.lDisk_100 = us.lDisk_100 + 1

-                    Else

-                        If c.Value < DISK_RANG_300 Then

-                            us.lDisk_300 = us.lDisk_300 + 1

-                        Else

-                            If c.Value < DISK_RANG_1000 Then

-                                us.lDisk_1000 = us.lDisk_1000 + 1

-                            Else

-                                If c.Value < DISK_RANG_3000 Then

-                                    us.lDisk_3000 = us.lDisk_3000 + 1

-                                Else

-                                    us.lDisk_Big = us.lDisk_Big + 1

-                                End If

-                            End If

-                        End If

-                    End If

-                End If

-            End If

-        Next c

-        us.lDiskAvr = us.lDiskTotal / us.lUsersCount

-        

-        Set Location = .Range( _

-            .Cells(RAW_DATA_RANGE_ROW + 1, RAW_DATA_RANGE_COL + IN_LAST_IDX), _

-            .Cells(RAW_DATA_RANGE_ROW + us.lUsersCount, RAW_DATA_RANGE_COL + IN_LAST_IDX) _

-        )

-        

-        Dim HowLong As Integer

-        ReDim bu(us.lUsersCount) As TBadUser

-        Dim i_bad As Long

-        i_bad = LBound(bu)

-                

-        If DOMEN_Idx = STA_USER_SML Then

-            GoodRangeCollounm = SENDMAIL_GOOD_RANGE_COL

-        Else

-            If DOMEN_Idx = STA_USER_MAL Then

-                GoodRangeCollounm = MALE_GOOD_RANGE_COL

-            Else

-                GoodRangeCollounm = FEMALE_GOOD_RANGE_COL

-            End If

-        End If

-        

-        With Worksheets(MAINTAIN_USER_LST)

-            Set GoodList = .Range( _

-                .Cells(GOOD_RANGE_ROW, GoodRangeCollounm), _

-                .Cells(GOOD_RANGE_ROW, GoodRangeCollounm) _

-            )

-        End With

-        

-        For Each c In Location

-            If IsDate(c.Value) Then

-                HowLong = -DateDiff("d", Now, c.Value)

-                If HowLong = TIME_RANG_0D Then

-                    us.lTime_0D = us.lTime_0D + 1

-                Else

-                    If HowLong <= TIME_RANG_3D Then

-                        us.lTime_3D = us.lTime_3D + 1

-                    Else

-                        If HowLong <= TIME_RANG_1W Then

-                            us.lTime_1W = us.lTime_1W + 1

-                        Else

-                            If HowLong <= TIME_RANG_2W Then

-                                us.lTime_2W = us.lTime_2W + 1

-                            Else

-                                If HowLong <= TIME_RANG_1M Then

-                                    us.lTime_1M = us.lTime_1M + 1

-                                Else

-                                    If HowLong <= TIME_RANG_2M Then

-                                        us.lTime_2M = us.lTime_2M + 1

-                                    Else

-                                        If Not NameInGoodUserList(GoodList, c.Offset(0, -3).Value) Then

-                                            us.lUsersBad = us.lUsersBad + 1

-                                            bu(i_bad).theName = c.Offset(0, -3).Value

-                                            bu(i_bad).lLast = c.Value

-                                            bu(i_bad).lDiskSize = c.Offset(0, -1).Value

-                                            us.lDiskBad = us.lDiskBad + c.Offset(0, -1).Value

-                                            i_bad = i_bad + 1

-                                        End If

-                                    End If

-                                End If

-                            End If

-                        End If

-                    End If

-                End If

-            Else

-                us.lTime_0D = us.lTime_0D + 1

-            End If

-        Next c

-        ReDim bad_users(i_bad)

-        

-        us.lDiskBadAvr = us.lDiskBad / i_bad

-        

-    End With ' with ws

-End Sub

-

-Sub WriteResultUsers(ws As Worksheet, us As TUserStatData)

-    Dim curline As Integer

-    Dim Location As Range

-    With ws

-        Set Location = .Range( _

-                .Cells(STA_DATA_RANGE_ROW, STA_DATA_RANGE_COL), _

-                .Cells(STA_DATA_RANGE_ROW, STA_DATA_RANGE_COL) _

-            )

-        curline = GetLinesCount(Location)

-        With .Range( _

-                .Cells(STA_DATA_RANGE_ROW + curline, STA_DATA_RANGE_COL), _

-                .Cells(STA_DATA_RANGE_ROW + curline, STA_DATA_RANGE_COL) _

-            )

-            .Offset(0, STA_DATE_IDX).Value = us.theDate

-            .Offset(0, STA_DATE_IDX).NumberFormat = "dd-mmm-yy"

-            

-            .Offset(0, STA_TIME_IDX).Value = us.theTime

-            .Offset(0, STA_TIME_IDX).NumberFormat = "hh:mm"

-            

-            .Offset(0, STA_USERS_IDX).Value = us.lUsersCount

-            If curline > 0 Then

-                us.lUsersNew = us.lUsersCount - .Offset(-1, STA_USERS_IDX).Value

-            End If

-            .Offset(0, STA_NEW_USERS_IDX).Value = us.lUsersNew

-            .Offset(0, STA_BAD_USERS_IDX).Value = us.lUsersBad

-            .Offset(0, STA_DISK_COMMON_IDX).Value = us.lDiskTotal

-            .Offset(0, STA_DISK_MAX_IDX).Value = us.lDiskMax

-            .Offset(0, STA_DISK_AVR_IDX).Value = us.lDiskAvr

-            .Offset(0, STA_DISK_BAD_MAX_IDX).Value = us.lDiskBad

-            .Offset(0, STA_DISK_BAD_AVR_IDX).Value = us.lDiskBadAvr

-            .Offset(0, STA_DISK_HIS_0_IDX).Value = us.lDisk_0

-            .Offset(0, STA_DISK_HIS_30_IDX).Value = us.lDisk_30

-            .Offset(0, STA_DISK_HIS_100_IDX).Value = us.lDisk_100

-            .Offset(0, STA_DISK_HIS_300_IDX).Value = us.lDisk_300

-            .Offset(0, STA_DISK_HIS_1000_IDX).Value = us.lDisk_1000

-            .Offset(0, STA_DISK_HIS_3000_IDX).Value = us.lDisk_3000

-            .Offset(0, STA_DISK_HIS_BIG_IDX).Value = us.lDisk_Big

-            .Offset(0, STA_TIME_HIS_0D_IDX).Value = us.lTime_0D

-            .Offset(0, STA_TIME_HIS_3D_IDX).Value = us.lTime_3D

-            .Offset(0, STA_TIME_HIS_1W_IDX).Value = us.lTime_1W

-            .Offset(0, STA_TIME_HIS_2W_IDX).Value = us.lTime_2W

-            .Offset(0, STA_TIME_HIS_1M_IDX).Value = us.lTime_1M

-            .Offset(0, STA_TIME_HIS_2M_IDX).Value = us.lTime_2M

-        End With 'With .Range( _

-

-    End With 'With ws

-End Sub

-

-Sub WriteCommonResult(ws As Worksheet)

-    Dim LastLine As Integer

-    Dim Location As Range

-    Set Location = ws.Range(STA_DATA_RANGE)

-    LastLine = GetLinesCount(Location)

-    Set Location = Location.Offset(LastLine, 0)

-    While Not IsEmpty(Location.Offset(-1, 0))

-        Location.Fo = Location.Offset(-1, 0)

-        ' ws.Paste

-        Set Location = Location.Offset(0, 1)

-    Wend

-End Sub

-

-Sub WriteBadUsers(ws As Worksheet, bad_users() As TBadUser)

-    Dim Location As Range

-    

-    With ws

-        .Parent.Application.DisplayAlerts = False

-        .Range( _

-            .Cells(BAD_DATA_RANGE_ROW, BAD_DATA_RANGE_COL), _

-            .Cells(65535, BAD_DATA_RANGE_COL + 3) _

-        ).ClearContents

-

-        Set Location = .Range( _

-                .Cells(BAD_DATA_RANGE_ROW, BAD_DATA_RANGE_COL), _

-                .Cells(BAD_DATA_RANGE_ROW, BAD_DATA_RANGE_COL) _

-            )

-        

-        Dim i As Integer

-        

-        For i = LBound(bad_users()) To UBound(bad_users())

-            If bad_users(i).theName = "" Then

-                Exit For

-            End If

-            Location.Offset(i, 0).Value = bad_users(i).theName

-            Location.Offset(i, 1).Value = bad_users(i).lLast

-            Location.Offset(i, 1).NumberFormat = "dd-mmm-yy"

-            Location.Offset(i, 2).Value = bad_users(i).lDiskSize

-        Next i

-        

-        Set Location = .Range( _

-                .Cells(BAD_DATA_RANGE_ROW - 1, BAD_DATA_RANGE_COL), _

-                .Cells(BAD_DATA_RANGE_ROW + i, BAD_DATA_RANGE_COL + 2) _

-            )

-        

-        Location.Sort _

-            Key1:=.Range(BAD_HEADER_RANGE).Offset(0, 1), _

-            Order1:=xlAscending, _

-            Header:=xlGuess, _

-            OrderCustom:=1, _

-            MatchCase:=False, _

-            Orientation:=xlTopToBottom

-        

-        ReDim bad_users(0)

-    End With

-End Sub

-

-Function NameInGoodUserList(GoodList As Range, uname As String) As Boolean

-    Dim i, maxLines As Integer

-    maxLines = GetLinesCount(GoodList) + 1

-    

-    NameInGoodUserList = False

-    

-    For i = 0 To maxLines

-        If GoodList.Offset(i, 0).Value = uname Then

-            NameInGoodUserList = True

-            Exit For

-        End If

-    Next i

-    

-End Function

-<<<<<<
-======================
-mFileOpen
->>>>>>
-Attribute VB_Name = "mFileOpen"

-Option Explicit

-

-Public Const MAX_LOAD_DATA_LINES As Integer = 16000

-

-Public Const MSG_FILE_INVALID_FORMAT As String = "Неверный формат файла"

-

-Public Const FUNCRES_FILE_OK As Integer = 0

-Public Const FUNCRES_FILE_VERY_SMALL As Integer = -1

-Public Const FUNCRES_FILE_INVALID_FORMAT As Integer = -2

-

-Public Const SETUP_PAGE_NAME As String = "Setup"

-Public Const HOME_PAGE_NAME As String = "HomePage"

-Public Const DOMAIN_NAME_IDX As String = "D5"

-

-Public Const FEMALE_NAME_IDX As String = "1"

-Public Const MALE_NAME_IDX As String = "2"

-Public Const SMAIL_NAME_IDX As String = "3"

-

-Public Const FEMALE_FILE_NAME_ADR As String = "E3"

-Public Const MALE_FILE_NAME_ADR As String = "E5"

-Public Const SMAIL_FILE_NAME_ADR As String = "E7"

-

-

-

-Function UpdateHistoryFromFile(wb As Workbook, FileToOpen As String) As Integer

-    Dim DestRangeName As String

-    Dim ResultLength As Integer

-    Dim Location As Range

-

-    Dim SingleFileLine As String

-    Dim FileHandler As Integer

-    Dim i, row_idx As Integer

-    

-    UpdateHistoryFromFile = FUNCRES_FILE_INVALID_FORMAT

-    With wb

-'        .Application.ScreenUpdating = False

-        With .Worksheets(RAW_DATA_SHEET)

-            'Clear table include temp area

-            .Parent.Application.DisplayAlerts = False

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW - 1, RAW_DATA_RANGE_COL - 1), _

-                .Cells(65535, RAW_DATA_RANGE_COL + IN_IP_IDX + 3) _

-            ).ClearContents

-            Set Location = .Range(RAW_DATA_RANGE).Offset(-1, 0)

-            

-            ' Reading data from file

-            FileHandler = FreeFile

-            row_idx = 0

-            Open FileToOpen For Input As #FileHandler

-            Do While Not EOF(FileHandler) And row_idx < MAX_LOAD_DATA_LINES

-                Line Input #FileHandler, SingleFileLine

-                .Range(RAW_DATA_RANGE).Offset(row_idx, 0) = SingleFileLine

-                row_idx = row_idx + 1

-            Loop

-            Close #FileHandler

-            

-            ' Parsing data

-            DestRangeName = "=" & RAW_DATA_SHEET & "!" & RAW_DATA_RANGE & _

-                            ":" & RAW_DATA_RANGE_COL_S & (RAW_DATA_RANGE_ROW + row_idx)

-            ResultLength = row_idx

-            

-            .Range(DestRangeName).TextToColumns _

-                Destination:=.Range(DestRangeName), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=True, _

-                Semicolon:=True, _

-                Comma:=True, _

-                Space:=True, _

-                Other:=False, _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 1), _

-                                Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1))

-            

-            .Parent.Application.DisplayAlerts = True

-            Dim CurrentDate As String

-            Dim RawData As Range

-            

-            Set RawData = .Range(RAW_DATA_RANGE)

-            

-            row_idx = row_idx - 1

-            Set Location = .Range( _

-                .Cells(RAW_DATA_RANGE_ROW + 1, RAW_DATA_RANGE_COL + IN_STORAGE_IDX), _

-                .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + IN_STORAGE_IDX) _

-            )

-            Dim c As Variant

-            For Each c In Location

-                c.Value = ChkAccountSize(c.Value)

-            Next c

-        End With ' With .Worksheets(RAW_DATA_SHEET)

-    End With ' wb

-    UpdateHistoryFromFile = FUNCRES_FILE_OK

-End Function

-

-Function ChkAccountSize(strSize As String) As Long

-    Dim ChNum As Long

-    ChNum = InStr(strSize, "K")

-    If ChNum = 0 Then

-        ChNum = InStr(strSize, "M")

-        If ChNum = 0 Then

-            ChkAccountSize = Val(strSize) / 1024

-        Else

-            strSize = Left(strSize, ChNum - 1)

-            ChNum = Val(strSize)

-            ChkAccountSize = ChNum * 1024

-        End If

-    Else

-        strSize = Left(strSize, ChNum - 1)

-        ChNum = Val(strSize)

-        ChkAccountSize = ChNum

-    End If

-End Function

-

-Sub SetFile()

-    Dim FileToOpen As Variant

-    Dim DomainIdx As Range

-    Dim WSh As Worksheet

-    

-    FileToOpen = Application.GetOpenFilename("Text Files (*.txt), *.txt")

-    If FileToOpen = False Then

-        MsgBox "No file select"

-    Else

-        MsgBox "Selected file is :" & FileToOpen

-    End If

-    Set WSh = ThisWorkbook.Sheets(HOME_PAGE_NAME)

-    With WSh

-        If .Range(DOMAIN_NAME_IDX) = FEMALE_NAME_IDX Then

-            Set DomainIdx = .Range(FEMALE_FILE_NAME_ADR)

-        Else

-            If .Range(DOMAIN_NAME_IDX) = MALE_NAME_IDX Then

-                Set DomainIdx = .Range(MALE_FILE_NAME_ADR)

-            Else

-                Set DomainIdx = .Range(SMAIL_FILE_NAME_ADR)

-            End If

-        End If

-        DomainIdx = FileToOpen

-        With DomainIdx.Font

-            .Name = "Arial"

-            .FontStyle = "Bold"

-            .Size = 10

-            .Strikethrough = False

-            .Superscript = False

-            .Subscript = False

-            .OutlineFont = False

-            .Shadow = False

-            .Underline = xlUnderlineStyleNone

-            .ColorIndex = xlAutomatic

-        End With 'DomainIdx

-    End With ' WSh

-End Sub

-

-<<<<<<
-======================
-mPrg
->>>>>>
-Attribute VB_Name = "mPrg"

-Option Explicit

-

-Sub ReCalc()

-    Dim wb As Workbook

-    Dim FileToOpen As String

-    Set wb = ThisWorkbook

-    

-    wb.Sheets(HOME_PAGE_NAME).EnableCalculation = False

-    

-    FileToOpen = wb.Sheets(SETUP_PAGE_NAME).Range(FEMALE_FILE_NAME_ADR)

-    

-    UpdateHistoryFromFile wb, FileToOpen

-    GetUserStat wb.Sheets(RAW_DATA_SHEET), UserStat, BadUserList, STA_USER_FEM

-    WriteResultUsers wb.Sheets(STA_USER_FEM), UserStat

-    WriteBadUsers wb.Sheets(BAD_USER_FEM), BadUserList

-

-    FileToOpen = wb.Sheets(SETUP_PAGE_NAME).Range(MALE_FILE_NAME_ADR)

-    UpdateHistoryFromFile wb, FileToOpen

-    GetUserStat wb.Sheets(RAW_DATA_SHEET), UserStat, BadUserList, STA_USER_MAL

-    WriteResultUsers wb.Sheets(STA_USER_MAL), UserStat

-    WriteBadUsers wb.Sheets(BAD_USER_MAL), BadUserList

-

-    FileToOpen = wb.Sheets(SETUP_PAGE_NAME).Range(SMAIL_FILE_NAME_ADR)

-    UpdateHistoryFromFile wb, FileToOpen

-    GetUserStat wb.Sheets(RAW_DATA_SHEET), UserStat, BadUserList, STA_USER_SML

-    WriteResultUsers wb.Sheets(STA_USER_SML), UserStat

-    WriteBadUsers wb.Sheets(BAD_USER_SML), BadUserList

-    

-'    WriteCommonResult wb.Sheets(STA_USER_TOT)

-    

-    wb.Sheets(HOME_PAGE_NAME).EnableCalculation = True

-    Application.Calculate

-    

-    

-End Sub

-

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Sub ResetTotslUsers()

-Attribute ResetTotslUsers.VB_Description = "Macro recorded 23.10.00 by Nickolai Garbuz"

-Attribute ResetTotslUsers.VB_ProcData.VB_Invoke_Func = " \n14"

-'

-' Macro1 Macro

-' Macro recorded 23.10.00 by Nickolai Garbuz

-'

-

-'

-    With Worksheets("Total_users")

-        Dim EndLine As Variant

-        .Activate

-        EndLine = GetLinesCount(.Range("A2")) + 1

-        .Range("A" & EndLine & ":" & "W" & EndLine).Select

-        EndLine = EndLine + 1

-        Selection.Copy

-        .Range("A" & (EndLine)).Select

-        .Paste

-    End With

-    Worksheets("HomePage").Activate

-    Dim ChObj As ChartObject

-    With Worksheets("HomePage")

-        For Each ChObj In .Charts

-            If ChObj.Name = "Users Stat" Then

-                ChObj.SetSourceData Source:=Sheets("Total_Users").Range("A2:A13,C2:E13" _

-        ), PlotBy:=xlColumns

-            End If

-        Next ChObj

-    End With

-End Sub

-Sub Macro2()

-Attribute Macro2.VB_Description = "Macro recorded 23.10.00 by Nickolai Garbuz"

-Attribute Macro2.VB_ProcData.VB_Invoke_Func = " \n14"

-'

-' Macro2 Macro

-' Macro recorded 23.10.00 by Nickolai Garbuz

-'

-

-'

-    Dim ChObj As ChartObject

-    With Worksheets("HomePage")

-        For Each ChObj In .Charts

-            If ChObj.Name = "Users Stat" Then

-                ChObj.SetSourceData Source:=Sheets("Total_Users").Range("A2:A13,C2:E13" _

-        ), PlotBy:=xlColumns

-            End If

-    End With

-    ActiveSheet.ChartObjects("Chart 12").Activate

-    ActiveChart.PlotArea.Select

-    ActiveChart

-End Sub

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module2
->>>>>>
-Attribute VB_Name = "Module2"

-Function make_ref(shn As String, cn As String)

-    Dim a As Object

-    a = Sheets(shn).Range(cn)

-    make_ref = a.Value

-End Function

-

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Sub make_ref()

-Attribute make_ref.VB_Description = "Macro recorded 04.11.99 by Oleg Tabarovsky"

-Attribute make_ref.VB_ProcData.VB_Invoke_Func = " \n14"

-'

-' make_ref Macro

-' Macro recorded 04.11.99 by Oleg Tabarovsky

-'

-

-'

-    Range("H33").Select

-    Application.CommandBars("Stop Recording").Visible = False

-    Range("H27").Select

-    ActiveCell.FormulaR1C1 = "=make_ref(R[-1]C[-7],R[-18]C[-6])"

-    Range("H27").Select

-    ActiveCell.FormulaR1C1 = "=make_ref(R[-1]C[-7],R[-18]C[-6])"

-    Range("H27").Select

-    ActiveCell.FormulaR1C1 = "=make_ref(R[-1]C[-7],R[-18]C[-6])"

-    Range("H27").Select

-    ActiveCell.FormulaR1C1 = "=make_ref(R[-1]C[-7],R[-18]C[-6])"

-    Windows("test1.xls").Activate

-    Range("H4:I4").Select

-    Selection.NumberFormat = "General"

-    Range("H4").Select

-    ActiveCell.FormulaR1C1 = "=RC[-4]"

-    ActiveCell.FormulaR1C1 = "=R[1]C[-4]"

-    Range("H4").Select

-    ActiveCell.FormulaR1C1 = "=R[2]C[-4]"

-    Range("H6").Select

-    Windows("Book1").Activate

-    Range("H27").Select

-    Sheets("GL").Select

-    Range("B9").Select

-    Sheets("Сalculator").Select

-    Range("H27").Select

-    ActiveCell.FormulaR1C1 = "=make_ref(R[-1]C[-7],""B9"")"

-    ActiveCell.FormulaR1C1 = "=make_ref(R[-1]C[-7],R[-18]C[-6])"

-    Range("G25").Select

-    ActiveCell.FormulaR1C1 = "b9"

-    Range("H27").Select

-    ActiveCell.FormulaR1C1 = "=make_ref(R[-1]C[-7],R[-2]C[-1])"

-    Range("H27").Select

-    ActiveCell.FormulaR1C1 = "=make_ref(R[-1]C[-7],R[-2]C[-1])"

-    Range("H27").Select

-    ActiveCell.FormulaR1C1 = "=make_ref(R[-1]C[-7],R[-2]C[-1])"

-    Range("H27").Select

-    ActiveCell.FormulaR1C1 = "=make_ref(R[-1]C[-7],R[-2]C[-1])"

-    Range("G25").Select

-    Selection.ClearContents

-    Range("H27").Select

-    Selection.ClearContents

-    Range("E26").Select

-    ActiveWindow.SmallScroll Down:=-7

-    Range("D13").Select

-    ActiveWindow.SmallScroll Down:=5

-    Range("D40").Select

-    ActiveWindow.SmallScroll Down:=13

-    Range("D51").Select

-    ActiveCell.FormulaR1C1 = _

-        "=IF(R[-36]C,R[-36]C,HLOOKUP(R[-42]C,R[18]C[-3]:R[19]C[28],2))"

-    Range("D51").Select

-    ActiveWindow.SmallScroll Down:=-7

-    Range("A27").Select

-    ActiveWindow.SmallScroll Down:=-8

-    Range("A27").Select

-    ActiveCell.FormulaR1C1 = "A81"

-    Range("B27").Select

-    ActiveWindow.SmallScroll Down:=14

-    Range("D51").Select

-    ActiveWindow.SmallScroll Down:=-27

-    ActiveCell.FormulaR1C1 = _

-        "=IF(R[-36]C,R[-36]C,HLOOKUP(R[-42]C,HLOOKUP(R[-38]C,R[-25]C[-3]:R[-25]C[1],2),2))"

-    Range("D52").Select

-    ActiveWindow.SmallScroll Down:=8

-    Range("D51").Select

-    ActiveWindow.SmallScroll Down:=-6

-    Range("A27").Select

-    ActiveCell.FormulaR1C1 = "A81:F82"

-    Range("E27").Select

-    ActiveWindow.SmallScroll Down:=34

-    Range("D51").Select

-    ActiveCell.FormulaR1C1 = _

-        "=IF(R[-36]C,R[-36]C,HLOOKUP(R[-42]C,HLOOKUP(R[-38]C,R[-25]C[-3]:R[-24]C[1],2),2))"

-    Range("D52").Select

-    ActiveWindow.SmallScroll Down:=1

-    Range("G37").Select

-    ActiveWindow.SmallScroll Down:=-8

-    Range("D15").Select

-    Selection.ClearContents

-    Range("G24").Select

-    ActiveWindow.SmallScroll Down:=15

-    Range("D51").Select

-    ActiveCell.FormulaR1C1 = _

-        "=IF(R[-36]C,R[-36]C,HLOOKUP(R[-42]C,INDIRECT(HLOOKUP(R[-38]C,R[-25]C[-3]:R[-24]C[1],2)),2))"

-    Range("I40").Select

-    ActiveCell.FormulaR1C1 = _

-        "=INDIRECT(HLOOKUP(R[-27]C[-5],R[-14]C[-8]:R[-13]C[-4],2))"

-    Range("I40").Select

-    ActiveCell.FormulaR1C1 = _

-        "=INDIRECT(HLOOKUP(R[-27]C[-5],R[-14]C[-8]:R[-13]C[-4],2))"

-    Range("D13").Select

-    ActiveCell.FormulaR1C1 = "GL"

-    Range("D14").Select

-    ActiveWindow.SmallScroll Down:=15

-    Range("A27").Select

-    ActiveCell.FormulaR1C1 = "A81"

-    Range("I40").Select

-    ActiveWindow.SmallScroll Down:=-2

-    ActiveCell.FormulaR1C1 = _

-        "=INDIRECT(HLOOKUP(R[-27]C[-5],R[-14]C[-8]:R[-13]C[-4],2))"

-    Range("D43").Select

-    ActiveWindow.SmallScroll Down:=2

-    Range("D51").Select

-    ActiveWindow.SmallScroll Down:=-6

-    Range("I40").Select

-    ActiveCell.FormulaR1C1 = _

-        "=SUM(INDIRECT(HLOOKUP(R[-27]C[-5],R[-14]C[-8]:R[-13]C[-4],2)))"

-    Range("A27").Select

-    ActiveCell.FormulaR1C1 = "A81:a83"

-    Range("I40").Select

-    ActiveCell.FormulaR1C1 = _

-        "=HLOOKUP(R[-31]C[-5],INDIRECT(HLOOKUP(R[-27]C[-5],R[-14]C[-8]:R[-13]C[-4],2)),2)"

-    Range("G5").Select

-    ActiveWindow.SmallScroll Down:=18

-    Range("I40").Select

-    ActiveWindow.SmallScroll Down:=-2

-    Range("A27").Select

-    ActiveCell.FormulaR1C1 = "A81:f82"

-    Range("A28").Select

-    ActiveWindow.SmallScroll Down:=-16

-    Range("D8").Select

-    ActiveCell.FormulaR1C1 = "768"

-    Range("D9").Select

-    ActiveWindow.SmallScroll Down:=0

-    Range("D8").Select

-    ActiveCell.FormulaR1C1 = "1024"

-    Range("D9").Select

-    ActiveWindow.SmallScroll Down:=29

-    Range("D51").Select

-    ActiveWindow.SmallScroll Down:=-18

-    Range("A27").Select

-    ActiveCell.FormulaR1C1 = "A81:F82"

-    Range("F29").Select

-    ActiveWindow.SmallScroll Down:=26

-    Range("D51").Select

-    ActiveWindow.SmallScroll Down:=9

-    Range("I40").Select

-    Selection.Cut

-    Range("I40").Select

-    Application.CutCopyMode = False

-    Selection.ClearContents

-    Range("D51").Select

-    Selection.Copy

-    Range("D52").Select

-    ActiveSheet.Paste

-    Range("D52").Select

-    Application.CutCopyMode = False

-    Range("D51").Select

-    ActiveWindow.SmallScroll Down:=-21

-    Range("D52").Select

-    ActiveSheet.Paste

-    Range("D52").Select

-    ActiveCell.FormulaR1C1 = _

-        "=IF(R[-37]C,R[-37]C,HLOOKUP(R[-43]C,INDIRECT(HLOOKUP(R[-39]C,R[-26]C[-3]:R[-25]C[1],2)),2))"

-    Range("D52").Select

-    ActiveCell.FormulaR1C1 = _

-        "=IF(R[-37]C,R[-37]C,HLOOKUP(R[-43]C,INDIRECT(HLOOKUP(R[-39]C,R[-26]C[-3]:R[-25]C[1],3)),2))"

-    Range("D53").Select

-    ActiveWindow.SmallScroll Down:=30

-    Range("F86").Select

-    ActiveWindow.SmallScroll Down:=-36

-    Rows("28:28").Select

-    Selection.Insert Shift:=xlDown

-    Range("A28").Select

-    ActiveCell.FormulaR1C1 = "A85:F86"

-    Range("D52").Select

-    ActiveWindow.SmallScroll Down:=9

-    Range("D53").Select

-    ActiveWindow.SmallScroll Down:=-8

-    Range("A27").Select

-    ActiveCell.FormulaR1C1 = "A82:F83"

-    Range("A28").Select

-    ActiveCell.FormulaR1C1 = "A86:F87"

-    Range("D53").Select

-    ActiveCell.FormulaR1C1 = _

-        "=IF(R[-38]C,R[-38]C,HLOOKUP(R[-44]C,INDIRECT(HLOOKUP(R[-40]C,R[-27]C[-3]:R[-25]C[1],3)),2))"

-    Range("D52").Select

-    ActiveWindow.SmallScroll Down:=3

-    Range("D56").Select

-    ActiveCell.FormulaR1C1 = "=IF(R[-39]C,R[-39]C,0)"

-    Range("D56").Select

-    ActiveCell.FormulaR1C1 = _

-        "=IF(R[-39]C,R[-39]C,HLOOKUP(R[-47]C,INDIRECT(HLOOKUP(R[-43]C,R[-30]C[-3]:R[-28]C[1],2)),2))"

-    Range("D56").Select

-    ActiveWindow.SmallScroll Down:=-19

-    ActiveCell.FormulaR1C1 = _

-        "=IF(R[-39]C,R[-39]C,HLOOKUP(R[-47]C,INDIRECT(HLOOKUP(R[-42]C,R[-30]C[-3]:R[-28]C[1],2)),2))"

-    Range("D57").Select

-    ActiveWindow.SmallScroll Down:=-15

-    Range("D14").Select

-    ActiveCell.FormulaR1C1 = "GL"

-    Range("D17").Select

-    Selection.ClearContents

-    Range("G24:H24").Select

-    Range("H24").Activate

-    ActiveWindow.SmallScroll Down:=23

-    Range("D53").Select

-    ActiveWindow.SmallScroll Down:=-28

-    Range("D19").Select

-    ActiveWindow.SmallScroll Down:=29

-    Range("D53").Select

-    ActiveCell.FormulaR1C1 = _

-        "=IF(R[-34]C,R[-34]C,HLOOKUP(R[-44]C,INDIRECT(HLOOKUP(R[-40]C,R[-27]C[-3]:R[-25]C[1],3)),2))"

-    Range("D57").Select

-    ActiveCell.FormulaR1C1 = _

-        "=IF(R[-40]C,R[-40]C,HLOOKUP(R[-48]C,INDIRECT(HLOOKUP(R[-43]C,R[-31]C[-3]:R[-29]C[1],2)),2))"

-    Range("D56").Select

-    ActiveWindow.SmallScroll Down:=-2

-    Range("D57").Select

-    ActiveCell.FormulaR1C1 = _

-        "=IF(R[-36]C,R[-36]C,HLOOKUP(R[-48]C,INDIRECT(HLOOKUP(R[-43]C,R[-31]C[-3]:R[-29]C[1],3)),2))"

-    Range("D41").Select

-    ActiveWindow.SmallScroll Down:=-22

-    Range("D40").Select

-    ActiveCell.FormulaR1C1 = _

-        "=(R[23]C/R[-6]C)+IF(R[-25]C,R[-25]C*IF(R[-24]C,R[-24]C+1,1),0)+IF(R[-23]C,R[-23]C*IF(R[-22]C,R[-22]C+1,1),0)"

-    Range("D40").Select

-    ActiveWindow.SmallScroll Down:=-17

-    Range("D41").Select

-    ActiveCell.FormulaR1C1 = _

-        "=HLOOKUP(R[-32]C,R[29]C[-3]:R[30]C[28],2)*(HLOOKUP(R[-34]C,R[25]C[-2]:R[26]C[10],2)/R[-7]C)*IF(R[-9]C,R[-9]C,1)+IF(R[-22]C,R[-22]C*IF(R[-21]C,R[-21]C,1),0)+IF(R[-20]C,R[-20]C*IF(R[-19]C,R[-19]C,1),0)"

-    ActiveWindow.SmallScroll Down:=18

-    Range("D40").Select

-    ActiveCell.FormulaR1C1 = _

-        "=(R[23]C/R[-6]C)+IF(R[-25]C,R[-25]C*IF(R[-24]C,R[-24]C+1,1),IF(R[-25]C,R[-25]C,HLOOKUP(R[-31]C,INDIRECT(HLOOKUP(R[-27]C,R[-14]C[-3]:R[-13]C[1],2)),2)))+IF(R[-23]C,R[-23]C*IF(R[-22]C,R[-22]C+1,1),0)"

-    Range("D40").Select

-    ActiveCell.FormulaR1C1 = _

-        "=(R[23]C/R[-6]C)+IF(R[-25]C,R[-25]C*IF(R[-24]C,R[-24]C+1,1),IF(R[-25]C,R[-25]C,HLOOKUP(R[-31]C,INDIRECT(HLOOKUP(R[-27]C,R[-14]C[-3]:R[-13]C[1],2)),2)))?R[-23]C R[-23]C*IF(R[-22]C,R[-22]C+1,1)R[-23]C R[-23]C R[-31]C R[-26]C R[-14]C[-3]:R[-12]C[1] 2 "

-    Range("D52").Select

-    ActiveWindow.SmallScroll Down:=-13

-    Range("A29").Select

-    ActiveCell.FormulaR1C1 = "A90"

-    Range("F29").Select

-    ActiveWindow.SmallScroll Down:=17

-    Range("D52").Select

-    ActiveWindow.SmallScroll Down:=7

-    ActiveCell.FormulaR1C1 = _

-        "=IF(R[-37]C,R[-37]C,HLOOKUP(R[-43]C,INDIRECT(HLOOKUP(R[-39]C,R[-26]C[-3]:R[-25]C[1],2)),2)*INDIRECT(HLOOKUP(R[-39]C,R[-26]C[-3]:R[-25]C[1],3)))"

-    Range("D52").Select

-    ActiveCell.FormulaR1C1 = _

-        "=IF(R[-37]C,R[-37]C,HLOOKUP(R[-43]C,INDIRECT(HLOOKUP(R[-39]C,R[-26]C[-3]:R[-23]C[1],2)),2)*INDIRECT(HLOOKUP(R[-39]C,R[-26]C[-3]:R[-23]C[1],3)))"

-    Range("D52").Select

-    ActiveCell.FormulaR1C1 = _

-        "=IF(R[-37]C,R[-37]C,HLOOKUP(R[-43]C,INDIRECT(HLOOKUP(R[-39]C,R[-26]C[-3]:R[-23]C[1],2)),2)*SUM(INDIRECT(HLOOKUP(R[-39]C,R[-26]C[-3]:R[-23]C[1],3))))"

-    Range("D52").Select

-    ActiveWindow.SmallScroll Down:=-2

-    ActiveCell.FormulaR1C1 = _

-        "=IF(R[-37]C,R[-37]C,HLOOKUP(R[-43]C,INDIRECT(HLOOKUP(R[-39]C,R[-26]C[-3]:R[-23]C[1],2)),2)*INDIRECT(HLOOKUP(R[-39]C,R[-26]C[-3]:R[-23]C[1],3)))"

-    ActiveCell.FormulaR1C1 = _

-        "=IF(R[-37]C,R[-37]C,HLOOKUP(R[-43]C,INDIRECT(HLOOKUP(R[-39]C,R[-26]C[-3]:R[-23]C[1],2)),2)*INDIRECT(HLOOKUP(R[-39]C,R[-26]C[-3]:R[-23]C[1],4)))"

-    ActiveCell.FormulaR1C1 = _

-        "=IF(R[-37]C,R[-37]C,HLOOKUP(R[-43]C,INDIRECT(HLOOKUP(R[-39]C,R[-26]C[-3]:R[-23]C[1],2)),2)*(1-INDIRECT(HLOOKUP(R[-39]C,R[-26]C[-3]:R[-23]C[1],4))))"

-    Range("D52").Select

-    ActiveWindow.SmallScroll Down:=4

-    Range("D56").Select

-    ActiveCell.FormulaR1C1 = _

-        "=IF(R[-39]C,R[-39]C,HLOOKUP(R[-47]C,INDIRECT(HLOOKUP(R[-42]C,R[-30]C[-3]:R[-27]C[1],2)),2)*(1-INDIRECT(HLOOKUP(R[-42]C,R[-30]C[-3]:R[-27]C[1],4))))"

-    Range("D57").Select

-    ActiveCell.FormulaR1C1 = _

-        "=IF(R[-36]C,R[-36]C,HLOOKUP(R[-48]C,INDIRECT(HLOOKUP(R[-43]C,R[-31]C[-3]:R[-29]C[1],3)),2)*(1-INDIRECT(HLOOKUP(R[-43]C,R[-31]C[-3]:R[-28]C[1],4))))"

-    ActiveWindow.SmallScroll Down:=-17

-    Range("D19").Select

-    Selection.ClearContents

-    Range("D21").Select

-    Selection.ClearContents

-    ActiveWindow.SmallScroll Down:=21

-    Range("D53").Select

-    ActiveCell.FormulaR1C1 = _

-        "=IF(R[-34]C,R[-34]C,HLOOKUP(R[-44]C,INDIRECT(HLOOKUP(R[-40]C,R[-27]C[-3]:R[-25]C[1],3)),2)*(1-INDIRECT(HLOOKUP(R[-40]C,R[-27]C[-3]:R[-24]C[1],4))))"

-    Range("G53:G54").Select

-    Range("G54").Activate

-    ActiveWindow.SmallScroll Down:=37

-    Range("H91").Select

-    ActiveWindow.SmallScroll Down:=2

-    Range("A96").Select

-    Sheets("GL").Select

-    ActiveWindow.SelectedSheets.Delete

-    Sheets("MTU").Select

-    ActiveWindow.SelectedSheets.Delete

-    ActiveWindow.SmallScroll Down:=-61

-    Range("A24:E26").Select

-    Selection.Borders(xlDiagonalDown).LineStyle = xlNone

-    Selection.Borders(xlDiagonalUp).LineStyle = xlNone

-    With Selection.Borders(xlEdgeLeft)

-        .LineStyle = xlContinuous

-        .Weight = xlMedium

-        .ColorIndex = xlAutomatic

-    End With

-    With Selection.Borders(xlEdgeTop)

-        .LineStyle = xlContinuous

-        .Weight = xlMedium

-        .ColorIndex = xlAutomatic

-    End With

-    With Selection.Borders(xlEdgeBottom)

-        .LineStyle = xlContinuous

-        .Weight = xlMedium

-        .ColorIndex = xlAutomatic

-    End With

-    With Selection.Borders(xlEdgeRight)

-        .LineStyle = xlContinuous

-        .Weight = xlMedium

-        .ColorIndex = xlAutomatic

-    End With

-    Selection.Borders(xlInsideVertical).LineStyle = xlNone

-    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

-    Range("A25").Select

-    ActiveCell.FormulaR1C1 = "Golden Line"

-    Range("E26").Select

-    ActiveWindow.SmallScroll Down:=-12

-    Range("D8").Select

-    ActiveCell.FormulaR1C1 = "64"

-    Rows("9:9").Select

-    Selection.EntireRow.Hidden = True

-    Range("A7:D8").Select

-    Selection.Borders(xlDiagonalDown).LineStyle = xlNone

-    Selection.Borders(xlDiagonalUp).LineStyle = xlNone

-    With Selection.Borders(xlEdgeLeft)

-        .LineStyle = xlContinuous

-        .Weight = xlMedium

-        .ColorIndex = xlAutomatic

-    End With

-    With Selection.Borders(xlEdgeTop)

-        .LineStyle = xlContinuous

-        .Weight = xlMedium

-        .ColorIndex = xlAutomatic

-    End With

-    With Selection.Borders(xlEdgeBottom)

-        .LineStyle = xlContinuous

-        .Weight = xlMedium

-        .ColorIndex = xlAutomatic

-    End With

-    With Selection.Borders(xlEdgeRight)

-        .LineStyle = xlContinuous

-        .Weight = xlMedium

-        .ColorIndex = xlAutomatic

-    End With

-    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

-    Range("D14").Select

-    Selection.ClearContents

-    Range("D21").Select

-    ActiveCell.FormulaR1C1 = "0"

-    Range("E22").Select

-    ActiveWindow.SmallScroll Down:=13

-    Range("D17").Select

-    ActiveCell.FormulaR1C1 = "0"

-    Range("D40").Select

-    ActiveWindow.SmallScroll Down:=15

-    Range("D56").Select

-    ActiveWindow.SmallScroll Down:=-17

-    Range("D17").Select

-    ActiveCell.FormulaR1C1 = "1"

-    Range("D21").Select

-    ActiveCell.FormulaR1C1 = "1"

-    Range("E22").Select

-    ActiveWindow.SmallScroll Down:=17

-    Range("D40").Select

-    ActiveCell.FormulaR1C1 = _

-        "=(R[23]C/R[-6]C)+IF(R[-25]C,R[-25]C*IF(R[-24]C,R[-24]C+1,1),IF(R[-25]C,R[-25]C,HLOOKUP(R[-31]C,INDIRECT(HLOOKUP(R[-27]C,R[-14]C[-3]:R[-13]C[1],2)),2)))LR[-23]C R[-23]C*IF(R[-22]C,R[-22]C+1,1))R[-23]C R[-23]C R[-31]C R[-26]C R[-14]C[-3]:R[-12]C[1] 2 "

-    Range("D41").Select

-    ActiveCell.FormulaR1C1 = _

-        "=CEILING(HLOOKUP(R[-32]C,R[29]C[-3]:R[30]C[28],2)*(HLOOKUP(R[-34]C,R[25]C[-2]:R[26]C[10],2)/R[-7]C)*IF(R[-9]C,R[-9]C,1)+IF(R[-22]C,R[-22]C*IF(R[-21]C,R[-21]C,1),0)+IF(R[-20]C,R[-20]C*IF(R[-19]C,R[-19]C,1),0),1)"

-    Range("D44").Select

-    ActiveCell.FormulaR1C1 = "=CEILING(R[4]C+R[8]C+R[12]C,1)"

-    Range("D45").Select

-    ActiveCell.FormulaR1C1 = "=CEILING(R[4]C+R[8]C+R[12]C,1)"

-    Range("D41").Select

-    ActiveWindow.ScrollRow = 20

-    ActiveWindow.ScrollRow = 13

-    ActiveWindow.SmallScroll Down:=17

-    Range("D41").Select

-    ActiveCell.FormulaR1C1 = _

-        "=HLOOKUP(R[-32]C,R[29]C[-3]:R[30]C[28],2)*(HLOOKUP(R[-34]C,R[25]C[-2]:R[26]C[10],2)/R[-7]C)*IF(R[-9]C,R[-9]C,1)+IF(R[-22]C,R[-22]C*IF(R[-21]C,R[-21]C,1),IF(R[-22]C,R[-22]C,HLOOKUP(R[-32]C,INDIRECT(HLOOKUP(R[-28]C,R[-15]C[-3]:R[-13]C[1],3)),2))))"

-    Range("D41").Select

-    ActiveCell.FormulaR1C1 = _

-        "=HLOOKUP(R[-32]C,R[29]C[-3]:R[30]C[28],2)*(HLOOKUP(R[-34]C,R[25]C[-2]:R[26]C[10],2)/R[-7]C)*IF(R[-9]C,R[-9]C,1)+IF(R[-22]C,R[-22]C*IF(R[-21]C,R[-21]C,1),IF(R[-22]C,R[-22]C,HLOOKUP(R[-32]C,INDIRECT(HLOOKUP(R[-28]C,R[-15]C[-3]:R[-13]C[1],3)),2))))"

-    Range("D41").Select

-    ActiveWindow.LargeScroll Down:=-1

-    Range("D21").Select

-    ActiveCell.FormulaR1C1 = "2"

-    Range("E22").Select

-    ActiveWindow.SmallScroll Down:=14

-    Range("D21").Select

-    ActiveCell.FormulaR1C1 = "1"

-    Range("E23").Select

-    ActiveWindow.SmallScroll Down:=-8

-    Range("D16").Select

-    Selection.ClearContents

-    Range("D18").Select

-    Selection.ClearContents

-    Range("G21").Select

-    ActiveWindow.SmallScroll Down:=23

-    Range("D48").Select

-    ActiveCell.FormulaR1C1 = "=CEILING(R[15]C/R[-14]C*IF(R[-15]C,1-R[-15]C,1),1)"

-    Range("D49").Select

-    ActiveCell.FormulaR1C1 = "=CEILING(R[-8]C*IF(R[-16]C,1-R[-16]C,1),1)"

-    Range("D52").Select

-    ActiveCell.FormulaR1C1 = _

-        "=CEILING(IF(R[-37]C,R[-37]C,HLOOKUP(R[-43]C,INDIRECT(HLOOKUP(R[-39]C,R[-26]C[-3]:R[-23]C[1],2)),2)*(1-INDIRECT(HLOOKUP(R[-39]C,R[-26]C[-3]:R[-23]C[1],4)))),1)"

-    Range("D53").Select

-    ActiveCell.FormulaR1C1 = _

-        "=CEILING(IF(R[-34]C,R[-34]C,HLOOKUP(R[-44]C,INDIRECT(HLOOKUP(R[-40]C,R[-27]C[-3]:R[-25]C[1],3)),2)*(1-INDIRECT(HLOOKUP(R[-40]C,R[-27]C[-3]:R[-24]C[1],4)))),1)"

-    Range("D56").Select

-    ActiveCell.FormulaR1C1 = _

-        "=CEILING(IF(R[-39]C,R[-39]C,HLOOKUP(R[-47]C,INDIRECT(HLOOKUP(R[-42]C,R[-30]C[-3]:R[-27]C[1],2)),2)*(1-INDIRECT(HLOOKUP(R[-42]C,R[-30]C[-3]:R[-27]C[1],4)))),1)"

-    Range("D57").Select

-    ActiveCell.FormulaR1C1 = _

-        "=CEILING(IF(R[-36]C,R[-36]C,HLOOKUP(R[-48]C,INDIRECT(HLOOKUP(R[-43]C,R[-31]C[-3]:R[-29]C[1],3)),2)*(1-INDIRECT(HLOOKUP(R[-43]C,R[-31]C[-3]:R[-28]C[1],4)))),1)"

-    Range("D41").Select

-    ActiveCell.FormulaR1C1 = _

-        "=HLOOKUP(R[-32]C,R[29]C[-3]:R[30]C[28],2)*(HLOOKUP(R[-34]C,R[25]C[-2]:R[26]C[10],2)/R[-7]C)*IF(R[-9]C,R[-9]C,1)+IF(R[-22]C,R[-22]C*IF(R[-21]C,R[-21]C,1),IHLOOKUP(R[-32]C,INDIRECT(HLOOKUP(R[-28]C,R[-15]C[-3]:R[-13]C[1],3)),2))(R[-20]C "

-    Range("D41").Select

-    ActiveCell.FormulaR1C1 = _

-        "=HLOOKUP(R[-32]C,R[29]C[-3]:R[30]C[28],2)*(HLOOKUP(R[-34]C,R[25]C[-2]:R[26]C[10],2)/R[-7]C)*IF(R[-9]C,R[-9]C,1)+IF(R[-22]C,R[-22]C*IF(R[-21]C,R[-21]C,1),HLOOKUP(R[-32]C,INDIRECT(HLOOKUP(R[-28]C,R[-15]C[-3]:R[-13]C[1],3)),2))"

-    Range("D41").Select

-    ActiveCell.FormulaR1C1 = _

-        "=HLOOKUP(R[-32]C,R[29]C[-3]:R[30]C[28],2)*(HLOOKUP(R[-34]C,R[25]C[-2]:R[26]C[10],2)/R[-7]C)*IF(R[-9]C,R[-9]C,1)+IF(R[-22]C,R[-22]C*IF(R[-21]C,R[-21]C,1),HLOOKUP(R[-32]C,INDIRECT(HLOOKUP(R[-28]C,R[-15]C[-3]:R[-13]C[1],3)),2))"

-    Range("D41").Select

-    ActiveCell.FormulaR1C1 = _

-        "=HLOOKUP(R[-32]C,R[29]C[-3]:R[30]C[28],2)*(HLOOKUP(R[-34]C,R[25]C[-2]:R[26]C[10],2)/R[-7]C)*IF(R[-9]C,R[-9]C,1)+IF(R[-22]C,R[-22]C*IF(R[-21]C,R[-21]C,1),HLOOKUP(R[-32]C,INDIRECT(HLOOKUP(R[-28]C,R[-15]C[-3]:R[-12]C[1],3)),2))"

-    Range("D41").Select

-    ActiveWindow.LargeScroll Down:=-1

-    ActiveWindow.SmallScroll Down:=14

-    ActiveWindow.LargeScroll Down:=-1

-    ActiveCell.FormulaR1C1 = _

-        "=HLOOKUP(R[-32]C,R[29]C[-3]:R[30]C[28],2)*(HLOOKUP(R[-34]C,R[25]C[-2]:R[26]C[10],2)/R[-7]C)*IF(R[-9]C,R[-9]C,1)+IF(R[-22]C,R[-22]C*IF(R[-21]C,R[-21]C,1),HLOOKUP(R[-32]C,INDIRECT(HLOOKUP(R[-28]C,R[-15]C[-3]:R[-12]C[1],3)),2))"

-    ActiveWindow.SmallScroll Down:=12

-    ActiveCell.FormulaR1C1 = _

-        "=HLOOKUP(R[-32]C,R[29]C[-3]:R[30]C[28],2)*(HLOOKUP(R[-34]C,R[25]C[-2]:R[26]C[10],2)/R[-7]C)*IF(R[-9]C,R[-9]C,1)+IF(R[-22]C,R[-22]C*IF(R[-21]C,R[-21]C,1),HLOOKUP(R[-32]C,INDIRECT(HLOOKUP(R[-28]C,R[-15]C[-3]:R[-12]C[1],2)),2))&R[-20]C "

-    Range("D49").Select

-    ActiveCell.FormulaR1C1 = _

-        "=CEILING(HLOOKUP(R[-40]C,R[21]C[-3]:R[22]C[28],2)*(HLOOKUP(R[-42]C,R[17]C[-2]:R[18]C[10],2)/R[-15]C)*IF(R[-17]C,R[-17]C,1)*IF(R[-16]C,1-R[-16]C,1),1)"

-    Range("D45").Select

-    ActiveWindow.SmallScroll Down:=4

-    Range("D49").Select

-    ActiveWindow.SmallScroll Down:=-27

-    Range("D7").Select

-    ActiveCell.FormulaR1C1 = "100"

-    Range("D8").Select

-    ActiveWindow.SmallScroll Down:=0

-    Range("D7").Select

-    ActiveCell.FormulaR1C1 = "10"

-    Range("D8").Select

-    ActiveWindow.SmallScroll Down:=39

-    Range("D49").Select

-    ActiveWindow.SmallScroll Down:=-4

-    Range("D41").Select

-    ActiveWindow.SmallScroll Down:=17

-    ActiveWindow.LargeScroll Down:=-2

-    ActiveWindow.SmallScroll Down:=24

-    Range("D41").Select

-    ActiveWindow.LargeScroll Down:=-1

-    ActiveWindow.SmallScroll Down:=44

-    ActiveWindow.LargeScroll Down:=-2

-    Rows("30:30").Select

-    Selection.Insert Shift:=xlDown

-    Range("A27").Select

-    ActiveCell.FormulaR1C1 = "A83:F84"

-    Range("A28").Select

-    ActiveCell.FormulaR1C1 = "A87:F88"

-    Range("A29").Select

-    ActiveCell.FormulaR1C1 = "A91"

-    Range("A30").Select

-    ActiveWindow.SmallScroll Down:=17

-    Range("D42").Select

-    ActiveCell.FormulaR1C1 = _

-        "=CEILING(HLOOKUP(R[-33]C,R[29]C[-3]:R[30]C[28],2)*(HLOOKUP(R[-35]C,R[25]C[-2]:R[26]C[10],2)/R[-7]C)*IF(R[-9]C,R[-9]C,1),1)"

-    ActiveCell.FormulaR1C1 = _

-        "=HLOOKUP(R[-33]C,R[29]C[-3]:R[30]C[28],2)*(HLOOKUP(R[-35]C,R[25]C[-2]:R[26]C[10],2)/R[-7]C)*IF(R[-9]C,R[-9]C,1)+IF(R[-23]C,R[-23]C*IF(R[-22]C,R[-22]C,1),HLOOKUP(R[-33]C,INDIRECT(HLOOKUP(R[-29]C,R[-16]C[-3]:R[-13]C[1],2)),2))"

-    ActiveWindow.LargeScroll Down:=-1

-    Rows("21:21").Select

-    ActiveWindow.SmallScroll Down:=24

-    Range("D42").Select

-    ActiveWindow.SmallScroll Down:=14

-    ActiveWindow.LargeScroll Down:=-2

-    ActiveWindow.SmallScroll Down:=53

-    ActiveWindow.LargeScroll Down:=-2

-    ActiveWindow.SmallScroll Down:=23

-    Range("D42").Select

-    ActiveCell.FormulaR1C1 = _

-        "=HLOOKUP(R[-33]C,R[29]C[-3]:R[30]C[28],2)*(HLOOKUP(R[-35]C,R[25]C[-2]:R[26]C[10],2)/R[-7]C)*IF(R[-9]C,R[-9]C,1)+IF(R[-23]C,R[-23]C*IF(R[-22]C,R[-22]C,1),HLOOKUP(R[-33]C,INDIRECT(HLOOKUP(R[-29]C,R[-16]C[-3]:R[-13]C[1],3)),2))R[-21]C "

-    Range("D41").Select

-    ActiveCell.FormulaR1C1 = _

-        "=(R[23]C/R[-6]C)+IF(R[-26]C,R[-26]C*IF(R[-25]C,R[-25]C+1,1),IF(R[-26]C,R[-26]C,HLOOKUP(R[-32]C,INDIRECT(HLOOKUP(R[-28]C,R[-15]C[-3]:R[-12]C[1],2)),2)))"

-    Range("D50").Select

-    ActiveWindow.SmallScroll Down:=5

-    Range("G50").Select

-    ActiveWindow.SmallScroll Down:=-26

-    Range("D7").Select

-    ActiveCell.FormulaR1C1 = "720"

-    Range("E7").Select

-    ActiveWindow.SmallScroll Down:=51

-    ActiveWindow.LargeScroll Down:=-2

-    ActiveWindow.SmallScroll Down:=5

-    Range("D8").Select

-    ActiveCell.FormulaR1C1 = "128"

-    Range("E8").Select

-    ActiveWindow.SmallScroll Down:=29

-    ActiveWindow.ScrollRow = 1

-    Range("D8").Select

-    ActiveCell.FormulaR1C1 = "256"

-    Range("G12").Select

-    ActiveWindow.SmallScroll Down:=25

-    ActiveWindow.ScrollRow = 1

-    ActiveWindow.SmallScroll Down:=0

-    Range("D8").Select

-    ActiveCell.FormulaR1C1 = "512"

-    Range("D10").Select

-    ActiveWindow.SmallScroll Down:=31

-    ActiveWindow.ScrollRow = 1

-    Range("D8").Select

-    ActiveCell.FormulaR1C1 = "1024"

-    Range("F12").Select

-    ActiveWindow.SmallScroll Down:=4

-    Range("D8").Select

-    ActiveCell.FormulaR1C1 = "2048"

-    Range("E8").Select

-    ActiveWindow.SmallScroll Down:=42

-    Range("D75").Select

-    ActiveWindow.SmallScroll Down:=1

-    Range("A60:C60").Select

-    Selection.Borders(xlDiagonalDown).LineStyle = xlNone

-    Selection.Borders(xlDiagonalUp).LineStyle = xlNone

-    Selection.Borders(xlEdgeLeft).LineStyle = xlNone

-    Selection.Borders(xlEdgeTop).LineStyle = xlNone

-    With Selection.Borders(xlEdgeBottom)

-        .LineStyle = xlDouble

-        .Weight = xlThick

-        .ColorIndex = xlAutomatic

-    End With

-    Selection.Borders(xlEdgeRight).LineStyle = xlNone

-    Selection.Borders(xlInsideVertical).LineStyle = xlNone

-    Range("D60").Select

-    ActiveCell.FormulaR1C1 = "НИЧЕГО НЕ ТРОГАТЬ НИЖЕ ЭТОЙ ЧЕРТЫ"

-    Range("D60").Select

-    Selection.Font.Bold = True

-    Range("I60:N60").Select

-    Selection.Borders(xlDiagonalDown).LineStyle = xlNone

-    Selection.Borders(xlDiagonalUp).LineStyle = xlNone

-    Selection.Borders(xlEdgeLeft).LineStyle = xlNone

-    Selection.Borders(xlEdgeTop).LineStyle = xlNone

-    With Selection.Borders(xlEdgeBottom)

-        .LineStyle = xlDouble

-        .Weight = xlThick

-        .ColorIndex = xlAutomatic

-    End With

-    Selection.Borders(xlEdgeRight).LineStyle = xlNone

-    Selection.Borders(xlInsideVertical).LineStyle = xlNone

-    Range("F61").Select

-    ActiveWindow.SmallScroll Down:=-47

-    ChDir "N:\Info\Telecom\Leased-lines"

-    ActiveWorkbook.SaveAs FileName:="N:\Info\Telecom\Leased-lines\Calculator.xls" _

-        , FileFormat:=xlNormal, Password:="", WriteResPassword:="", _

-        ReadOnlyRecommended:=False, CreateBackup:=False

-    Range("A24").Select

-    Selection.Font.Bold = True

-    Range("A25:E25").Select

-    Selection.Font.Italic = True

-    Range("A26:E26").Select

-    Selection.Font.Bold = True

-    Range("A25:E25").Select

-    Selection.Borders(xlDiagonalDown).LineStyle = xlNone

-    Selection.Borders(xlDiagonalUp).LineStyle = xlNone

-    With Selection.Borders(xlEdgeLeft)

-        .LineStyle = xlContinuous

-        .Weight = xlMedium

-        .ColorIndex = xlAutomatic

-    End With

-    With Selection.Borders(xlEdgeTop)

-        .LineStyle = xlContinuous

-        .Weight = xlThin

-        .ColorIndex = xlAutomatic

-    End With

-    With Selection.Borders(xlEdgeBottom)

-        .LineStyle = xlContinuous

-        .Weight = xlThin

-        .ColorIndex = xlAutomatic

-    End With

-    With Selection.Borders(xlEdgeRight)

-        .LineStyle = xlContinuous

-        .Weight = xlMedium

-        .ColorIndex = xlAutomatic

-    End With

-    Selection.Borders(xlInsideVertical).LineStyle = xlNone

-    Rows("27:29").Select

-    Selection.EntireRow.Hidden = True

-    Range("I31").Select

-    ActiveWindow.SmallScroll Down:=54

-    Rows("62:144").Select

-    Selection.EntireRow.Hidden = True

-    Range("D157").Select

-    ActiveWindow.SmallScroll Down:=-36

-    ActiveWorkbook.Save

-    Application.Dialogs(xlDialogSendMail).Show

-    ActiveWorkbook.RunAutoMacros Which:=xlAutoClose

-End Sub

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Function ChkIncrease(aRange As Range) As Integer

-    Dim res As Integer

-    Dim areaCount As Long

-    areaCount = aRange.Count

-    res = 0

-    If areaCount > 1 Then

-        For i = 1 To areaCount - 1

-            If aRange(i).Value <= aRange(i + 1).Value Then

-                res = res + 1

-            End If

-        Next i

-    Else

-        res = -1

-    End If

-    

-    If (res = areaCount - 1) Then

-        ChkIncrease = 1

-    Else

-        ChkIncrease = 0

-    End If

-End Function

-

-Function ChkDecrease(aRange As Range) As Integer

-    Dim res As Integer

-    Dim areaCount As Long

-    areaCount = aRange.Count

-    res = 0

-    If areaCount > 1 Then

-        For i = 1 To areaCount - 1

-            If aRange(i).Value >= aRange(i + 1).Value Then

-                res = res + 1

-            End If

-        Next i

-    Else

-        res = -1

-    End If

-    

-    If (res = areaCount - 1) Then

-        ChkDecrease = 1

-    Else

-        ChkDecrease = 0

-    End If

-End Function

-

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Function CheckRange(aRange As Range) As Integer

-    Dim res As Integer

-    Dim areaCount As Long

-    areaCount = aRange.Count

-    res = 0

-    If areaCount > 1 Then

-        For i = 1 To areaCount - 1

-            If aRange(i).Value <= aRange(i + 1).Value Then

-                res = res + 1

-            End If

-        Next i

-    Else

-        res = -1

-    End If

-    

-    If (res = areaCount - 1) Then

-        CheckRange = 1

-    Else

-        CheckRange = 0

-    End If

-End Function

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Function ChkIncrease(aRange As Range) As Integer

-    Dim res As Integer

-    Dim areaCount As Long

-    areaCount = aRange.Count

-    res = 0

-    If areaCount > 1 Then

-        For i = 1 To areaCount - 1

-            If aRange(i).Value <= aRange(i + 1).Value Then

-                res = res + 1

-            End If

-        Next i

-    Else

-        res = -1

-    End If

-    

-    If (res = areaCount - 1) Then

-        ChkIncrease = 1

-    Else

-        ChkIncrease = 0

-    End If

-End Function

-

-Function ChkDecrease(aRange As Range) As Integer

-    Dim res As Integer

-    Dim areaCount As Long

-    areaCount = aRange.Count

-    res = 0

-    If areaCount > 1 Then

-        For i = 1 To areaCount - 1

-            If aRange(i).Value >= aRange(i + 1).Value Then

-                res = res + 1

-            End If

-        Next i

-    Else

-        res = -1

-    End If

-    

-    If (res = areaCount - 1) Then

-        ChkDecrease = 1

-    Else

-        ChkDecrease = 0

-    End If

-End Function

-

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Option Explicit

-

-Sub Click()

-

-End Sub

-

-

-Sub SaveSettings()

-    ThisWorkbook.Save

-End Sub

-

-Sub gotohome()

-    Sheets("Home").Select

-    Range("A1").Select

-End Sub

-

-Sub gotolist()

-    Sheets("SiteList").Select

-    Range("A1").Select

-End Sub

-

-Private Sub Workbook_Open()

-    MsgBox ("ok")

-    gotohome

-End Sub

-

-Option Explicit

-

-Sub DeleteSite()

-    MsgBox "Вы уверены", vbOKCancel, "Удаление"

-End Sub

-

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet19
->>>>>>
-Attribute VB_Name = "Sheet19"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Module2
->>>>>>
-Attribute VB_Name = "Module2"

-Option Explicit

-

-Sub Add_Tarif()

-    Dim s As String

-    s = InputBox("Укажите новое имя", "Добавление нового")

-End Sub

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-AppEv_ISP
->>>>>>
-Attribute VB_Name = "AppEv_ISP"

-

-

-Sub dummy()

-Attribute dummy.VB_ProcData.VB_Invoke_Func = " \n14"

-

-End Sub

-

-Sub Set_Default_Hosting()

-Attribute Set_Default_Hosting.VB_ProcData.VB_Invoke_Func = " \n14"

-    With ThisWorkbook.Worksheets("Prices.Hosting")

-        .Range("C5") = 1

-        .Range("c18") = 1

-        .Range("c23") = 1

-    End With

-End Sub

-

-Sub Set_Default_Intel()

-Attribute Set_Default_Intel.VB_ProcData.VB_Invoke_Func = " \n14"

-    With ThisWorkbook.Worksheets("Prices.Intel")

-        If .Range("B3") = 1 Then ' ISP 1100

-            .Range("b9") = 1

-            .Range("f15") = 1

-            .Range("b21") = 1

-            .Range("b30") = 1

-            .Range("b37") = 1

-            .Range("b45") = 1

-            .Range("b51") = 1

-            .Range("b57") = 1

-        Else

-            .Range("f9") = 1

-            .Range("f15") = 1

-            .Range("f21") = 1

-            .Range("f30") = 1

-            .Range("f37") = 1

-            .Range("f45") = 1

-            .Range("f51") = 1

-            .Range("f57") = 1

-        End If

-    End With

-

-End Sub

-

-Sub evISP_ModelChange()

-Attribute evISP_ModelChange.VB_ProcData.VB_Invoke_Func = " \n14"

-    SetCPUList

-    SetRAMList

-    SetHDDList

-    SetADDList

-    Set_Default_Intel

-End Sub

-

-Sub SetCPUList()

-Attribute SetCPUList.VB_ProcData.VB_Invoke_Func = " \n14"

-    Dim NewCbxRange, NewCbxIndex As String

-    With ThisWorkbook.Worksheets("Prices.Intel")

-        If .Range("B3") = 1 Then ' ISP 1100

-            NewCbxRange = .Name & "!" & .Range("b10:b12").Address

-            NewCbxIndex = .Name & "!" & .Range("b9").Address

-        Else

-            NewCbxRange = .Name & "!" & .Range("f10:f11").Address

-            NewCbxIndex = .Name & "!" & .Range("f9").Address

-        End If

-    End With

-    With ThisWorkbook.Worksheets("Intel-ISP").Shapes("ISP_CPU")

-        .ControlFormat.ListFillRange = NewCbxRange

-        .ControlFormat.LinkedCell = NewCbxIndex

-    End With

-    With ThisWorkbook.Worksheets("Prices.Intel")

-        If .Range("B3") = 1 Then ' ISP 1100

-            NewCbxRange = .Name & "!" & .Range("b16:b16").Address

-            NewCbxIndex = .Name & "!" & .Range("b15").Address

-        Else

-            NewCbxRange = .Name & "!" & .Range("f16:f17").Address

-            NewCbxIndex = .Name & "!" & .Range("f15").Address

-        End If

-    End With

-    With ThisWorkbook.Worksheets("Intel-ISP").Shapes("ISP_CPU_CNT")

-        .ControlFormat.ListFillRange = NewCbxRange

-        .ControlFormat.LinkedCell = NewCbxIndex

-    End With

-End Sub

-

-Sub SetRAMList()

-Attribute SetRAMList.VB_ProcData.VB_Invoke_Func = " \n14"

-    Dim NewCbxRange, NewCbxIndex As String

-    With ThisWorkbook.Worksheets("Prices.Intel")

-        If .Range("B3") = 1 Then ' ISP 1100

-            NewCbxRange = .Name & "!" & .Range("b22:b26").Address

-            NewCbxIndex = .Name & "!" & .Range("b21").Address

-        Else

-            NewCbxRange = .Name & "!" & .Range("f22:f26").Address

-            NewCbxIndex = .Name & "!" & .Range("f21").Address

-        End If

-    End With

-    With ThisWorkbook.Worksheets("Intel-ISP").Shapes("ISP_RAM")

-        .ControlFormat.ListFillRange = NewCbxRange

-        .ControlFormat.LinkedCell = NewCbxIndex

-    End With

-End Sub

-

-Sub SetHDDList()

-Attribute SetHDDList.VB_ProcData.VB_Invoke_Func = " \n14"

-    Dim NewCbxRange, NewCbxIndex As String

-    With ThisWorkbook.Worksheets("Prices.Intel")

-        If .Range("B3") = 1 Then ' ISP 1100

-            NewCbxRange = .Name & "!" & .Range("b31:b33").Address

-            NewCbxIndex = .Name & "!" & .Range("b30").Address

-        Else

-            NewCbxRange = .Name & "!" & .Range("f31:f33").Address

-            NewCbxIndex = .Name & "!" & .Range("f30").Address

-        End If

-    End With

-    With ThisWorkbook.Worksheets("Intel-ISP").Shapes("ISP_HDD")

-        .ControlFormat.ListFillRange = NewCbxRange

-        .ControlFormat.LinkedCell = NewCbxIndex

-    End With

-    With ThisWorkbook.Worksheets("Prices.Intel")

-        If .Range("B3") = 1 Then ' ISP 1100

-            NewCbxRange = .Name & "!" & .Range("b38:b39").Address

-            NewCbxIndex = .Name & "!" & .Range("b37").Address

-        Else

-            NewCbxRange = .Name & "!" & .Range("f38:f41").Address

-            NewCbxIndex = .Name & "!" & .Range("f37").Address

-        End If

-    End With

-    With ThisWorkbook.Worksheets("Intel-ISP").Shapes("ISP_HDD_CNT")

-        .ControlFormat.ListFillRange = NewCbxRange

-        .ControlFormat.LinkedCell = NewCbxIndex

-    End With

-End Sub

-

-Sub SetADDList()

-Attribute SetADDList.VB_ProcData.VB_Invoke_Func = " \n14"

-    Dim NewCbxRange, NewCbxIndex As String

-    With ThisWorkbook.Worksheets("Prices.Intel")

-        If .Range("B3") = 1 Then ' ISP 1100

-            NewCbxRange = .Name & "!" & .Range("b46:b47").Address

-            NewCbxIndex = .Name & "!" & .Range("b45").Address

-        Else

-            NewCbxRange = .Name & "!" & .Range("f46:f47").Address

-            NewCbxIndex = .Name & "!" & .Range("f45").Address

-        End If

-    End With

-    With ThisWorkbook.Worksheets("Intel-ISP").Shapes("ISP_CDRW")

-        .ControlFormat.ListFillRange = NewCbxRange

-        .ControlFormat.LinkedCell = NewCbxIndex

-    End With

-    With ThisWorkbook.Worksheets("Prices.Intel")

-        If .Range("B3") = 1 Then ' ISP 1100

-            NewCbxRange = .Name & "!" & .Range("b52:b53").Address

-            NewCbxIndex = .Name & "!" & .Range("b51").Address

-        Else

-            NewCbxRange = .Name & "!" & .Range("f52:f52").Address

-            NewCbxIndex = .Name & "!" & .Range("f51").Address

-        End If

-    End With

-    With ThisWorkbook.Worksheets("Intel-ISP").Shapes("ISP_SVGA")

-        .ControlFormat.ListFillRange = NewCbxRange

-        .ControlFormat.LinkedCell = NewCbxIndex

-    End With

-    With ThisWorkbook.Worksheets("Prices.Intel")

-        If .Range("B3") = 1 Then ' ISP 1100

-            NewCbxRange = .Name & "!" & .Range("b58:b59").Address

-            NewCbxIndex = .Name & "!" & .Range("b57").Address

-        Else

-            NewCbxRange = .Name & "!" & .Range("f58:f59").Address

-            NewCbxIndex = .Name & "!" & .Range("f57").Address

-        End If

-    End With

-    With ThisWorkbook.Worksheets("Intel-ISP").Shapes("ISP_ETH2")

-        .ControlFormat.ListFillRange = NewCbxRange

-        .ControlFormat.LinkedCell = NewCbxIndex

-    End With

-End Sub

-

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag lengthProject Name : 'VBAProject'
-Quirk - duff tag lengthProject Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Sub Home_Click()

-Attribute Home_Click.VB_Description = "Macro recorded 11/04/2001 by Nickolai Garbuz"

-Attribute Home_Click.VB_ProcData.VB_Invoke_Func = " \n14"

-    Sheets("Home").Select

-    Range("A1").Select

-End Sub

-Sub CPriceDraft_Click()

-    Sheets("Price.Draft").Select

-    Range("A1").Select

-End Sub

-Sub COperSetup_Click()

-    Sheets("Operators.Setup").Select

-    Range("A1").Select

-End Sub

-Sub COperPrice_Click()

-    Sheets("Operators.Price").Select

-    Range("A1").Select

-End Sub

-Sub CDealerSetup_Click()

-    Sheets("Dealers.Setup").Select

-    Range("A1").Select

-End Sub

-Sub CDealerPrice_Click()

-    Sheets("Dealers.Price").Select

-    Range("A1").Select

-End Sub

-

-Sub CClientSetup_Click()

-    Sheets("Corporate.Setup").Select

-    Range("A1").Select

-End Sub

-Sub CClientGPL_Click()

-    Sheets("Corporate.GPL").Select

-    Range("A1").Select

-End Sub

-Sub CClientGPL10_Click()

-    Sheets("Corporate.GPL-10").Select

-    Range("A1").Select

-End Sub

-Sub CClientGPL20_Click()

-    Sheets("Corporate.GPL-20").Select

-    Range("A1").Select

-End Sub

-

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Option Explicit

-

-Const SCAN_ROW As String = "C3"

-Const PRICE_COUNT As Integer = 4

-Const PROFIT_TABLE As String = "AA1"

-Const CORRECTION_TABLE As String = "M1"

-

-

-Sub RecalcRouting()

-    Dim Src As Range

-    Dim Dst As Range

-    Dim Tst As Range

-    Dim Scan As Range

-    Dim Disp As Range

-    Dim i As Integer

-    Dim j As Integer

-    Dim IgnBad As Boolean

-    

-    Set Scan = ThisWorkbook.Worksheets("CompactPrices").Range(SCAN_ROW)

-    

-   Application.Calculation = xlCalculationManual

-   

-    With ThisWorkbook.Worksheets("Function")

-        Set Disp = .Range("Display")

-        

-        Disp = GetLinesCount(Scan)

-        IgnBad = .Range("NoBad")

-        

-        If .Range("RestRout") = True Then

-            Disp = Disp * 2

-            RestoreRouting IgnBad, Disp

-        End If

-    End With

-    

-    With ThisWorkbook.Worksheets("CompactPrices")

-        Set Scan = .Range(SCAN_ROW)

-        

-        While Scan <> ""

-            

-            Disp = Disp - 1

-            

-            Set Src = .Range(PROFIT_TABLE).Offset(Scan.Row - 1, 0)

-            Set Tst = .Range(CORRECTION_TABLE).Offset(Scan.Row - 1, 0)

-            

-' Расчет приоритетов по цене

-            For i = 0 To PRICE_COUNT - 1

-                Src.Offset(0, PRICE_COUNT + i) = "-"

-                If Application.WorksheetFunction.IsNumber(Src.Offset(0, i)) Then

-                    Src.Offset(0, PRICE_COUNT + i) = 4

-                    For j = 0 To PRICE_COUNT - 1

-                        Set Dst = Src.Offset(0, j)

-                        If Src.Offset(0, i).Address <> Dst.Address Then

-                            If Application.WorksheetFunction.IsNumber(Dst) Then

-                                If Tst.Offset(0, i) = Tst.Offset(0, j) Then

-                                    If Src.Offset(0, i) > Dst Then

-                                        Src.Offset(0, PRICE_COUNT + i) = Src.Offset(0, PRICE_COUNT + i) - 1

-                                    End If

-                                Else

-                                    If Tst.Offset(0, i) < Tst.Offset(0, j) Then

-                                        Src.Offset(0, PRICE_COUNT + i) = Src.Offset(0, PRICE_COUNT + i) - 1

-                                    End If

-                                End If

-                            Else

-                               Src.Offset(0, PRICE_COUNT + i) = Src.Offset(0, PRICE_COUNT + i) - 1

-                            End If

-                        End If

-                    Next j

-                End If

-            Next i

-

-' Коректировка приоритетов

-            For i = 0 To PRICE_COUNT - 1

-                Set Src = .Range(PROFIT_TABLE).Offset(Scan.Row - 1, PRICE_COUNT + i)

-                If Src <> "-" Then

-                    For j = PRICE_COUNT - 1 To 0 Step -1

-                        Set Dst = .Range(PROFIT_TABLE).Offset(Scan.Row - 1, PRICE_COUNT + j)

-                        If Dst <> "-" Then

-                            If Src.Address <> Dst.Address Then

-                                If Src = Dst Then

-                                    If Tst.Offset(0, i) = Tst.Offset(0, j) Then

-                                        If i < j Then

-                                            Src = Src - 1

-                                        Else

-                                            Dst = Dst - 1

-                                        End If

-                                    Else

-                                        If Tst.Offset(0, i) < Tst.Offset(0, j) Then

-                                            Src = Src - 1

-                                        Else

-                                            Dst = Dst - 1

-                                        End If

-                                    End If

-                                End If

-                            End If

-                        End If

-                    Next j

-                End If

-            Next i

-

-

-            Set Scan = Scan.Offset(1, 0)

-        Wend

-        With Application

-            .Calculate

-            .Calculation = xlCalculationAutomatic

-        End With

-    End With

-End Sub

-

-Sub RestoreRouting(BadIgnore As Boolean, Disp As Range)

-    Dim Src As Range

-    Dim Dst As Range

-    Dim Scan As Range

-    Dim i As Integer

-    

-    With ThisWorkbook.Worksheets("CompactPrices")

-        Set Scan = .Range(SCAN_ROW)

-        Set Src = .Range(PROFIT_TABLE)

-        Set Dst = .Range(CORRECTION_TABLE)

-        

-        While Scan <> ""

-            Disp = Disp - 1

-            For i = 0 To PRICE_COUNT - 1

-                Dst.Offset(Scan.Row - 1, i) = 1

-            Next i

-            .Calculate

-lChkAgain:

-            For i = 0 To PRICE_COUNT - 1

-                If Application.WorksheetFunction.IsNumber(Src.Offset(Scan.Row - 1, i)) Then

-                    If BadIgnore Then

-                        If Src.Offset(Scan.Row - 1, i) < 0 Then

-                            Dst.Offset(Scan.Row - 1, i) = ""

-                            Application.Calculate

-                        End If

-                    End If

-                Else

-                    Dst.Offset(Scan.Row - 1, i) = ""

-                End If

-            Next i

-                        

-            If BadIgnore Then

-                .Calculate

-                

-                For i = 0 To PRICE_COUNT - 1

-                    If Src.Offset(Scan.Row - 1, i) < 0 Then

-                        GoTo lChkAgain

-                    End If

-                Next i

-            End If

-                        

-            Set Scan = Scan.Offset(1, 0)

-        Wend

-        

-    End With

-End Sub

-

-Function GetLinesCount(r As Range) As Integer

-

-    Dim LinesCount As Integer

-    Dim rr As Range

-

-    Set rr = r

- 

-    LinesCount = 0

-    

-    While rr <> ""

-        LinesCount = LinesCount + 1

-        Set rr = rr.Offset(1, 0)

-    Wend

-    

-    GetLinesCount = LinesCount

-End Function

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Option Explicit

-

-Const SCAN_ROW As String = "C3"

-Const PRICE_COUNT As Integer = 4

-Const PROFIT_TABLE As String = "AA1"

-Const CORRECTION_TABLE As String = "M1"

-

-

-Sub RecalcRouting()

-Attribute RecalcRouting.VB_ProcData.VB_Invoke_Func = " \n14"

-    Dim Src As Range

-    Dim Dst As Range

-    Dim Tst As Range

-    Dim Scan As Range

-    Dim Disp As Range

-    Dim i As Integer

-    Dim j As Integer

-    Dim IgnBad As Boolean

-    

-    Set Scan = ThisWorkbook.Worksheets("CompactPrices").Range(SCAN_ROW)

-    

-   Application.Calculation = xlCalculationManual

-   

-    With ThisWorkbook.Worksheets("Function")

-        Set Disp = .Range("Display")

-        

-        Disp = GetLinesCount(Scan)

-        IgnBad = .Range("NoBad")

-        

-        If .Range("RestRout") = True Then

-            Disp = Disp * 2

-            RestoreRouting IgnBad, Disp

-        End If

-    End With

-    

-    With ThisWorkbook.Worksheets("CompactPrices")

-        Set Scan = .Range(SCAN_ROW)

-        

-        While Scan <> ""

-            

-            Disp = Disp - 1

-            

-            Set Src = .Range(PROFIT_TABLE).Offset(Scan.Row - 1, 0)

-            Set Tst = .Range(CORRECTION_TABLE).Offset(Scan.Row - 1, 0)

-            

-' Расчет приоритетов по цене

-            For i = 0 To PRICE_COUNT - 1

-                Src.Offset(0, PRICE_COUNT + i) = "-"

-                If Application.WorksheetFunction.IsNumber(Src.Offset(0, i)) Then

-                    Src.Offset(0, PRICE_COUNT + i) = 4

-                    For j = 0 To PRICE_COUNT - 1

-                        Set Dst = Src.Offset(0, j)

-                        If Src.Offset(0, i).Address <> Dst.Address Then

-                            If Application.WorksheetFunction.IsNumber(Dst) Then

-                                If Tst.Offset(0, i) = Tst.Offset(0, j) Then

-                                    If Src.Offset(0, i) > Dst Then

-                                        Src.Offset(0, PRICE_COUNT + i) = Src.Offset(0, PRICE_COUNT + i) - 1

-                                    End If

-                                Else

-                                    If Tst.Offset(0, i) < Tst.Offset(0, j) Then

-                                        Src.Offset(0, PRICE_COUNT + i) = Src.Offset(0, PRICE_COUNT + i) - 1

-                                    End If

-                                End If

-                            Else

-                               Src.Offset(0, PRICE_COUNT + i) = Src.Offset(0, PRICE_COUNT + i) - 1

-                            End If

-                        End If

-                    Next j

-                End If

-            Next i

-

-' Коректировка приоритетов

-            For i = 0 To PRICE_COUNT - 1

-                Set Src = .Range(PROFIT_TABLE).Offset(Scan.Row - 1, PRICE_COUNT + i)

-                If Src <> "-" Then

-                    For j = PRICE_COUNT - 1 To 0 Step -1

-                        Set Dst = .Range(PROFIT_TABLE).Offset(Scan.Row - 1, PRICE_COUNT + j)

-                        If Dst <> "-" Then

-                            If Src.Address <> Dst.Address Then

-                                If Src = Dst Then

-                                    If Tst.Offset(0, i) = Tst.Offset(0, j) Then

-                                        If i < j Then

-                                            Src = Src - 1

-                                        Else

-                                            Dst = Dst - 1

-                                        End If

-                                    Else

-                                        If Tst.Offset(0, i) < Tst.Offset(0, j) Then

-                                            Src = Src - 1

-                                        Else

-                                            Dst = Dst - 1

-                                        End If

-                                    End If

-                                End If

-                            End If

-                        End If

-                    Next j

-                End If

-            Next i

-

-

-            Set Scan = Scan.Offset(1, 0)

-        Wend

-        With Application

-            .Calculate

-            .Calculation = xlCalculationAutomatic

-        End With

-    End With

-End Sub

-

-Sub RestoreRouting(BadIgnore As Boolean, Disp As Range)

-Attribute RestoreRouting.VB_ProcData.VB_Invoke_Func = " \n14"

-    Dim Src As Range

-    Dim Dst As Range

-    Dim Scan As Range

-    Dim i As Integer

-    

-    With ThisWorkbook.Worksheets("CompactPrices")

-        Set Scan = .Range(SCAN_ROW)

-        Set Src = .Range(PROFIT_TABLE)

-        Set Dst = .Range(CORRECTION_TABLE)

-        

-        While Scan <> ""

-            Disp = Disp - 1

-            For i = 0 To PRICE_COUNT - 1

-                Dst.Offset(Scan.Row - 1, i) = 1

-            Next i

-            .Calculate

-lChkAgain:

-            For i = 0 To PRICE_COUNT - 1

-                If Application.WorksheetFunction.IsNumber(Src.Offset(Scan.Row - 1, i)) Then

-                    If BadIgnore Then

-                        If Src.Offset(Scan.Row - 1, i) < 0 Then

-                            Dst.Offset(Scan.Row - 1, i) = ""

-                            Application.Calculate

-                        End If

-                    End If

-                Else

-                    Dst.Offset(Scan.Row - 1, i) = ""

-                End If

-            Next i

-                        

-            If BadIgnore Then

-                .Calculate

-                

-                For i = 0 To PRICE_COUNT - 1

-                    If Src.Offset(Scan.Row - 1, i) < 0 Then

-                        GoTo lChkAgain

-                    End If

-                Next i

-            End If

-                        

-            Set Scan = Scan.Offset(1, 0)

-        Wend

-        

-    End With

-End Sub

-

-Function GetLinesCount(r As Range) As Integer

-Attribute GetLinesCount.VB_ProcData.VB_Invoke_Func = " \n14"

-

-    Dim LinesCount As Integer

-    Dim rr As Range

-

-    Set rr = r

- 

-    LinesCount = 0

-    

-    While rr <> ""

-        LinesCount = LinesCount + 1

-        Set rr = rr.Offset(1, 0)

-    Wend

-    

-    GetLinesCount = LinesCount

-End Function

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Option Explicit

-

-Const SCAN_ROW As String = "C3"

-Const PRICE_COUNT As Integer = 4

-Const PROFIT_TABLE As String = "AA1"

-Const CORRECTION_TABLE As String = "M1"

-

-

-Sub RecalcRouting()

-Attribute RecalcRouting.VB_ProcData.VB_Invoke_Func = " \n14"

-    Dim Src As Range

-    Dim Dst As Range

-    Dim Tst As Range

-    Dim Scan As Range

-    Dim Disp As Range

-    Dim i As Integer

-    Dim j As Integer

-    Dim IgnBad As Boolean

-    

-    Set Scan = ThisWorkbook.Worksheets("CompactPrices").Range(SCAN_ROW)

-    

-   Application.Calculation = xlCalculationManual

-   

-    With ThisWorkbook.Worksheets("Function")

-        Set Disp = .Range("Display")

-        

-        Disp = GetLinesCount(Scan)

-        IgnBad = .Range("NoBad")

-        

-        If .Range("RestRout") = True Then

-            Disp = Disp * 2

-            RestoreRouting IgnBad, Disp

-        End If

-    End With

-    

-    With ThisWorkbook.Worksheets("CompactPrices")

-        Set Scan = .Range(SCAN_ROW)

-        

-        While Scan <> ""

-            

-            Disp = Disp - 1

-            

-            Set Src = .Range(PROFIT_TABLE).Offset(Scan.Row - 1, 0)

-            Set Tst = .Range(CORRECTION_TABLE).Offset(Scan.Row - 1, 0)

-            

-' Расчет приоритетов по цене

-            For i = 0 To PRICE_COUNT - 1

-                Src.Offset(0, PRICE_COUNT + i) = "-"

-                If Application.WorksheetFunction.IsNumber(Src.Offset(0, i)) Then

-                    Src.Offset(0, PRICE_COUNT + i) = 4

-                    For j = 0 To PRICE_COUNT - 1

-                        Set Dst = Src.Offset(0, j)

-                        If Src.Offset(0, i).Address <> Dst.Address Then

-                            If Application.WorksheetFunction.IsNumber(Dst) Then

-                                If Tst.Offset(0, i) = Tst.Offset(0, j) Then

-                                    If Src.Offset(0, i) > Dst Then

-                                        Src.Offset(0, PRICE_COUNT + i) = Src.Offset(0, PRICE_COUNT + i) - 1

-                                    End If

-                                Else

-                                    If Tst.Offset(0, i) < Tst.Offset(0, j) Then

-                                        Src.Offset(0, PRICE_COUNT + i) = Src.Offset(0, PRICE_COUNT + i) - 1

-                                    End If

-                                End If

-                            Else

-                               Src.Offset(0, PRICE_COUNT + i) = Src.Offset(0, PRICE_COUNT + i) - 1

-                            End If

-                        End If

-                    Next j

-                End If

-            Next i

-

-' Коректировка приоритетов

-            For i = 0 To PRICE_COUNT - 1

-                Set Src = .Range(PROFIT_TABLE).Offset(Scan.Row - 1, PRICE_COUNT + i)

-                If Src <> "-" Then

-                    For j = PRICE_COUNT - 1 To 0 Step -1

-                        Set Dst = .Range(PROFIT_TABLE).Offset(Scan.Row - 1, PRICE_COUNT + j)

-                        If Dst <> "-" Then

-                            If Src.Address <> Dst.Address Then

-                                If Src = Dst Then

-                                    If Tst.Offset(0, i) = Tst.Offset(0, j) Then

-                                        If i < j Then

-                                            Src = Src - 1

-                                        Else

-                                            Dst = Dst - 1

-                                        End If

-                                    Else

-                                        If Tst.Offset(0, i) < Tst.Offset(0, j) Then

-                                            Src = Src - 1

-                                        Else

-                                            Dst = Dst - 1

-                                        End If

-                                    End If

-                                End If

-                            End If

-                        End If

-                    Next j

-                End If

-            Next i

-

-

-            Set Scan = Scan.Offset(1, 0)

-        Wend

-        With Application

-            .Calculate

-            .Calculation = xlCalculationAutomatic

-        End With

-    End With

-End Sub

-

-Sub RestoreRouting(BadIgnore As Boolean, Disp As Range)

-Attribute RestoreRouting.VB_ProcData.VB_Invoke_Func = " \n14"

-    Dim Src As Range

-    Dim Dst As Range

-    Dim Scan As Range

-    Dim i As Integer

-    

-    With ThisWorkbook.Worksheets("CompactPrices")

-        Set Scan = .Range(SCAN_ROW)

-        Set Src = .Range(PROFIT_TABLE)

-        Set Dst = .Range(CORRECTION_TABLE)

-        

-        While Scan <> ""

-            Disp = Disp - 1

-            For i = 0 To PRICE_COUNT - 1

-                Dst.Offset(Scan.Row - 1, i) = 1

-            Next i

-            .Calculate

-lChkAgain:

-            For i = 0 To PRICE_COUNT - 1

-                If Application.WorksheetFunction.IsNumber(Src.Offset(Scan.Row - 1, i)) Then

-                    If BadIgnore Then

-                        If Src.Offset(Scan.Row - 1, i) < 0 Then

-                            Dst.Offset(Scan.Row - 1, i) = ""

-                            Application.Calculate

-                        End If

-                    End If

-                Else

-                    Dst.Offset(Scan.Row - 1, i) = ""

-                End If

-            Next i

-                        

-            If BadIgnore Then

-                .Calculate

-                

-                For i = 0 To PRICE_COUNT - 1

-                    If Src.Offset(Scan.Row - 1, i) < 0 Then

-                        GoTo lChkAgain

-                    End If

-                Next i

-            End If

-                        

-            Set Scan = Scan.Offset(1, 0)

-        Wend

-        

-    End With

-End Sub

-

-Function GetLinesCount(r As Range) As Integer

-Attribute GetLinesCount.VB_ProcData.VB_Invoke_Func = " \n14"

-

-    Dim LinesCount As Integer

-    Dim rr As Range

-

-    Set rr = r

- 

-    LinesCount = 0

-    

-    While rr <> ""

-        LinesCount = LinesCount + 1

-        Set rr = rr.Offset(1, 0)

-    Wend

-    

-    GetLinesCount = LinesCount

-End Function

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Option Explicit

-

-Const SCAN_ROW As String = "C3"

-Const PRICE_COUNT As Integer = 4

-Const PROFIT_TABLE As String = "AA1"

-Const CORRECTION_TABLE As String = "M1"

-

-

-Sub RecalcRouting()

-Attribute RecalcRouting.VB_ProcData.VB_Invoke_Func = " \n14"

-    Dim Src As Range

-    Dim Dst As Range

-    Dim Tst As Range

-    Dim Scan As Range

-    Dim Disp As Range

-    Dim i As Integer

-    Dim j As Integer

-    Dim IgnBad As Boolean

-    

-    Set Scan = ThisWorkbook.Worksheets("CompactPrices").Range(SCAN_ROW)

-    

-   Application.Calculation = xlCalculationManual

-   

-    With ThisWorkbook.Worksheets("Function")

-        Set Disp = .Range("Display")

-        

-        Disp = GetLinesCount(Scan)

-        IgnBad = .Range("NoBad")

-        

-        If .Range("RestRout") = True Then

-            Disp = Disp * 2

-            RestoreRouting IgnBad, Disp

-        End If

-    End With

-    

-    With ThisWorkbook.Worksheets("CompactPrices")

-        Set Scan = .Range(SCAN_ROW)

-        

-        While Scan <> ""

-            

-            Disp = Disp - 1

-            

-            Set Src = .Range(PROFIT_TABLE).Offset(Scan.Row - 1, 0)

-            Set Tst = .Range(CORRECTION_TABLE).Offset(Scan.Row - 1, 0)

-            

-' Расчет приоритетов по цене

-            For i = 0 To PRICE_COUNT - 1

-                Src.Offset(0, PRICE_COUNT + i) = "-"

-                If Application.WorksheetFunction.IsNumber(Src.Offset(0, i)) Then

-                    Src.Offset(0, PRICE_COUNT + i) = 4

-                    For j = 0 To PRICE_COUNT - 1

-                        Set Dst = Src.Offset(0, j)

-                        If Src.Offset(0, i).Address <> Dst.Address Then

-                            If Application.WorksheetFunction.IsNumber(Dst) Then

-                                If Tst.Offset(0, i) = Tst.Offset(0, j) Then

-                                    If Src.Offset(0, i) > Dst Then

-                                        Src.Offset(0, PRICE_COUNT + i) = Src.Offset(0, PRICE_COUNT + i) - 1

-                                    End If

-                                Else

-                                    If Tst.Offset(0, i) < Tst.Offset(0, j) Then

-                                        Src.Offset(0, PRICE_COUNT + i) = Src.Offset(0, PRICE_COUNT + i) - 1

-                                    End If

-                                End If

-                            Else

-                               Src.Offset(0, PRICE_COUNT + i) = Src.Offset(0, PRICE_COUNT + i) - 1

-                            End If

-                        End If

-                    Next j

-                End If

-            Next i

-

-' Коректировка приоритетов

-            For i = 0 To PRICE_COUNT - 1

-                Set Src = .Range(PROFIT_TABLE).Offset(Scan.Row - 1, PRICE_COUNT + i)

-                If Src <> "-" Then

-                    For j = PRICE_COUNT - 1 To 0 Step -1

-                        Set Dst = .Range(PROFIT_TABLE).Offset(Scan.Row - 1, PRICE_COUNT + j)

-                        If Dst <> "-" Then

-                            If Src.Address <> Dst.Address Then

-                                If Src = Dst Then

-                                    If Tst.Offset(0, i) = Tst.Offset(0, j) Then

-                                        If i < j Then

-                                            Src = Src - 1

-                                        Else

-                                            Dst = Dst - 1

-                                        End If

-                                    Else

-                                        If Tst.Offset(0, i) < Tst.Offset(0, j) Then

-                                            Src = Src - 1

-                                        Else

-                                            Dst = Dst - 1

-                                        End If

-                                    End If

-                                End If

-                            End If

-                        End If

-                    Next j

-                End If

-            Next i

-

-

-            Set Scan = Scan.Offset(1, 0)

-        Wend

-        With Application

-            .Calculate

-            .Calculation = xlCalculationAutomatic

-        End With

-    End With

-End Sub

-

-Sub RestoreRouting(BadIgnore As Boolean, Disp As Range)

-Attribute RestoreRouting.VB_ProcData.VB_Invoke_Func = " \n14"

-    Dim Src As Range

-    Dim Dst As Range

-    Dim Scan As Range

-    Dim i As Integer

-    

-    With ThisWorkbook.Worksheets("CompactPrices")

-        Set Scan = .Range(SCAN_ROW)

-        Set Src = .Range(PROFIT_TABLE)

-        Set Dst = .Range(CORRECTION_TABLE)

-        

-        While Scan <> ""

-            Disp = Disp - 1

-            For i = 0 To PRICE_COUNT - 1

-                Dst.Offset(Scan.Row - 1, i) = 1

-            Next i

-            .Calculate

-lChkAgain:

-            For i = 0 To PRICE_COUNT - 1

-                If Application.WorksheetFunction.IsNumber(Src.Offset(Scan.Row - 1, i)) Then

-                    If BadIgnore Then

-                        If Src.Offset(Scan.Row - 1, i) < 0 Then

-                            Dst.Offset(Scan.Row - 1, i) = ""

-                            Application.Calculate

-                        End If

-                    End If

-                Else

-                    Dst.Offset(Scan.Row - 1, i) = ""

-                End If

-            Next i

-                        

-            If BadIgnore Then

-                .Calculate

-                

-                For i = 0 To PRICE_COUNT - 1

-                    If Src.Offset(Scan.Row - 1, i) < 0 Then

-                        GoTo lChkAgain

-                    End If

-                Next i

-            End If

-                        

-            Set Scan = Scan.Offset(1, 0)

-        Wend

-        

-    End With

-End Sub

-

-Function GetLinesCount(r As Range) As Integer

-Attribute GetLinesCount.VB_ProcData.VB_Invoke_Func = " \n14"

-

-    Dim LinesCount As Integer

-    Dim rr As Range

-

-    Set rr = r

- 

-    LinesCount = 0

-    

-    While rr <> ""

-        LinesCount = LinesCount + 1

-        Set rr = rr.Offset(1, 0)

-    Wend

-    

-    GetLinesCount = LinesCount

-End Function

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-mForecastPrice
->>>>>>
-Attribute VB_Name = "mForecastPrice"

-Option Explicit

-

-

-Sub Step_4a_SetParentZonePrices()

-    Dim i As Integer

-    Dim k As Integer

-    Dim DstRange As Range

-    Dim ListsRange As Range

-    

-    With ThisWorkbook

-'        .Application.ScreenUpdating = False

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        

-        Dim s As String

-        i = 0

-        For k = 1 To ListsRange.Count

-            If ListsRange(k, Ofs_InPriceList) <> 1 Then

-                GoTo End_of_For_1

-            End If

-            

-            If ListsRange(k, Ofs_ChkParent) = 1 Then

-                Set DstRange = .Worksheets(WKS_PRICE_NAME).Range(WKS_A3)

-                RestoreParentZonePrice DstRange, idx_PriceIN + i

-            End If

-            

-            i = i + 1

-End_of_For_1:

-        Next k

-        .Application.ScreenUpdating = True

-    End With

-End Sub

-

-Sub Step_4b_SetChildZonePrices()

-    Dim i As Integer

-    Dim k As Integer

-    Dim DstRange As Range

-    Dim ListsRange As Range

-    

-    With ThisWorkbook

-        .Application.ScreenUpdating = False

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        

-        Dim s As String

-        i = 0

-        For k = 1 To ListsRange.Count

-            If ListsRange(k, Ofs_InPriceList) <> 1 Then

-                GoTo End_of_For_1

-            End If

-            

-            If ListsRange(k, Ofs_ChkChild) = 1 Then

-                Set DstRange = .Worksheets(WKS_PRICE_NAME).Range(WKS_A3)

-                RestoreChildZonePrice DstRange, idx_PriceIN + i

-            End If

-            

-            i = i + 1

-End_of_For_1:

-        Next k

-        .Application.ScreenUpdating = True

-    End With

-End Sub

-

-Sub Step_4c_SetAliasZonePrices()

-    Dim i As Integer

-    Dim k As Integer

-    Dim DstRange As Range

-    Dim ListsRange As Range

-    

-    With ThisWorkbook

-        .Application.ScreenUpdating = False

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        

-        Dim s As String

-        i = 0

-        For k = 1 To ListsRange.Count

-            If ListsRange(k, Ofs_InPriceList) <> 1 Then

-                GoTo End_of_For_1

-            End If

-            

-            If ListsRange(k, Ofs_ChkAlias) = 1 Then

-                Set DstRange = .Worksheets(WKS_PRICE_NAME).Range(WKS_A3)

-                RestoreAliasZonePrice DstRange, idx_PriceIN + i

-            End If

-            

-            i = i + 1

-End_of_For_1:

-        Next k

-        .Application.ScreenUpdating = True

-    End With

-

-End Sub

-

-Sub RestoreAliasZonePrice(r As Range, PriceIndex As Integer)

-    Dim Src As Range

-    Dim Dst As Range

-    Dim IdxAliasPrice As Integer

-    Dim AreaCount As Integer

-    

-    Set Dst = r

-    

-    AreaCount = GetLinesCount(Dst)

-    

-    Set Dst = r

-    While Dst <> ""

-        If Dst.Offset(0, PriceIndex) = "-" Then

-            IdxAliasPrice = 1

-            Do

-                IdxAliasPrice = GetAliasDescrIdx(Dst.Offset(0, idx_eDescr), AreaCount, IdxAliasPrice)

-                If IdxAliasPrice = -1 Then

-                    Exit Do

-                End If

-                Set Src = r.Offset(IdxAliasPrice - 3, 0)

-                If Application.WorksheetFunction.IsNumber(Src.Offset(0, PriceIndex)) Then

-                    Exit Do

-                Else

-                    IdxAliasPrice = IdxAliasPrice + 1

-                End If

-            Loop

-            

-            If IdxAliasPrice > -1 Then

-                Set Src = r.Offset(IdxAliasPrice - 3, PriceIndex)

-                If Application.WorksheetFunction.IsNumber(Src) Then

-                    Dst.Offset(0, PriceIndex) = Src

-                    With Dst.Offset(0, PriceIndex)

-                        .Font.Bold = True

-                        .Font.Underline = xlUnderlineStyleSingle

-                        .Font.Italic = False

-                        .Font.ColorIndex = 10 ' green

-                    End With

-                End If

-            End If

-        End If

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-End Sub

-

-Sub RestoreChildZonePrice(r As Range, PriceIndex As Integer)

-    Dim Dst As Range

-    Dim IdxParentPrice As Integer

-    Dim AreaCount As Integer

-    

-    Set Dst = r

-    

-    AreaCount = GetLinesCount(Dst)

-    

-    Set Dst = r

-    While Dst <> ""

-        If Dst.Offset(0, PriceIndex) = "-" Then

-            IdxParentPrice = FindGlobalAreaIdx(Dst, AreaCount)

-            If IdxParentPrice > -1 Then

-                Dst.Offset(0, PriceIndex) = r.Offset(IdxParentPrice - 3, PriceIndex)

-                With Dst.Offset(0, PriceIndex)

-                    .Font.Bold = False

-                    .Font.Italic = True

-                    .Font.ColorIndex = 29 ' magenta

-                End With

-            End If

-        End If

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-End Sub

-

-Sub RestoreParentZonePrice(r As Range, PriceIndex As Integer)

-    Dim Src As Range

-    Dim Dst As Range

-    Dim IdxMaxPrice As Integer

-    

-    Set Dst = r

-    

-    While Dst <> ""

-        If Dst.Offset(0, PriceIndex) = "-" Then

-            Set Src = Dst.Offset(1, 0)

-            IdxMaxPrice = GetZoneMaxPrice(Dst, Src, PriceIndex)

-            If IdxMaxPrice >= 0 Then

-                Dst.Offset(0, PriceIndex) = Src.Offset(IdxMaxPrice, PriceIndex)

-                With Dst.Offset(0, PriceIndex)

-                    .Font.Bold = True

-                    .Font.Italic = True

-                    .Font.ColorIndex = 3 ' Red

-                End With

-            End If

-        End If

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-End Sub

-

-Function GetZoneMaxPrice(Dst As Range, Src As Range, price_idx As Integer) As Integer

-    Dim s As String

-    Dim MaxPrice As Double

-    Dim MaxPriceIdx As Integer

-    

-    GetZoneMaxPrice = -1

-    MaxPrice = -1

-    MaxPriceIdx = 0

-    

-    While InStr(1, Src.Offset(MaxPriceIdx, 0), Dst) > 0

-        

-        If Application.WorksheetFunction.IsNumber(Src.Offset(MaxPriceIdx, price_idx)) Then

-            If MaxPrice < Src.Offset(MaxPriceIdx, price_idx) Then

-                MaxPrice = Src.Offset(MaxPriceIdx, price_idx)

-                GetZoneMaxPrice = MaxPriceIdx

-            End If

-        End If

-        MaxPriceIdx = MaxPriceIdx + 1

-    Wend

-End Function

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet19
->>>>>>
-Attribute VB_Name = "Sheet19"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-mOpPrices
->>>>>>
-Attribute VB_Name = "mOpPrices"

-Option Explicit

-

-Public Const idx_PriceIN As Integer = 4

-

-Sub Step_3_Recalc_1st_Prices()

-    AnalyzeOpPricesData WKS_PRICE_NAME, "0.0000"

-End Sub

-

-

-

-Sub AnalyzeOpPricesData(wks_name As String, DATA_fmt As String)

-

-' Формируем список зон на рабочем листе

-' Удаляем предыдущий расчет

-    ClearWorkArea (wks_name)

-    

-    ThisWorkbook.Worksheets(wks_name).Activate

-    ThisWorkbook.Worksheets(wks_name).Cells.Select

-    With Selection

-        .ClearContents

-        .Interior.ColorIndex = xlNone

-        .Font.Bold = False

-        .Font.ColorIndex = 0

-        .HorizontalAlignment = xlGeneral

-        .VerticalAlignment = xlBottom

-        .WrapText = False

-        .Orientation = 0

-        .AddIndent = False

-        .ShrinkToFit = False

-        .MergeCells = False

-    End With

-    ThisWorkbook.Worksheets(wks_name).Range("A1").Select

-

-' Подсчитываем количество входящих в прайс-листов

-    Dim ListsRange As Range

-    Dim i As Integer

-    Dim j As Integer

-    Dim k As Integer

-    Dim ListsRange_PriceCount As Integer

-    

-    Set ListsRange = ThisWorkbook.Worksheets(WKS_HOME_NAME).Range("OpList")

-    ListsRange_PriceCount = 0

-

-    For i = 1 To ListsRange.Count

-        If ListsRange(i, Ofs_InPriceList) = 1 Then

-            ListsRange_PriceCount = ListsRange_PriceCount + 1

-        End If

-    Next i

-

-

-

-' Форматируем заголовок рабочего листа

-

-    Dim SrcRange As Range

-    Dim DstRange As Range

-

-    With ThisWorkbook

-        .Application.ScreenUpdating = False

-        

-        Set DstRange = .Worksheets(wks_name).Range(WKS_A3)

-

-

-        With DstRange

-            .Offset(-2, idx_sCode) = "Common"

-            .Offset(-1, idx_sCode) = "sCode"

-            .Offset(-1, idx_Code) = "Code"

-            .Offset(-1, idx_eDescr) = "Descr_E"

-            .Offset(-1, idx_rDescr) = "Descr_R"

-            .Offset(-2, idx_PriceIN) = "Price (In)"

-            k = 1

-            For i = 1 To ListsRange.Count

-                If ListsRange(i, Ofs_InPriceList) = 1 Then

-                    .Offset(-1, k + idx_PriceIN - 1) = ListsRange(i, 1)

-                    k = k + 1

-                End If

-            Next i

-            .Offset(-2, idx_PriceIN + ListsRange_PriceCount) = "Stat of Price (IN)"

-            .Offset(-1, idx_PriceIN + ListsRange_PriceCount) = "Count"

-            .Offset(-1, idx_PriceIN + ListsRange_PriceCount + 1) = "Min"

-            .Offset(-1, idx_PriceIN + ListsRange_PriceCount + 1) = "Min"

-            .Offset(-1, idx_PriceIN + ListsRange_PriceCount + 2) = "Max"

-            .Offset(-1, idx_PriceIN + ListsRange_PriceCount + 3) = "Avg"

-            .Offset(-1, idx_PriceIN + ListsRange_PriceCount + 4) = "Down"

-            .Offset(-1, idx_PriceIN + ListsRange_PriceCount + 5) = "Up"

-            .Offset(-2, idx_PriceIN + ListsRange_PriceCount + 6) = "Operators"

-            .Offset(-1, idx_PriceIN + ListsRange_PriceCount + 6) = "Price"

-            .Offset(-2, idx_PriceIN + ListsRange_PriceCount + 7) = "Profit[x100%]"

-            .Offset(-1, idx_PriceIN + ListsRange_PriceCount + 7) = "Avg"

-            .Offset(-1, idx_PriceIN + ListsRange_PriceCount + 8) = "Min"

-            .Offset(-1, idx_PriceIN + ListsRange_PriceCount + 9) = "Max"

-            .Offset(-2, idx_PriceIN + ListsRange_PriceCount + 10) = "Op Profit[x100%] (Routing type 1)"

-            j = idx_PriceIN + ListsRange_PriceCount + 10

-            k = 1

-            For i = 1 To ListsRange.Count

-                If ListsRange(i, Ofs_InPriceList) = 1 Then

-                    .Offset(-1, k + j - 1) = ListsRange(i, 1)

-                    k = k + 1

-                End If

-            Next i

-            With .Offset(-2, 0).EntireRow

-                .HorizontalAlignment = xlLeft

-                .Font.Bold = True

-            End With

-            With .Offset(-1, 0).EntireRow

-                .HorizontalAlignment = xlCenter

-                .Font.Bold = True

-            End With

-            

-        End With

-

-' Копируем созданный список на рабочий лист

-        Set SrcRange = .Worksheets(WKS_FIX_AREAS_NAME).Range(WKS_A3)

-        

-        CopyAreasList DstRange, SrcRange

-        

-        Set SrcRange = .Worksheets(WKS_AREAS_NAME).Range(WKS_A3)

-        

-        Set DstRange = .Worksheets(wks_name).Range(WKS_A3)

-    End With

-

-' Подсчитываем общее количество зон

-

-    Dim AreaCount As Integer

-    AreaCount = GetLinesCount(DstRange)

-

-

-' Форматируем полученный результат

-        

-    For i = 1 To 4

-        Set DstRange = ThisWorkbook.Worksheets(wks_name) _

-                    .Range(Cells(2, i), Cells(2 + AreaCount, i))

-        With DstRange

-            .EntireColumn.AutoFit

-            If i Mod 2 = 1 Then

-                .Interior.ColorIndex = 36 ' LightYellow

-            Else

-                .Interior.ColorIndex = xlNone  'White

-            End If

-        End With

-    Next i

-

-' Перебираем цены/данные всех операторов и формируем общий список цен по зонам

-' Копируем цены операторов для зон

-

-    With ThisWorkbook

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        

-        Dim s As String

-        i = 1

-        For k = 1 To ListsRange.Count

-            If ListsRange(k, Ofs_InPriceList) <> 1 Then

-                GoTo End_of_For_1

-            End If

-            Set DstRange = .Worksheets(wks_name).Range(WKS_A3)

-            s = ListsRange.Cells(k, 1).Value

-            If wks_name = WKS_TRAFFIC_NAME Then

-                s = s & ".Data"

-            End If

-            

-            If SheetExist(s) Then

-                Set SrcRange = .Worksheets(s).Range(WKS_A3)

-    

-                AddOpPriceData DstRange, SrcRange, i - 1

-                

-            End If

-            

-' Форматируем полученный результат

-            With .Worksheets(wks_name)

-                Set DstRange = .Range(.Cells(2, idx_Price + i), .Cells(2 + AreaCount, idx_Price + i))

-            End With

-            With DstRange

-                .NumberFormat = DATA_fmt

-                .Font.Bold = True

-                .HorizontalAlignment = xlCenter

-                .VerticalAlignment = xlBottom

-                .WrapText = False

-                .Orientation = 0

-                .AddIndent = False

-                .ShrinkToFit = False

-                .MergeCells = False

-                If i Mod 2 = 1 Then

-                    .Interior.ColorIndex = 36 ' LightYellow

-                Else

-                    .Interior.ColorIndex = xlNone  'White

-                End If

-            End With

-            i = i + 1

-End_of_For_1:

-        Next k

-        

-' Маркируем пустые направления у каждого оператора

-

-        With Worksheets(wks_name)

-            Set DstRange = .Range(.Cells(2, idx_Price + 1), .Cells(2 + AreaCount, idx_Price + ListsRange_PriceCount))

-        End With

-        

-'        DstRange.Select

-        

-        For Each SrcRange In DstRange

-            If SrcRange = "" Then

-                SrcRange = "-"

-            End If

-        Next SrcRange

-        

-        Set SrcRange = .Worksheets(wks_name).Range(WKS_A3)

-    End With

-    

-' Рассчитываем статистику по ценам

-    Set DstRange = ThisWorkbook.Worksheets(wks_name) _

-                .Range(WKS_A3).Offset(0, idx_PriceIN + ListsRange_PriceCount)

-                

-    DstRange.Select

-    

-    Dim Stat1stCol As Integer

-    Dim StatMinCol As Integer

-    Dim StatMaxCol As Integer

-    Dim StatAvgCol As Integer

-    Dim StatDnCol As Integer

-    Dim StatUpCol As Integer

-    

-    Dim offsetMinCol As Integer

-    Dim offsetMaxCol As Integer

-    Dim offsetAvgCol As Integer

-    Dim offsetUpCol As Integer

-    Dim offsetDnCol As Integer

-    Dim offsetPriceCol As Integer

-    Dim offsetAvgPtCol As Integer

-    Dim offsetMinPtCol As Integer

-    Dim offsetMaxPtCol As Integer

-    

-    

-    Stat1stCol = idx_PriceIN + ListsRange_PriceCount + 1

-    

-    offsetMinCol = 1

-    offsetMaxCol = 2

-    offsetAvgCol = 3

-    offsetUpCol = 4

-    offsetDnCol = 5

-    offsetPriceCol = 6

-    offsetAvgPtCol = 7

-    offsetMinPtCol = 8

-    offsetMaxPtCol = 9

-    

-    StatMinCol = Stat1stCol + offsetMinCol

-    StatMaxCol = Stat1stCol + offsetMaxCol

-    StatAvgCol = Stat1stCol + offsetAvgCol

-    StatUpCol = Stat1stCol + offsetUpCol

-    StatDnCol = Stat1stCol + offsetDnCol

-    

-    

-    For i = 0 To AreaCount - 1

-        s = RC2ADDR(i + 3, idx_PriceIN + 1) & ":" & RC2ADDR(i + 3, idx_PriceIN + ListsRange_PriceCount)

-        DstRange.Offset(i, 0).Formula = "=count(" & s & ")"

-        

-        Dim AnchorCell As String

-        AnchorCell = RC2ADDR(i + 3, Stat1stCol)

-        

-        DstRange.Offset(i, offsetMinCol).Formula = "=if(" & AnchorCell & ">0, min(" & s & "), ""-"")"

-        DstRange.Offset(i, offsetMaxCol).Formula = "=if(" & AnchorCell & ">0, max(" & s & "), ""-"")"

-        DstRange.Offset(i, offsetAvgCol).Formula = "=if(" & AnchorCell & ">0, average(" & s & "), ""-"")"

-        s = "=if(" & AnchorCell & ">0,(" & RC2ADDR(i + 3, StatAvgCol) & "-" & RC2ADDR(i + 3, StatMaxCol) & ")/" & RC2ADDR(i + 3, StatAvgCol) & ", ""-"")"

-        With DstRange.Offset(i, offsetDnCol)

-            .Formula = s

-            .NumberFormat = "0.00%_);[Red](0.00)%"

-        End With

-        s = "=if(" & AnchorCell & ">0, (" & RC2ADDR(i + 3, StatAvgCol) & "-" & RC2ADDR(i + 3, StatMinCol) & ")/" & RC2ADDR(i + 3, StatAvgCol) & ", ""-"")"

-        With DstRange.Offset(i, offsetUpCol)

-            .Formula = s

-            .NumberFormat = "0.00%"

-        End With

-

-' Расчет отпускной цены по формуле.

-        s = "=if(" & AnchorCell & ">0, if(" & RC2ADDR(i + 3, StatAvgCol) & "<=Trigger, " & RC2ADDR(i + 3, StatAvgCol) & "+FixedV," & RC2ADDR(i + 3, StatAvgCol) & "* FIxedP), ""-"")"

-        With DstRange.Offset(i, offsetPriceCol)

-            .Formula = s

-            .NumberFormat = "0.000"

-        End With

-

-' Расчет Прибыли и Убытков.

-        s = "=if(" & AnchorCell & ">0, (" & RC2ADDR(i + 3, Stat1stCol + offsetPriceCol) & "-" & RC2ADDR(i + 3, StatAvgCol) & ")/" & RC2ADDR(i + 3, StatAvgCol) & ", ""-"")"

-        With DstRange.Offset(i, offsetAvgPtCol)

-            .Formula = s

-            .HorizontalAlignment = xlCenter

-            .NumberFormat = "0.00%_);[Red](0.00)%"

-        End With

-

-        s = "=if(" & AnchorCell & ">0, (" & RC2ADDR(i + 3, Stat1stCol + offsetPriceCol) & "-" & RC2ADDR(i + 3, StatMaxCol) & ")/" & RC2ADDR(i + 3, StatMaxCol) & ", ""-"")"

-        With DstRange.Offset(i, offsetMinPtCol)

-            .Formula = s

-            .HorizontalAlignment = xlCenter

-            .NumberFormat = "0.00%_);[Red](0.00)%"

-        End With

-

-        s = "=if(" & AnchorCell & ">0, (" & RC2ADDR(i + 3, Stat1stCol + offsetPriceCol) & "-" & RC2ADDR(i + 3, StatMinCol) & ")/" & RC2ADDR(i + 3, StatMinCol) & ", ""-"")"

-        With DstRange.Offset(i, offsetMaxPtCol)

-            .Formula = s

-            .HorizontalAlignment = xlCenter

-            .NumberFormat = "0.00%_);[Red](0.00%)"

-        End With

-

-' Расчет Прибыли и Убытков по операторам (Routing type 1)

-        

-        j = 1

-        For k = 1 To ListsRange.Count

-            If ListsRange(k, Ofs_InPriceList) = 1 Then

-                AnchorCell = RC2ADDR(i + 3, idx_PriceIN + j)

-                s = "=if(isnumber(" & AnchorCell & "), (" & RC2ADDR(i + 3, Stat1stCol + offsetPriceCol) & "-" & AnchorCell & ")/" & AnchorCell & ", ""-"")"

-                With DstRange.Offset(i, offsetMaxPtCol + j)

-                    .Formula = s

-                    .NumberFormat = "0.00%_);[Red](0.00)%"

-                End With

-                j = j + 1

-            End If

-        Next k

-    Next i

-

-

-' Форматируем полученный результат

-' Статистика

-    For i = 0 To 5

-        With ThisWorkbook.Worksheets(wks_name)

-            Set DstRange = .Range(.Cells(2, Stat1stCol + i), .Cells(2 + AreaCount, Stat1stCol + i))

-        End With

-        With DstRange

-            If i > 0 And i <= 3 Then

-                .NumberFormat = DATA_fmt

-            End If

-            .HorizontalAlignment = xlCenter

-            .VerticalAlignment = xlBottom

-            .WrapText = False

-            .Orientation = 0

-            .AddIndent = False

-            .ShrinkToFit = False

-            .MergeCells = False

-            If i Mod 2 = 0 Then

-                .Interior.ColorIndex = 35 ' LightLightGreen

-            Else

-                .Interior.ColorIndex = 34  ' LightLightBlue

-            End If

-        End With

-    Next i

-

-' Формат колонки "Operators price"

-

-    With ThisWorkbook.Worksheets(wks_name)

-        Set DstRange = .Range(.Cells(1, Stat1stCol + offsetPriceCol), .Cells(2 + AreaCount, Stat1stCol + offsetPriceCol))

-        With DstRange

-            .Interior.ColorIndex = 36 ' LightYellow

-            .Font.ColorIndex = 10

-            .Font.Bold = True

-            .NumberFormat = "0.0000"

-            .HorizontalAlignment = xlCenter

-            .VerticalAlignment = xlBottom

-        End With

-    End With

-

-' Формат Прибыли и Убытков по операторам (Routing type 1)

-    For j = 1 To ListsRange_PriceCount

-        With ThisWorkbook.Worksheets(wks_name)

-            Set DstRange = .Range(.Cells(2, Stat1stCol + offsetMaxPtCol + j), .Cells(2 + AreaCount, Stat1stCol + offsetMaxPtCol + j))

-        End With

-        With DstRange

-            .HorizontalAlignment = xlCenter

-            .VerticalAlignment = xlBottom

-            .WrapText = False

-            .Orientation = 0

-            .AddIndent = False

-            .ShrinkToFit = False

-            .MergeCells = False

-            If j Mod 2 = 0 Then

-                .Interior.ColorIndex = 34  ' LightLightBlue

-            Else

-                .Interior.ColorIndex = 35 ' LightLightGreen

-            End If

-        End With

-    Next j

-    Application.ScreenUpdating = True

-End Sub

-

-Sub CopyAreasList(Dst As Range, Src As Range)

-    While Src <> ""

-        Dst.Offset(0, idx_sCode).Value = Src.Offset(0, idx_sCode).Value

-        Dst.Offset(0, idx_Code).Value = Src.Offset(0, idx_Code).Value

-        Dst.Offset(0, idx_eDescr).Value = Src.Offset(0, idx_eDescr).Value

-        Dst.Offset(0, idx_rDescr).Value = Src.Offset(0, idx_rDescr).Value

-        Set Src = Src.Offset(1, 0)

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-End Sub

-

-

-Sub AddOpPriceData(Dst As Range, Src As Range, index As Integer)

-    While Src <> "" And Dst <> ""

-        If Dst = Src Then

-            Dst.Offset(0, idx_Price + index) = Src.Offset(0, idx_Price)

-            Set Dst = Dst.Offset(1, 0)

-        End If

-        If Dst > Src Then

-            Set Src = Src.Offset(1, 0)

-        End If

-        If Dst < Src Then

-            Set Dst = Dst.Offset(1, 0)

-        End If

-    Wend

-End Sub

-

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet27
->>>>>>
-Attribute VB_Name = "Sheet27"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet23
->>>>>>
-Attribute VB_Name = "Sheet23"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-mGlobalList
->>>>>>
-Attribute VB_Name = "mGlobalList"

-Option Explicit

-

-

-

-

-Sub Step_1_BuildWorkPriceLists()

-

-    Dim SrcRange As Range

-    Dim DstRange As Range

-    Dim ListsRange As Range

-    

-    

-    With ThisWorkbook

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        

-        Dim s As String

-        Dim i As Integer

-    

-' Перебираем названия всех операторов и формируем общий список зон

-        With .Application

-            .Calculation = xlCalculationManual

-            .ScreenUpdating = False

-        End With

-

-        For i = 1 To ListsRange.Count

-            s = ListsRange.Cells(i, 1).Value

-            

-            CreateComSheet (s)

-            

-            Set DstRange = .Worksheets(s).Range(WKS_A3)

-            Set SrcRange = .Worksheets(s & ".Tarif").Range(WKS_A3)

-            

-            MarkDublicates SrcRange

-            

-            Set SrcRange = .Worksheets(s & ".Tarif").Range(WKS_A3)

-            AddOpArea DstRange, SrcRange, ADD_CODE_PRICE

-            

-            Set DstRange = .Worksheets(s).Range(WKS_A3)

-            

-            If SheetExist(s & ".Data") Then

-                Set SrcRange = .Worksheets(s & ".Data").Range(WKS_A3)

-                AddOpArea DstRange, SrcRange, ADD_CODE_TRAFFIC

-            End If

-            

-' Присваиваем зонам статус:

-' 00 - не известная, не используется

-' 01 - не известная, используется

-' 10 - известная, не используется

-' 11 - известная, используется

-            

-            Set DstRange = .Worksheets(s).Range(WKS_A3)

-            While DstRange <> ""

-                If DstRange.Offset(0, idx_Price) = 0 Or DstRange.Offset(0, idx_Price) = "-" Then

-                    If DstRange.Offset(0, idx_Traffic) = 0 Then

-                        DstRange.Offset(0, idx_Status) = 0

-                    Else

-                        DstRange.Offset(0, idx_Status) = 1

-                    End If

-                Else

-                    If DstRange.Offset(0, idx_Traffic) = 0 Then

-                        DstRange.Offset(0, idx_Status) = 10

-                    Else

-                        DstRange.Offset(0, idx_Status) = 11

-                    End If

-                End If

-                Set DstRange = DstRange.Offset(1, 0)

-            Wend

-                

-            With .Worksheets(s)

-                With .Columns("A:H")

-                    .HorizontalAlignment = xlHAlignGeneral

-                    .VerticalAlignment = xlBottom

-                    .WrapText = False

-                    .Orientation = 0

-                    .AddIndent = False

-                    .ShrinkToFit = True

-                    .MergeCells = False

-                End With

-                .Columns("A:A").HorizontalAlignment = xlLeft

-                .Columns("B:B").NumberFormat = "#"

-                With .Rows("2:2")

-                    .Font.Bold = False

-                    .WrapText = False

-                    .HorizontalAlignment = xlCenter

-                End With

-                With .Columns("G:G")

-                    .HorizontalAlignment = xlHAlignCenter

-                    .NumberFormat = "0#"

-                End With

-            End With

-            MarkDublicates (.Worksheets(s).Range(WKS_A3))

-        Next i

-        With .Application

-            .Calculation = xlCalculationAutomatic

-            .ScreenUpdating = True

-            .Calculate

-        End With

-        

-    End With

-

-End Sub

-

-Sub Step_2_CreateGlobalCodeList()

-

-' Перебираем названия всех операторов и формируем общий список зон

-' Удаляем предыдущий расчет

-    ClearWorkArea WKS_AREAS_NAME, "A1"

-    

-' Формируем общий список зон

-

-    

-    BuildAreasList (WKS_AREAS_NAME)

-    

-    BuildAreasStatus (WKS_AREAS_NAME)

-

-    

-End Sub

-

-Sub BuildAreasList(DstName As String)

-

-    Dim SrcRange As Range

-    Dim DstRange As Range

-    Dim ListsRange As Range

-    

-    With ThisWorkbook

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        

-        Dim s As String

-        Dim i As Integer

-    

-        With .Application

-            .Calculation = xlCalculationManual

-            .ScreenUpdating = False

-        End With

-        

-' Формируем строку заголовка

-        With .Worksheets(DstName)

-            .Range("a1") = DstName

-            With .Range("a2")

-                .Offset(0, idx_sCode) = "sCode"

-                .Offset(0, idx_Code) = "Code"

-                .Offset(0, idx_eDescr) = "Descr_E"

-                .Offset(0, idx_rDescr) = "Descr_R"

-            End With

-            With .Rows("2:2")

-                .Font.Bold = False

-                .WrapText = False

-                .HorizontalAlignment = xlCenter

-            End With

-        End With

-        

-' Перебираем названия всех операторов и формируем общий список зон

-        For i = 1 To ListsRange.Count

-            s = ListsRange.Cells(i, 1).Value

-            

-            If SheetExist(s) Then

-                Set DstRange = .Worksheets(WKS_AREAS_NAME).Range(WKS_A3)

-                Set SrcRange = .Worksheets(s).Range(WKS_A3)

-        

-                AddGlobalOpArea DstRange, SrcRange

-            End If

-        Next i

-        Set SrcRange = .Worksheets(DstName).Range(WKS_A3)

-        .Worksheets(DstName).Select

-                

-        MarkDublicates (.Worksheets(DstName).Range(WKS_A3))

-        

-        With .Application

-            .Calculation = xlCalculationAutomatic

-            .ScreenUpdating = True

-            .Calculate

-        End With

-    End With

-End Sub

-

-Sub AddGlobalOpArea(Dst As Range, Src As Range)

-    While Src <> ""

-        If Dst > Src Then

-            Dst.Worksheet.Range(Dst, Dst.Offset(0, 50)).Insert Shift:=xlShiftDown

-            Set Dst = Dst.Offset(-1, 0)

-        End If

-        If Dst = "" Then

-            Dst.Offset(0, idx_sCode) = Src.Offset(0, idx_sCode)

-            Dst.Offset(0, idx_Code) = Src.Offset(0, idx_Code)

-        End If

-        If Dst = Src Then

-            CheckNameOpArea Dst, Src, ADD_CODE_ONLY

-            Set Src = Src.Offset(1, 0)

-        End If

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-    

-    Dst.Worksheet.Columns("A:H").AutoFit

-    

-    Set Dst = Dst.Worksheet.Range(WKS_A3)

-    

-End Sub

-

-Sub CheckNameOpArea(Dst As Range, Src As Range, ByVal add_type As Integer)

-    

-    Dim Exist_SrcEng As Boolean

-    Dim Exist_SrcRus As Boolean

-    Dim Exist_DstEng As Boolean

-    Dim Exist_DstRus As Boolean

-    

-    Dim Unknown_Src As Boolean

-    Dim Unknown_Dst As Boolean

-    

-    With Dst

-        Exist_DstEng = .Offset(0, idx_eDescr) <> "" And .Offset(0, idx_eDescr) <> UNKNOWN_AREA And .Offset(0, idx_eDescr) <> NONAME_AREA

-        Exist_DstRus = .Offset(0, idx_rDescr) <> "" And .Offset(0, idx_rDescr) <> UNKNOWN_AREA And .Offset(0, idx_rDescr) <> NONAME_AREA

-    End With

-    

-    Unknown_Dst = Not (Exist_DstEng Or Exist_DstRus)

-    

-    If add_type = ADD_CODE_TRAFFIC Then

-        If Unknown_Dst Then

-            Dst.Offset(0, idx_eDescr) = UNKNOWN_AREA & Dst.Offset(0, idx_Code)

-            Dst.Offset(0, idx_rDescr) = UNKNOWN_AREA & Dst.Offset(0, idx_Code)

-        End If

-        Exit Sub

-    End If

-    

-    With Src

-        Exist_SrcEng = .Offset(0, idx_eDescr) <> "" And .Offset(0, idx_eDescr) <> UNKNOWN_AREA And .Offset(0, idx_eDescr) <> NONAME_AREA

-        Exist_SrcRus = .Offset(0, idx_rDescr) <> "" And .Offset(0, idx_rDescr) <> UNKNOWN_AREA And .Offset(0, idx_rDescr) <> NONAME_AREA

-    End With

-    

-    Unknown_Src = Not (Exist_SrcEng Or Exist_SrcRus)

-    

-    If Unknown_Src And Unknown_Dst Then

-        Dst.Offset(0, idx_eDescr) = UNKNOWN_AREA

-        Dst.Offset(0, idx_rDescr) = UNKNOWN_AREA

-        Exit Sub

-    End If

-    

-    If Unknown_Src Then

-        If Not Exist_DstRus Then

-            Dst.Offset(0, idx_rDescr) = NONAME_AREA

-        End If

-        If Not Exist_DstEng Then

-            Dst.Offset(0, idx_eDescr) = NONAME_AREA

-        End If

-    Else

-        If Not Exist_DstEng Then

-            If Exist_SrcEng Then

-                Dst.Offset(0, idx_eDescr) = Src.Offset(0, idx_eDescr)

-            Else

-                Dst.Offset(0, idx_eDescr) = NONAME_AREA

-            End If

-        End If

-        If Not Exist_DstRus Then

-            If Exist_SrcRus Then

-                Dst.Offset(0, idx_rDescr) = Src.Offset(0, idx_rDescr)

-            Else

-                Dst.Offset(0, idx_rDescr) = NONAME_AREA

-            End If

-        End If

-    End If

-End Sub

-

-Sub AddOpArea(Dst As Range, Src As Range, Optional add_type = ADD_CODE_ONLY)

-    

-    While Src <> ""

-        If Dst > Src Then

-            Dst.Worksheet.Range(Dst, Dst.Offset(0, 50)).Insert Shift:=xlShiftDown

-            Set Dst = Dst.Offset(-1, 0)

-        End If

-        If Dst = "" Then

-            Dst.Offset(0, idx_sCode) = Src.Offset(0, idx_sCode)

-            Dst.Offset(0, idx_Code) = Src.Offset(0, idx_Code)

-        End If

-        If Dst = Src Then

-            Select Case add_type

-                Case ADD_CODE_PRICE

-                    Dst.Offset(0, idx_Price) = Src.Offset(0, idx_Price)

-                    If Dst.Offset(0, idx_Price) = "" Then

-                        Dst.Offset(0, idx_Price) = "-"

-                    End If

-                Case ADD_CODE_TRAFFIC

-                    Dst.Offset(0, idx_Traffic) = Src.Offset(0, idx_DatTraffic)

-                    Dst.Offset(0, idx_Calls) = Src.Offset(0, idx_DatCalls)

-                    

-            End Select

-            

-            CheckNameOpArea Dst, Src, add_type

-                        

-            Set Src = Src.Offset(1, 0)

-        End If

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-    

-    Select Case add_type

-        Case ADD_CODE_PRICE

-            Dst.Worksheet.Columns("E:E").NumberFormat = "0.0000"

-        Case ADD_CODE_TRAFFIC

-            Dst.Worksheet.Columns("F:F").NumberFormat = "0.00"

-    End Select

-    

-    Dst.Worksheet.Columns("A:H").AutoFit

-    

-    Set Dst = Dst.Worksheet.Range("A1")

-End Sub

-

-Sub BuildAreasStatus(wks_name As String)

-    Dim rSrc As Range

-    Dim rDst As Range

-    Dim ListsRange As Range

-    Dim i As Integer

-    Dim j As Integer

-    Dim s As String

-    Dim WS_Name As String

-    

-    With ThisWorkbook

-        .Application.ScreenUpdating = False

-        

-        

-' Вычисляем размер списка

-

-        Dim AreaCount As Integer

-

-        Set rDst = .Worksheets(wks_name).Range(WKS_A3)

-        

-        AreaCount = GetLinesCount(rDst) + 3

-

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        Set rDst = .Worksheets(wks_name).Range(WKS_A3)

-        j = 3

-        

-        For i = 1 To ListsRange.Count

-            rDst.Offset(-1, i + idx_GLStatus).Formula = ListsRange(i, 1)

-        Next i

-        

-' Вычисляем статусы зон для списка операторов

-        While rDst <> ""

-            For i = 1 To ListsRange.Count

-                WS_Name = ListsRange(i, 1)

-                If SheetExist(WS_Name) Then

-                    s = "INDEX(" & WS_Name & "!G1:$G$" & AreaCount & ", MATCH($A" & j & "," & WS_Name & "!$A$1:$A$" & AreaCount & ",0), 1)"

-                    s = "=if(iserror(" & s & "), ""-""," & s & ")"

-                Else

-                    s = "-"

-                End If

-                rDst.Offset(0, i + idx_GLStatus).Formula = s

-                rDst.Offset(0, i + idx_GLStatus).NumberFormat = "0#"

-            Next i

-            j = j + 1

-            Set rDst = rDst.Offset(1, 0)

-        Wend

-        

-' Форматируем результат

-        For i = 0 To ListsRange.Count

-            With rDst.Offset(-1, i + idx_GLStatus).EntireColumn

-                .HorizontalAlignment = xlCenter

-                .ShrinkToFit = True

-            End With

-        Next i

-

-' Корректируем названия зон

-

-        With .Worksheets(wks_name)

-            Set rDst = .Range(.Cells(3, 1), .Cells(AreaCount, 1))

-        End With

-

-        Set rSrc = .Worksheets(WKS_FIX_AREAS_NAME).Range(WKS_A3)

-        

-        AreaCount = GetLinesCount(rSrc) + 3

-

-        With .Worksheets(WKS_FIX_AREAS_NAME)

-            Set rSrc = .Range(.Cells(2, 1), .Cells(AreaCount, 1))

-        End With

-

-        Dim b As Range

-        Dim c As Range

-        For Each c In rDst

-            Set b = rSrc.Find(c, LookIn:=xlValues, MatchByte:=True)

-            If Not b Is Nothing Then

-                If c.Offset(0, idx_eDescr) <> b.Offset(0, idx_eDescr) Or c.Offset(0, idx_rDescr) <> b.Offset(0, idx_rDescr) Then

-                    c.Offset(0, idx_eDescr) = b.Offset(0, idx_eDescr)

-                    c.Offset(0, idx_rDescr) = b.Offset(0, idx_rDescr)

-                    c.Offset(0, idx_GLStatus) = "Fixed"

-                    With c.EntireRow

-                        .Font.Bold = True

-                        .Font.ColorIndex = xlColorIndexAutomatic

-                    End With

-                Else

-                    c.Offset(0, idx_GLStatus) = "-"

-                End If

-            Else

-                If c.Offset(0, idx_sCode) <> "" Then

-                    Dim FixedList As Range

-                    c.Offset(0, idx_GLStatus) = "New"

-                    With c.EntireRow

-                        .Font.Bold = True

-                        .Font.ColorIndex = 3 ' Red

-                    End With

-                End If

-                

-'                Set Fixed

-            End If

-        Next c

-        

-        Application.ScreenUpdating = True

-        

-    End With

-End Sub

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Sub ClearWorkArea(DstName As String, Optional StartRange As String = WKS_A3)

-    Dim DstRange As Range

-    With ThisWorkbook

-       

-        Set DstRange = .Worksheets(DstName).Range(StartRange)

-        Worksheets(DstName).Select

-        DstRange.Select

-        Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select

-        Range(Selection, Selection.End(xlDown)).Select

-        Selection.Delete Shift:=xlUp

-        Selection.Font.Bold = False

-        Selection.Font.ColorIndex = xlColorIndexAutomatic

-        Set DstRange = .Worksheets(DstName).Range(StartRange)

-        DstRange.Select

-    End With

-End Sub

-

-Function SheetExist(SheetName As String) As Boolean

-    Dim Count, i As Integer

-

-    Count = ThisWorkbook.Sheets.Count

-    SheetExist = False

-    For i = 1 To Count

-        If ThisWorkbook.Sheets(i).Name = SheetName Then

-            SheetExist = True

-            i = Count

-        End If

-    Next i

-End Function

-

-Function GetLinesCount(r As Range) As Integer

-

-    Dim LinesCount As Integer

-    Dim rr As Range

-    

-    Set rr = r

-    

-    LinesCount = 0

-

-    While rr <> ""

-        LinesCount = LinesCount + 1

-        Set rr = rr.Offset(1, 0)

-    Wend

-    

-    GetLinesCount = LinesCount

-End Function

-

-Sub CreateComSheet(wks_name As String)

-    Dim theRange As Range

-    With ThisWorkbook

-        If Not SheetExist(wks_name) Then

-            .Sheets.Add.Name = wks_name

-        End If

-            

-        .Sheets(wks_name).Visible = True

-        .Sheets(wks_name).Select

-        Cells.Select

-        Selection.ClearContents

-        Selection.Interior.ColorIndex = xlNone

-        Selection.Borders(xlLeft).LineStyle = xlNone

-        Selection.Borders(xlRight).LineStyle = xlNone

-        Selection.Borders(xlTop).LineStyle = xlNone

-        Selection.Borders(xlBottom).LineStyle = xlNone

-        Selection.BorderAround LineStyle:=xlNone

-        Selection.Font.ColorIndex = 0

-        Selection.EntireColumn.ColumnWidth = ActiveSheet.StandardWidth

-    

-        With .Worksheets(wks_name)

-            .Range("a1") = wks_name

-            With .Range("a2")

-                .Offset(0, idx_sCode) = "sCode"

-                .Offset(0, idx_Code) = "Code"

-                .Offset(0, idx_eDescr) = "Descr_E"

-                .Offset(0, idx_rDescr) = "Descr_R"

-                .Offset(0, idx_Price) = "Price"

-                .Offset(0, idx_Traffic) = "Traffic"

-                .Offset(0, idx_Calls) = "Calls"

-                .Offset(0, idx_Status) = "Status"

-            End With

-            With .Rows("2:2")

-                .Font.Bold = False

-                .WrapText = False

-                .HorizontalAlignment = xlCenter

-            End With

-            .Range("A1").Select

-        End With

-    End With

-End Sub

-

-' Возвращает index имени зоны синонима из сортированного списка имен зон, начиная со StartIndex

-' Пример для зоны Russia, Moscow глобальной будет являться зона с именем Russia

-' Результаты функции:

-' -1 исследуемая зона уже является глобальной

-' > 0 - глобальной зоны найденной глобальной зоны в списке

-

-Function GetAliasDescrIdx(Dst As Range, AreaCount As Integer, Optional StartIndex As Integer = 1) As Integer

-    Dim s As String

-    Dim idx As Integer

-    

-    s = Dst

-    idx = StartIndex

-    

-    GetAliasDescrIdx = -1

-    

-    With Dst.Worksheet

-        Do

-            idx = FindVIndex(Dst.EntireColumn, AreaCount, s, idx)

-            If idx > 0 Then

-                If idx <> Dst.Row Then

-                    GetAliasDescrIdx = idx

-                    Exit Do

-                Else

-                    idx = idx + 1

-                End If

-            End If

-        Loop While (idx <> -1)

-    End With

-End Function

-

-' Возвращает index глобального имени зоны из сортированного списка имен зон

-' Пример для зоны Russia, Moscow глобальной будет являться зона с именем Russia

-' Результаты функции:

-' -1 исследуемая зона уже является глобальной

-' > 0 - глобальной зоны найденной глобальной зоны в списке

-

-Function GetGlobalDescrIdx(Dst As Range, AreaCount As Integer, Optional StartIndex As Integer = 1) As Integer

-    Dim iStrPos As Integer

-    Dim s As String

-    Dim idx As Integer

-    

-    s = Dst

-    idx = StartIndex

-    iStrPos = Len(s)

-    

-    GetGlobalDescrIdx = -1

-    

-    With Dst.Worksheet

-        Do

-            idx = FindVIndex(Dst.EntireColumn, AreaCount, s, idx)

-            If idx > 0 Then

-                If idx <> Dst.Row Then

-                    GetGlobalDescrIdx = idx

-                    Exit Do

-                Else

-                    idx = idx + 1

-                End If

-            Else

-                iStrPos = InStrRev(s, " ") - 1

-                If iStrPos = -1 Then

-                    iStrPos = InStrRev(s, ",") - 1

-                End If

-                If iStrPos <> -1 Then

-                    idx = 1

-                    s = Left(s, iStrPos)

-                End If

-            End If

-        Loop While (idx <> -1 And iStrPos <> 0)

-    End With

-End Function

-

-' Возвращает index глобальной зоны из сортированного списка зон

-' Пример для зоны s709643 глобальной будут являться зоны s7096 и s7

-

-' Результаты функции:

-' -1 исследуемая зона является глобальной

-' > 0 - индекс в списке глобальной зоны

-

-Function FindGlobalAreaIdx(Dst As Range, AreaCount As Integer) As Integer

-    Dim iStrPos As Integer

-    Dim s As String

-    Dim idx As Integer

-    

-    FindGlobalAreaIdx = -1

-    

-    s = Dst

-    If s = "" Then

-        Exit Function

-    End If

-    

-    idx = 1

-    iStrPos = Len(s) - 1

-    

-    With Dst.Worksheet

-        s = Left(s, iStrPos)

-        Do

-            idx = FindVIndex(Dst.EntireColumn, AreaCount, s, idx)

-            If idx > 0 Then

-                If idx <> Dst.Row Then

-                    FindGlobalAreaIdx = idx

-                    Exit Do

-                Else

-                    idx = idx + 1

-                End If

-            Else

-                iStrPos = iStrPos - 1

-                If iStrPos > 1 Then

-                    s = Left(s, iStrPos)

-                    idx = 1

-                End If

-            End If

-        Loop While (idx <> -1 And iStrPos <> 0)

-    End With

-End Function

-

-' Возвращает index глобальной зоны из сортированного списка зон

-' Пример для зоны 709643 глобальной будут являться зоны 7096 и 7

-

-' Результаты функции:

-' -1 исследуемая зона является глобальной

-' > 0 - индекс в списке глобальной зоны

-

-Function GetGlobalAreaIdx(wks_name As String, range_name As String, AreaCount As Integer, scDst) As Integer

-    Dim i As Integer

-    Dim s As String

-    Dim Answer As Integer

-    

-    GetGlobalAreaIdx = -1

-    

-    With ThisWorkbook.Worksheets(wks_name)

-        For i = Len(scDst) To 2 Step -1

-            s = Left(scDst, i)

-            Answer = FindVIndex(.Range(range_name), AreaCount, s)

-            If Answer > 0 Then

-                GetGlobalAreaIdx = Answer

-                Exit Function

-            End If

-        Next i

-    End With

-End Function

-

-Function FindVIndex(Src As Range, AreaCount As Integer, s As String, Optional Start As Integer = 1) As Integer

-    Dim l As Long

-    FindVIndex = -1

-    For l = Start To AreaCount

-        If s = Src.Cells(l, 1) Then

-            FindVIndex = l

-            Exit Function

-        End If

-    Next l

-End Function

-

-Sub MarkDublicates(Src As Range)

-    Dim Dst As Range

-    Set Dst = Src.Offset(1, 0)

-    While Dst <> ""

-        If Dst = Src Then

-            With Dst.EntireRow

-                .Font.Bold = True

-                .Font.ColorIndex = 3

-            End With

-            Set Dst = Dst.Offset(1, 0)

-        Else

-            Set Src = Dst

-            Set Dst = Src.Offset(1, 0)

-        End If

-    Wend

-End Sub

-

-Function RC2ADDR(RowIdx As Integer, ColIdx As Integer) As String

-    Dim s As String

-    Dim Chars As String

-    Dim idx As Integer

-    idx = ColIdx

-    Chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-    While idx > 1

-        s = Mid(Chars, idx Mod Len(Chars), 1) & s

-        idx = idx \ Len(Chars)

-    Wend

-    RC2ADDR = s & RowIdx

-End Function

-<<<<<<
-======================
-mbConstatnts
->>>>>>
-Attribute VB_Name = "mbConstatnts"

-Option Explicit

-

-Public Const UNKNOWN_AREA As String = "UNKNOWN_"

-Public Const NONAME_AREA As String = "*"

-

-Public Const WKS_AREAS_NAME As String = "GlobalList"

-Public Const WKS_PRICE_NAME As String = "OpPrices"

-Public Const WKS_COMPACT_NAME As String = "CompactPrices"

-Public Const WKS_TRAFFIC_NAME As String = "OpTraffic"

-Public Const WKS_FIX_AREAS_NAME As String = "GLFixed"

-Public Const WKS_HOME_NAME As String = "Home"

-

-Public Const Ofs_InPriceList As Integer = 2

-Public Const Ofs_ChkParent As Integer = 3

-Public Const Ofs_ChkChild As Integer = 4

-Public Const Ofs_ChkAlias As Integer = 5

-

-

-Public Const WKS_A3 As String = "A3"

-Public Const idx_sCode As Integer = 0

-Public Const idx_Code As Integer = 1

-Public Const idx_eDescr As Integer = 2

-Public Const idx_rDescr As Integer = 3

-Public Const idx_Price As Integer = 4

-Public Const idx_Traffic As Integer = 5

-Public Const idx_Calls As Integer = 6

-Public Const idx_Status As Integer = 7

-Public Const idx_Price2 As Integer = 8

-

-Public Const idx_DatTraffic As Integer = 2

-Public Const idx_DatCalls As Integer = 3

-

-Public Const idx_GLStatus As Integer = 4 ' колонка статуса зоны в листе WKS_AREAS_NAME

-

-Public Const idx_GLZType As Integer = 5 ' колонка типа зоны в листе WKS_FIX_AREAS_NAME

-Public Const GLZType_Mobile As String = "M" ' маркер мобильных зон в листе WKS_FIX_AREAS_NAME

-Public Const GLZType_Static As String = "D" ' маркер обычных зон в листе WKS_FIX_AREAS_NAME

-

-Public Const ADD_CODE_ONLY As Integer = 0

-Public Const ADD_CODE_PRICE As Integer = 1

-Public Const ADD_CODE_TRAFFIC As Integer = 2

-

-<<<<<<
-======================
-Sheet22
->>>>>>
-Attribute VB_Name = "Sheet22"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet24
->>>>>>
-Attribute VB_Name = "Sheet24"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet25
->>>>>>
-Attribute VB_Name = "Sheet25"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet28
->>>>>>
-Attribute VB_Name = "Sheet28"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet29
->>>>>>
-Attribute VB_Name = "Sheet29"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mCompact
->>>>>>
-Attribute VB_Name = "mCompact"

-Option Explicit

-

-' для работы этой процедуры необходимо установить правильно значения констант

-Private Const SHEET_NAME As String = "CompactPrices"

-Private Const START_CELL_ADDR As String = "W3"

-Private Const DST_CELL_ADDR As String = "B3"

-

-Sub zzz_CopactCodes()

-    Dim Src As Range

-    Dim Dst As Range

-    Dim r As Range

-    Dim AreaCount As Integer

-    Dim GlobalIdx As Integer

-    

-    

-    Set Src = ThisWorkbook.Worksheets(SHEET_NAME).Range(START_CELL_ADDR)

-    Set Dst = ThisWorkbook.Worksheets(SHEET_NAME).Range(DST_CELL_ADDR)

-    

-    While Dst <> ""

-        If Src <> "" Then

-            Dst = ""

-            Set r = Src

-            While r <> ""

-                If Dst = "" Then

-                    Dst = r

-                Else

-                    Dst = Dst & ";" & r

-                End If

-                Set r = r.Offset(0, 1)

-            Wend

-        End If

-        Set Dst = Dst.Offset(1, 0)

-        Set Src = Src.Offset(1, 0)

-    Wend

-    Dst.EntireColumn.AutoFit

-End Sub

-

-<<<<<<
-======================
-Sheet31
->>>>>>
-Attribute VB_Name = "Sheet31"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-zTest
->>>>>>
-Attribute VB_Name = "zTest"

-Sub z_CheckGLFixed()

-    Dim r As Range

-    Set r = ThisWorkbook.Worksheets(WKS_FIX_AREAS_NAME).Range(WKS_A3)

-    

-    MarkDublicates r

-End Sub

-

-Sub z_SetZoneType()

-    Dim r As Range

-    Set r = ThisWorkbook.Worksheets(WKS_FIX_AREAS_NAME).Range(WKS_A3)

-    While r <> ""

-        If InStr(r.Offset(0, idx_eDescr), "Cell") > 0 Then

-            r.Offset(0, idx_GLZType) = GLZType_Mobile

-        Else

-            r.Offset(0, idx_GLZType) = GLZType_Static

-        End If

-        Set r = r.Offset(1, 0)

-    Wend

-    With r.EntireColumn

-        .HorizontalAlignment = xlCenter

-        .AutoFit

-    End With

-    

-End Sub

-

-<<<<<<
-======================
-Sheet30
->>>>>>
-Attribute VB_Name = "Sheet30"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-mForecastPrice
->>>>>>
-Attribute VB_Name = "mForecastPrice"

-Option Explicit

-

-

-Sub Step_4a_SetParentZonePrices()

-    Dim i As Integer

-    Dim k As Integer

-    Dim DstRange As Range

-    Dim ListsRange As Range

-    

-    With ThisWorkbook

-'        .Application.ScreenUpdating = False

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        

-        Dim s As String

-        i = 0

-        For k = 1 To ListsRange.Count

-            If ListsRange(k, Ofs_InPriceList) <> 1 Then

-                GoTo End_of_For_1

-            End If

-            

-            If ListsRange(k, Ofs_ChkParent) = 1 Then

-                Set DstRange = .Worksheets(WKS_PRICE_NAME).Range(WKS_A3)

-                RestoreParentZonePrice DstRange, idx_PriceIN + i

-            End If

-            

-            i = i + 1

-End_of_For_1:

-        Next k

-        .Application.ScreenUpdating = True

-    End With

-End Sub

-

-Sub Step_4b_SetChildZonePrices()

-    Dim i As Integer

-    Dim k As Integer

-    Dim DstRange As Range

-    Dim ListsRange As Range

-    

-    With ThisWorkbook

-        .Application.ScreenUpdating = False

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        

-        Dim s As String

-        i = 0

-        For k = 1 To ListsRange.Count

-            If ListsRange(k, Ofs_InPriceList) <> 1 Then

-                GoTo End_of_For_1

-            End If

-            

-            If ListsRange(k, Ofs_ChkChild) = 1 Then

-                Set DstRange = .Worksheets(WKS_PRICE_NAME).Range(WKS_A3)

-                RestoreChildZonePrice DstRange, idx_PriceIN + i

-            End If

-            

-            i = i + 1

-End_of_For_1:

-        Next k

-        .Application.ScreenUpdating = True

-    End With

-End Sub

-

-Sub Step_4c_SetAliasZonePrices()

-    Dim i As Integer

-    Dim k As Integer

-    Dim DstRange As Range

-    Dim ListsRange As Range

-    

-    With ThisWorkbook

-        .Application.ScreenUpdating = False

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        

-        Dim s As String

-        i = 0

-        For k = 1 To ListsRange.Count

-            If ListsRange(k, Ofs_InPriceList) <> 1 Then

-                GoTo End_of_For_1

-            End If

-            

-            If ListsRange(k, Ofs_ChkAlias) = 1 Then

-                Set DstRange = .Worksheets(WKS_PRICE_NAME).Range(WKS_A3)

-                RestoreAliasZonePrice DstRange, idx_PriceIN + i

-            End If

-            

-            i = i + 1

-End_of_For_1:

-        Next k

-        .Application.ScreenUpdating = True

-    End With

-

-End Sub

-

-Sub RestoreAliasZonePrice(r As Range, PriceIndex As Integer)

-    Dim Src As Range

-    Dim Dst As Range

-    Dim IdxAliasPrice As Integer

-    Dim AreaCount As Integer

-    

-    Set Dst = r

-    

-    AreaCount = GetLinesCount(Dst)

-    

-    Set Dst = r

-    While Dst <> ""

-        If Dst.Offset(0, PriceIndex) = "-" Then

-            IdxAliasPrice = 1

-            Do

-                IdxAliasPrice = GetAliasDescrIdx(Dst.Offset(0, idx_eDescr), AreaCount, IdxAliasPrice)

-                If IdxAliasPrice = -1 Then

-                    Exit Do

-                End If

-                Set Src = r.Offset(IdxAliasPrice - 3, 0)

-                If Application.WorksheetFunction.IsNumber(Src.Offset(0, PriceIndex)) Then

-                    Exit Do

-                Else

-                    IdxAliasPrice = IdxAliasPrice + 1

-                End If

-            Loop

-            

-            If IdxAliasPrice > -1 Then

-                Set Src = r.Offset(IdxAliasPrice - 3, PriceIndex)

-                If Application.WorksheetFunction.IsNumber(Src) Then

-                    Dst.Offset(0, PriceIndex) = Src

-                    With Dst.Offset(0, PriceIndex)

-                        .Font.Bold = True

-                        .Font.Underline = xlUnderlineStyleSingle

-                        .Font.Italic = False

-                        .Font.ColorIndex = 10 ' green

-                    End With

-                End If

-            End If

-        End If

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-End Sub

-

-Sub RestoreChildZonePrice(r As Range, PriceIndex As Integer)

-    Dim Dst As Range

-    Dim IdxParentPrice As Integer

-    Dim AreaCount As Integer

-    

-    Set Dst = r

-    

-    AreaCount = GetLinesCount(Dst)

-    

-    Set Dst = r

-    While Dst <> ""

-        If Dst.Offset(0, PriceIndex) = "-" Then

-            IdxParentPrice = FindGlobalAreaIdx(Dst, AreaCount)

-            If IdxParentPrice > -1 Then

-                Dst.Offset(0, PriceIndex) = r.Offset(IdxParentPrice - 3, PriceIndex)

-                With Dst.Offset(0, PriceIndex)

-                    .Font.Bold = False

-                    .Font.Italic = True

-                    .Font.ColorIndex = 29 ' magenta

-                End With

-            End If

-        End If

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-End Sub

-

-Sub RestoreParentZonePrice(r As Range, PriceIndex As Integer)

-    Dim Src As Range

-    Dim Dst As Range

-    Dim IdxMaxPrice As Integer

-    

-    Set Dst = r

-    

-    While Dst <> ""

-        If Dst.Offset(0, PriceIndex) = "-" Then

-            Set Src = Dst.Offset(1, 0)

-            IdxMaxPrice = GetZoneMaxPrice(Dst, Src, PriceIndex)

-            If IdxMaxPrice >= 0 Then

-                Dst.Offset(0, PriceIndex) = Src.Offset(IdxMaxPrice, PriceIndex)

-                With Dst.Offset(0, PriceIndex)

-                    .Font.Bold = True

-                    .Font.Italic = True

-                    .Font.ColorIndex = 3 ' Red

-                End With

-            End If

-        End If

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-End Sub

-

-Function GetZoneMaxPrice(Dst As Range, Src As Range, price_idx As Integer) As Integer

-    Dim s As String

-    Dim MaxPrice As Double

-    Dim MaxPriceIdx As Integer

-    

-    GetZoneMaxPrice = -1

-    MaxPrice = -1

-    MaxPriceIdx = 0

-    

-    While InStr(1, Src.Offset(MaxPriceIdx, 0), Dst) > 0

-        

-        If Application.WorksheetFunction.IsNumber(Src.Offset(MaxPriceIdx, price_idx)) Then

-            If MaxPrice < Src.Offset(MaxPriceIdx, price_idx) Then

-                MaxPrice = Src.Offset(MaxPriceIdx, price_idx)

-                GetZoneMaxPrice = MaxPriceIdx

-            End If

-        End If

-        MaxPriceIdx = MaxPriceIdx + 1

-    Wend

-End Function

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet19
->>>>>>
-Attribute VB_Name = "Sheet19"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-mOpPrices
->>>>>>
-Attribute VB_Name = "mOpPrices"

-Option Explicit

-

-Public Const idx_PriceIN As Integer = 4

-

-Sub Step_3_Recalc_1st_Prices()

-    AnalyzeOpPricesData WKS_PRICE_NAME, "0.0000"

-End Sub

-

-

-

-Sub AnalyzeOpPricesData(wks_name As String, DATA_fmt As String)

-

-' Формируем список зон на рабочем листе

-' Удаляем предыдущий расчет

-    ClearWorkArea (wks_name)

-    

-    ThisWorkbook.Worksheets(wks_name).Activate

-    ThisWorkbook.Worksheets(wks_name).Cells.Select

-    With Selection

-        .ClearContents

-        .Interior.ColorIndex = xlNone

-        .Font.Bold = False

-        .Font.ColorIndex = 0

-        .HorizontalAlignment = xlGeneral

-        .VerticalAlignment = xlBottom

-        .WrapText = False

-        .Orientation = 0

-        .AddIndent = False

-        .ShrinkToFit = False

-        .MergeCells = False

-    End With

-    ThisWorkbook.Worksheets(wks_name).Range("A1").Select

-

-' Подсчитываем количество входящих в прайс-листов

-    Dim ListsRange As Range

-    Dim i As Integer

-    Dim j As Integer

-    Dim k As Integer

-    Dim ListsRange_PriceCount As Integer

-    

-    Set ListsRange = ThisWorkbook.Worksheets(WKS_HOME_NAME).Range("OpList")

-    ListsRange_PriceCount = 0

-

-    For i = 1 To ListsRange.Count

-        If ListsRange(i, Ofs_InPriceList) = 1 Then

-            ListsRange_PriceCount = ListsRange_PriceCount + 1

-        End If

-    Next i

-

-

-

-' Форматируем заголовок рабочего листа

-

-    Dim SrcRange As Range

-    Dim DstRange As Range

-

-    With ThisWorkbook

-        .Application.ScreenUpdating = False

-        

-        Set DstRange = .Worksheets(wks_name).Range(WKS_A3)

-

-

-        With DstRange

-            .Offset(-2, idx_sCode) = "Common"

-            .Offset(-1, idx_sCode) = "sCode"

-            .Offset(-1, idx_Code) = "Code"

-            .Offset(-1, idx_eDescr) = "Descr_E"

-            .Offset(-1, idx_rDescr) = "Descr_R"

-            .Offset(-2, idx_PriceIN) = "Price (In)"

-            k = 1

-            For i = 1 To ListsRange.Count

-                If ListsRange(i, Ofs_InPriceList) = 1 Then

-                    .Offset(-1, k + idx_PriceIN - 1) = ListsRange(i, 1)

-                    k = k + 1

-                End If

-            Next i

-            .Offset(-2, idx_PriceIN + ListsRange_PriceCount) = "Stat of Price (IN)"

-            .Offset(-1, idx_PriceIN + ListsRange_PriceCount) = "Count"

-            .Offset(-1, idx_PriceIN + ListsRange_PriceCount + 1) = "Min"

-            .Offset(-1, idx_PriceIN + ListsRange_PriceCount + 1) = "Min"

-            .Offset(-1, idx_PriceIN + ListsRange_PriceCount + 2) = "Max"

-            .Offset(-1, idx_PriceIN + ListsRange_PriceCount + 3) = "Avg"

-            .Offset(-1, idx_PriceIN + ListsRange_PriceCount + 4) = "Down"

-            .Offset(-1, idx_PriceIN + ListsRange_PriceCount + 5) = "Up"

-            .Offset(-2, idx_PriceIN + ListsRange_PriceCount + 6) = "Operators"

-            .Offset(-1, idx_PriceIN + ListsRange_PriceCount + 6) = "Price"

-            .Offset(-2, idx_PriceIN + ListsRange_PriceCount + 7) = "Profit[x100%]"

-            .Offset(-1, idx_PriceIN + ListsRange_PriceCount + 7) = "Avg"

-            .Offset(-1, idx_PriceIN + ListsRange_PriceCount + 8) = "Min"

-            .Offset(-1, idx_PriceIN + ListsRange_PriceCount + 9) = "Max"

-            .Offset(-2, idx_PriceIN + ListsRange_PriceCount + 10) = "Op Profit[x100%] (Routing type 1)"

-            j = idx_PriceIN + ListsRange_PriceCount + 10

-            k = 1

-            For i = 1 To ListsRange.Count

-                If ListsRange(i, Ofs_InPriceList) = 1 Then

-                    .Offset(-1, k + j - 1) = ListsRange(i, 1)

-                    k = k + 1

-                End If

-            Next i

-            With .Offset(-2, 0).EntireRow

-                .HorizontalAlignment = xlLeft

-                .Font.Bold = True

-            End With

-            With .Offset(-1, 0).EntireRow

-                .HorizontalAlignment = xlCenter

-                .Font.Bold = True

-            End With

-            

-        End With

-

-' Копируем созданный список на рабочий лист

-        Set SrcRange = .Worksheets(WKS_FIX_AREAS_NAME).Range(WKS_A3)

-        

-        CopyAreasList DstRange, SrcRange

-        

-        Set SrcRange = .Worksheets(WKS_AREAS_NAME).Range(WKS_A3)

-        

-        Set DstRange = .Worksheets(wks_name).Range(WKS_A3)

-    End With

-

-' Подсчитываем общее количество зон

-

-    Dim AreaCount As Integer

-    AreaCount = GetLinesCount(DstRange)

-

-

-' Форматируем полученный результат

-        

-    For i = 1 To 4

-        Set DstRange = ThisWorkbook.Worksheets(wks_name) _

-                    .Range(Cells(2, i), Cells(2 + AreaCount, i))

-        With DstRange

-            .EntireColumn.AutoFit

-            If i Mod 2 = 1 Then

-                .Interior.ColorIndex = 36 ' LightYellow

-            Else

-                .Interior.ColorIndex = xlNone  'White

-            End If

-        End With

-    Next i

-

-' Перебираем цены/данные всех операторов и формируем общий список цен по зонам

-' Копируем цены операторов для зон

-

-    With ThisWorkbook

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        

-        Dim s As String

-        i = 1

-        For k = 1 To ListsRange.Count

-            If ListsRange(k, Ofs_InPriceList) <> 1 Then

-                GoTo End_of_For_1

-            End If

-            Set DstRange = .Worksheets(wks_name).Range(WKS_A3)

-            s = ListsRange.Cells(k, 1).Value

-            If wks_name = WKS_TRAFFIC_NAME Then

-                s = s & ".Data"

-            End If

-            

-            If SheetExist(s) Then

-                Set SrcRange = .Worksheets(s).Range(WKS_A3)

-    

-                AddOpPriceData DstRange, SrcRange, i - 1

-                

-            End If

-            

-' Форматируем полученный результат

-            With .Worksheets(wks_name)

-                Set DstRange = .Range(.Cells(2, idx_Price + i), .Cells(2 + AreaCount, idx_Price + i))

-            End With

-            With DstRange

-                .NumberFormat = DATA_fmt

-                .Font.Bold = True

-                .HorizontalAlignment = xlCenter

-                .VerticalAlignment = xlBottom

-                .WrapText = False

-                .Orientation = 0

-                .AddIndent = False

-                .ShrinkToFit = False

-                .MergeCells = False

-                If i Mod 2 = 1 Then

-                    .Interior.ColorIndex = 36 ' LightYellow

-                Else

-                    .Interior.ColorIndex = xlNone  'White

-                End If

-            End With

-            i = i + 1

-End_of_For_1:

-        Next k

-        

-' Маркируем пустые направления у каждого оператора

-

-        With Worksheets(wks_name)

-            Set DstRange = .Range(.Cells(2, idx_Price + 1), .Cells(2 + AreaCount, idx_Price + ListsRange_PriceCount))

-        End With

-        

-'        DstRange.Select

-        

-        For Each SrcRange In DstRange

-            If SrcRange = "" Then

-                SrcRange = "-"

-            End If

-        Next SrcRange

-        

-        Set SrcRange = .Worksheets(wks_name).Range(WKS_A3)

-    End With

-    

-' Рассчитываем статистику по ценам

-    Set DstRange = ThisWorkbook.Worksheets(wks_name) _

-                .Range(WKS_A3).Offset(0, idx_PriceIN + ListsRange_PriceCount)

-                

-    DstRange.Select

-    

-    Dim Stat1stCol As Integer

-    Dim StatMinCol As Integer

-    Dim StatMaxCol As Integer

-    Dim StatAvgCol As Integer

-    Dim StatDnCol As Integer

-    Dim StatUpCol As Integer

-    

-    Dim offsetMinCol As Integer

-    Dim offsetMaxCol As Integer

-    Dim offsetAvgCol As Integer

-    Dim offsetUpCol As Integer

-    Dim offsetDnCol As Integer

-    Dim offsetPriceCol As Integer

-    Dim offsetAvgPtCol As Integer

-    Dim offsetMinPtCol As Integer

-    Dim offsetMaxPtCol As Integer

-    

-    

-    Stat1stCol = idx_PriceIN + ListsRange_PriceCount + 1

-    

-    offsetMinCol = 1

-    offsetMaxCol = 2

-    offsetAvgCol = 3

-    offsetUpCol = 4

-    offsetDnCol = 5

-    offsetPriceCol = 6

-    offsetAvgPtCol = 7

-    offsetMinPtCol = 8

-    offsetMaxPtCol = 9

-    

-    StatMinCol = Stat1stCol + offsetMinCol

-    StatMaxCol = Stat1stCol + offsetMaxCol

-    StatAvgCol = Stat1stCol + offsetAvgCol

-    StatUpCol = Stat1stCol + offsetUpCol

-    StatDnCol = Stat1stCol + offsetDnCol

-    

-    

-    For i = 0 To AreaCount - 1

-        s = RC2ADDR(i + 3, idx_PriceIN + 1) & ":" & RC2ADDR(i + 3, idx_PriceIN + ListsRange_PriceCount)

-        DstRange.Offset(i, 0).Formula = "=count(" & s & ")"

-        

-        Dim AnchorCell As String

-        AnchorCell = RC2ADDR(i + 3, Stat1stCol)

-        

-        DstRange.Offset(i, offsetMinCol).Formula = "=if(" & AnchorCell & ">0, min(" & s & "), ""-"")"

-        DstRange.Offset(i, offsetMaxCol).Formula = "=if(" & AnchorCell & ">0, max(" & s & "), ""-"")"

-        DstRange.Offset(i, offsetAvgCol).Formula = "=if(" & AnchorCell & ">0, average(" & s & "), ""-"")"

-        s = "=if(" & AnchorCell & ">0,(" & RC2ADDR(i + 3, StatAvgCol) & "-" & RC2ADDR(i + 3, StatMaxCol) & ")/" & RC2ADDR(i + 3, StatAvgCol) & ", ""-"")"

-        With DstRange.Offset(i, offsetDnCol)

-            .Formula = s

-            .NumberFormat = "0.00%_);[Red](0.00)%"

-        End With

-        s = "=if(" & AnchorCell & ">0, (" & RC2ADDR(i + 3, StatAvgCol) & "-" & RC2ADDR(i + 3, StatMinCol) & ")/" & RC2ADDR(i + 3, StatAvgCol) & ", ""-"")"

-        With DstRange.Offset(i, offsetUpCol)

-            .Formula = s

-            .NumberFormat = "0.00%"

-        End With

-

-' Расчет отпускной цены по формуле.

-        s = "=if(" & AnchorCell & ">0, if(" & RC2ADDR(i + 3, StatAvgCol) & "<=Trigger, " & RC2ADDR(i + 3, StatAvgCol) & "+FixedV," & RC2ADDR(i + 3, StatAvgCol) & "* FIxedP), ""-"")"

-        With DstRange.Offset(i, offsetPriceCol)

-            .Formula = s

-            .NumberFormat = "0.000"

-        End With

-

-' Расчет Прибыли и Убытков.

-        s = "=if(" & AnchorCell & ">0, (" & RC2ADDR(i + 3, Stat1stCol + offsetPriceCol) & "-" & RC2ADDR(i + 3, StatAvgCol) & ")/" & RC2ADDR(i + 3, StatAvgCol) & ", ""-"")"

-        With DstRange.Offset(i, offsetAvgPtCol)

-            .Formula = s

-            .HorizontalAlignment = xlCenter

-            .NumberFormat = "0.00%_);[Red](0.00)%"

-        End With

-

-        s = "=if(" & AnchorCell & ">0, (" & RC2ADDR(i + 3, Stat1stCol + offsetPriceCol) & "-" & RC2ADDR(i + 3, StatMaxCol) & ")/" & RC2ADDR(i + 3, StatMaxCol) & ", ""-"")"

-        With DstRange.Offset(i, offsetMinPtCol)

-            .Formula = s

-            .HorizontalAlignment = xlCenter

-            .NumberFormat = "0.00%_);[Red](0.00)%"

-        End With

-

-        s = "=if(" & AnchorCell & ">0, (" & RC2ADDR(i + 3, Stat1stCol + offsetPriceCol) & "-" & RC2ADDR(i + 3, StatMinCol) & ")/" & RC2ADDR(i + 3, StatMinCol) & ", ""-"")"

-        With DstRange.Offset(i, offsetMaxPtCol)

-            .Formula = s

-            .HorizontalAlignment = xlCenter

-            .NumberFormat = "0.00%_);[Red](0.00%)"

-        End With

-

-' Расчет Прибыли и Убытков по операторам (Routing type 1)

-        

-        j = 1

-        For k = 1 To ListsRange.Count

-            If ListsRange(k, Ofs_InPriceList) = 1 Then

-                AnchorCell = RC2ADDR(i + 3, idx_PriceIN + j)

-                s = "=if(isnumber(" & AnchorCell & "), (" & RC2ADDR(i + 3, Stat1stCol + offsetPriceCol) & "-" & AnchorCell & ")/" & AnchorCell & ", ""-"")"

-                With DstRange.Offset(i, offsetMaxPtCol + j)

-                    .Formula = s

-                    .NumberFormat = "0.00%_);[Red](0.00)%"

-                End With

-                j = j + 1

-            End If

-        Next k

-    Next i

-

-

-' Форматируем полученный результат

-' Статистика

-    For i = 0 To 5

-        With ThisWorkbook.Worksheets(wks_name)

-            Set DstRange = .Range(.Cells(2, Stat1stCol + i), .Cells(2 + AreaCount, Stat1stCol + i))

-        End With

-        With DstRange

-            If i > 0 And i <= 3 Then

-                .NumberFormat = DATA_fmt

-            End If

-            .HorizontalAlignment = xlCenter

-            .VerticalAlignment = xlBottom

-            .WrapText = False

-            .Orientation = 0

-            .AddIndent = False

-            .ShrinkToFit = False

-            .MergeCells = False

-            If i Mod 2 = 0 Then

-                .Interior.ColorIndex = 35 ' LightLightGreen

-            Else

-                .Interior.ColorIndex = 34  ' LightLightBlue

-            End If

-        End With

-    Next i

-

-' Формат колонки "Operators price"

-

-    With ThisWorkbook.Worksheets(wks_name)

-        Set DstRange = .Range(.Cells(1, Stat1stCol + offsetPriceCol), .Cells(2 + AreaCount, Stat1stCol + offsetPriceCol))

-        With DstRange

-            .Interior.ColorIndex = 36 ' LightYellow

-            .Font.ColorIndex = 10

-            .Font.Bold = True

-            .NumberFormat = "0.0000"

-            .HorizontalAlignment = xlCenter

-            .VerticalAlignment = xlBottom

-        End With

-    End With

-

-' Формат Прибыли и Убытков по операторам (Routing type 1)

-    For j = 1 To ListsRange_PriceCount

-        With ThisWorkbook.Worksheets(wks_name)

-            Set DstRange = .Range(.Cells(2, Stat1stCol + offsetMaxPtCol + j), .Cells(2 + AreaCount, Stat1stCol + offsetMaxPtCol + j))

-        End With

-        With DstRange

-            .HorizontalAlignment = xlCenter

-            .VerticalAlignment = xlBottom

-            .WrapText = False

-            .Orientation = 0

-            .AddIndent = False

-            .ShrinkToFit = False

-            .MergeCells = False

-            If j Mod 2 = 0 Then

-                .Interior.ColorIndex = 34  ' LightLightBlue

-            Else

-                .Interior.ColorIndex = 35 ' LightLightGreen

-            End If

-        End With

-    Next j

-    Application.ScreenUpdating = True

-End Sub

-

-Sub CopyAreasList(Dst As Range, Src As Range)

-    While Src <> ""

-        Dst.Offset(0, idx_sCode).Value = Src.Offset(0, idx_sCode).Value

-        Dst.Offset(0, idx_Code).Value = Src.Offset(0, idx_Code).Value

-        Dst.Offset(0, idx_eDescr).Value = Src.Offset(0, idx_eDescr).Value

-        Dst.Offset(0, idx_rDescr).Value = Src.Offset(0, idx_rDescr).Value

-        Set Src = Src.Offset(1, 0)

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-End Sub

-

-

-Sub AddOpPriceData(Dst As Range, Src As Range, index As Integer)

-    While Src <> "" And Dst <> ""

-        If Dst = Src Then

-            Dst.Offset(0, idx_Price + index) = Src.Offset(0, idx_Price)

-            Set Dst = Dst.Offset(1, 0)

-        End If

-        If Dst > Src Then

-            Set Src = Src.Offset(1, 0)

-        End If

-        If Dst < Src Then

-            Set Dst = Dst.Offset(1, 0)

-        End If

-    Wend

-End Sub

-

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet27
->>>>>>
-Attribute VB_Name = "Sheet27"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet23
->>>>>>
-Attribute VB_Name = "Sheet23"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-mGlobalList
->>>>>>
-Attribute VB_Name = "mGlobalList"

-Option Explicit

-

-

-

-

-Sub Step_1_BuildWorkPriceLists()

-

-    Dim SrcRange As Range

-    Dim DstRange As Range

-    Dim ListsRange As Range

-    

-    

-    With ThisWorkbook

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        

-        Dim s As String

-        Dim i As Integer

-    

-' Перебираем названия всех операторов и формируем общий список зон

-        With .Application

-            .Calculation = xlCalculationManual

-            .ScreenUpdating = False

-        End With

-

-        For i = 1 To ListsRange.Count

-            s = ListsRange.Cells(i, 1).Value

-            

-            CreateComSheet (s)

-            

-            Set DstRange = .Worksheets(s).Range(WKS_A3)

-            Set SrcRange = .Worksheets(s & ".Tarif").Range(WKS_A3)

-            

-            MarkDublicates SrcRange

-            

-            Set SrcRange = .Worksheets(s & ".Tarif").Range(WKS_A3)

-            AddOpArea DstRange, SrcRange, ADD_CODE_PRICE

-            

-            Set DstRange = .Worksheets(s).Range(WKS_A3)

-            

-            If SheetExist(s & ".Data") Then

-                Set SrcRange = .Worksheets(s & ".Data").Range(WKS_A3)

-                AddOpArea DstRange, SrcRange, ADD_CODE_TRAFFIC

-            End If

-            

-' Присваиваем зонам статус:

-' 00 - не известная, не используется

-' 01 - не известная, используется

-' 10 - известная, не используется

-' 11 - известная, используется

-            

-            Set DstRange = .Worksheets(s).Range(WKS_A3)

-            While DstRange <> ""

-                If DstRange.Offset(0, idx_Price) = 0 Or DstRange.Offset(0, idx_Price) = "-" Then

-                    If DstRange.Offset(0, idx_Traffic) = 0 Then

-                        DstRange.Offset(0, idx_Status) = 0

-                    Else

-                        DstRange.Offset(0, idx_Status) = 1

-                    End If

-                Else

-                    If DstRange.Offset(0, idx_Traffic) = 0 Then

-                        DstRange.Offset(0, idx_Status) = 10

-                    Else

-                        DstRange.Offset(0, idx_Status) = 11

-                    End If

-                End If

-                Set DstRange = DstRange.Offset(1, 0)

-            Wend

-                

-            With .Worksheets(s)

-                With .Columns("A:H")

-                    .HorizontalAlignment = xlHAlignGeneral

-                    .VerticalAlignment = xlBottom

-                    .WrapText = False

-                    .Orientation = 0

-                    .AddIndent = False

-                    .ShrinkToFit = True

-                    .MergeCells = False

-                End With

-                .Columns("A:A").HorizontalAlignment = xlLeft

-                .Columns("B:B").NumberFormat = "#"

-                With .Rows("2:2")

-                    .Font.Bold = False

-                    .WrapText = False

-                    .HorizontalAlignment = xlCenter

-                End With

-                With .Columns("G:G")

-                    .HorizontalAlignment = xlHAlignCenter

-                    .NumberFormat = "0#"

-                End With

-            End With

-            MarkDublicates (.Worksheets(s).Range(WKS_A3))

-        Next i

-        With .Application

-            .Calculation = xlCalculationAutomatic

-            .ScreenUpdating = True

-            .Calculate

-        End With

-        

-    End With

-

-End Sub

-

-Sub Step_2_CreateGlobalCodeList()

-

-' Перебираем названия всех операторов и формируем общий список зон

-' Удаляем предыдущий расчет

-    ClearWorkArea WKS_AREAS_NAME, "A1"

-    

-' Формируем общий список зон

-

-    

-    BuildAreasList (WKS_AREAS_NAME)

-    

-    BuildAreasStatus (WKS_AREAS_NAME)

-

-    

-End Sub

-

-Sub BuildAreasList(DstName As String)

-

-    Dim SrcRange As Range

-    Dim DstRange As Range

-    Dim ListsRange As Range

-    

-    With ThisWorkbook

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        

-        Dim s As String

-        Dim i As Integer

-    

-        With .Application

-            .Calculation = xlCalculationManual

-            .ScreenUpdating = False

-        End With

-        

-' Формируем строку заголовка

-        With .Worksheets(DstName)

-            .Range("a1") = DstName

-            With .Range("a2")

-                .Offset(0, idx_sCode) = "sCode"

-                .Offset(0, idx_Code) = "Code"

-                .Offset(0, idx_eDescr) = "Descr_E"

-                .Offset(0, idx_rDescr) = "Descr_R"

-            End With

-            With .Rows("2:2")

-                .Font.Bold = False

-                .WrapText = False

-                .HorizontalAlignment = xlCenter

-            End With

-        End With

-        

-' Перебираем названия всех операторов и формируем общий список зон

-        For i = 1 To ListsRange.Count

-            s = ListsRange.Cells(i, 1).Value

-            

-            If SheetExist(s) Then

-                Set DstRange = .Worksheets(WKS_AREAS_NAME).Range(WKS_A3)

-                Set SrcRange = .Worksheets(s).Range(WKS_A3)

-        

-                AddGlobalOpArea DstRange, SrcRange

-            End If

-        Next i

-        Set SrcRange = .Worksheets(DstName).Range(WKS_A3)

-        .Worksheets(DstName).Select

-                

-        MarkDublicates (.Worksheets(DstName).Range(WKS_A3))

-        

-        With .Application

-            .Calculation = xlCalculationAutomatic

-            .ScreenUpdating = True

-            .Calculate

-        End With

-    End With

-End Sub

-

-Sub AddGlobalOpArea(Dst As Range, Src As Range)

-    While Src <> ""

-        If Dst > Src Then

-            Dst.Worksheet.Range(Dst, Dst.Offset(0, 50)).Insert Shift:=xlShiftDown

-            Set Dst = Dst.Offset(-1, 0)

-        End If

-        If Dst = "" Then

-            Dst.Offset(0, idx_sCode) = Src.Offset(0, idx_sCode)

-            Dst.Offset(0, idx_Code) = Src.Offset(0, idx_Code)

-        End If

-        If Dst = Src Then

-            CheckNameOpArea Dst, Src, ADD_CODE_ONLY

-            Set Src = Src.Offset(1, 0)

-        End If

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-    

-    Dst.Worksheet.Columns("A:H").AutoFit

-    

-    Set Dst = Dst.Worksheet.Range(WKS_A3)

-    

-End Sub

-

-Sub CheckNameOpArea(Dst As Range, Src As Range, ByVal add_type As Integer)

-    

-    Dim Exist_SrcEng As Boolean

-    Dim Exist_SrcRus As Boolean

-    Dim Exist_DstEng As Boolean

-    Dim Exist_DstRus As Boolean

-    

-    Dim Unknown_Src As Boolean

-    Dim Unknown_Dst As Boolean

-    

-    With Dst

-        Exist_DstEng = .Offset(0, idx_eDescr) <> "" And .Offset(0, idx_eDescr) <> UNKNOWN_AREA And .Offset(0, idx_eDescr) <> NONAME_AREA

-        Exist_DstRus = .Offset(0, idx_rDescr) <> "" And .Offset(0, idx_rDescr) <> UNKNOWN_AREA And .Offset(0, idx_rDescr) <> NONAME_AREA

-    End With

-    

-    Unknown_Dst = Not (Exist_DstEng Or Exist_DstRus)

-    

-    If add_type = ADD_CODE_TRAFFIC Then

-        If Unknown_Dst Then

-            Dst.Offset(0, idx_eDescr) = UNKNOWN_AREA & Dst.Offset(0, idx_Code)

-            Dst.Offset(0, idx_rDescr) = UNKNOWN_AREA & Dst.Offset(0, idx_Code)

-        End If

-        Exit Sub

-    End If

-    

-    With Src

-        Exist_SrcEng = .Offset(0, idx_eDescr) <> "" And .Offset(0, idx_eDescr) <> UNKNOWN_AREA And .Offset(0, idx_eDescr) <> NONAME_AREA

-        Exist_SrcRus = .Offset(0, idx_rDescr) <> "" And .Offset(0, idx_rDescr) <> UNKNOWN_AREA And .Offset(0, idx_rDescr) <> NONAME_AREA

-    End With

-    

-    Unknown_Src = Not (Exist_SrcEng Or Exist_SrcRus)

-    

-    If Unknown_Src And Unknown_Dst Then

-        Dst.Offset(0, idx_eDescr) = UNKNOWN_AREA

-        Dst.Offset(0, idx_rDescr) = UNKNOWN_AREA

-        Exit Sub

-    End If

-    

-    If Unknown_Src Then

-        If Not Exist_DstRus Then

-            Dst.Offset(0, idx_rDescr) = NONAME_AREA

-        End If

-        If Not Exist_DstEng Then

-            Dst.Offset(0, idx_eDescr) = NONAME_AREA

-        End If

-    Else

-        If Not Exist_DstEng Then

-            If Exist_SrcEng Then

-                Dst.Offset(0, idx_eDescr) = Src.Offset(0, idx_eDescr)

-            Else

-                Dst.Offset(0, idx_eDescr) = NONAME_AREA

-            End If

-        End If

-        If Not Exist_DstRus Then

-            If Exist_SrcRus Then

-                Dst.Offset(0, idx_rDescr) = Src.Offset(0, idx_rDescr)

-            Else

-                Dst.Offset(0, idx_rDescr) = NONAME_AREA

-            End If

-        End If

-    End If

-End Sub

-

-Sub AddOpArea(Dst As Range, Src As Range, Optional add_type = ADD_CODE_ONLY)

-    

-    While Src <> ""

-        If Dst > Src Then

-            Dst.Worksheet.Range(Dst, Dst.Offset(0, 50)).Insert Shift:=xlShiftDown

-            Set Dst = Dst.Offset(-1, 0)

-        End If

-        If Dst = "" Then

-            Dst.Offset(0, idx_sCode) = Src.Offset(0, idx_sCode)

-            Dst.Offset(0, idx_Code) = Src.Offset(0, idx_Code)

-        End If

-        If Dst = Src Then

-            Select Case add_type

-                Case ADD_CODE_PRICE

-                    Dst.Offset(0, idx_Price) = Src.Offset(0, idx_Price)

-                    If Dst.Offset(0, idx_Price) = "" Then

-                        Dst.Offset(0, idx_Price) = "-"

-                    End If

-                Case ADD_CODE_TRAFFIC

-                    Dst.Offset(0, idx_Traffic) = Src.Offset(0, idx_DatTraffic)

-                    Dst.Offset(0, idx_Calls) = Src.Offset(0, idx_DatCalls)

-                    

-            End Select

-            

-            CheckNameOpArea Dst, Src, add_type

-                        

-            Set Src = Src.Offset(1, 0)

-        End If

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-    

-    Select Case add_type

-        Case ADD_CODE_PRICE

-            Dst.Worksheet.Columns("E:E").NumberFormat = "0.0000"

-        Case ADD_CODE_TRAFFIC

-            Dst.Worksheet.Columns("F:F").NumberFormat = "0.00"

-    End Select

-    

-    Dst.Worksheet.Columns("A:H").AutoFit

-    

-    Set Dst = Dst.Worksheet.Range("A1")

-End Sub

-

-Sub BuildAreasStatus(wks_name As String)

-    Dim rSrc As Range

-    Dim rDst As Range

-    Dim ListsRange As Range

-    Dim i As Integer

-    Dim j As Integer

-    Dim s As String

-    Dim WS_Name As String

-    

-    With ThisWorkbook

-        .Application.ScreenUpdating = False

-        

-        

-' Вычисляем размер списка

-

-        Dim AreaCount As Integer

-

-        Set rDst = .Worksheets(wks_name).Range(WKS_A3)

-        

-        AreaCount = GetLinesCount(rDst) + 3

-

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        Set rDst = .Worksheets(wks_name).Range(WKS_A3)

-        j = 3

-        

-        For i = 1 To ListsRange.Count

-            rDst.Offset(-1, i + idx_GLStatus).Formula = ListsRange(i, 1)

-        Next i

-        

-' Вычисляем статусы зон для списка операторов

-        While rDst <> ""

-            For i = 1 To ListsRange.Count

-                WS_Name = ListsRange(i, 1)

-                If SheetExist(WS_Name) Then

-                    s = "INDEX(" & WS_Name & "!G1:$G$" & AreaCount & ", MATCH($A" & j & "," & WS_Name & "!$A$1:$A$" & AreaCount & ",0), 1)"

-                    s = "=if(iserror(" & s & "), ""-""," & s & ")"

-                Else

-                    s = "-"

-                End If

-                rDst.Offset(0, i + idx_GLStatus).Formula = s

-                rDst.Offset(0, i + idx_GLStatus).NumberFormat = "0#"

-            Next i

-            j = j + 1

-            Set rDst = rDst.Offset(1, 0)

-        Wend

-        

-' Форматируем результат

-        For i = 0 To ListsRange.Count

-            With rDst.Offset(-1, i + idx_GLStatus).EntireColumn

-                .HorizontalAlignment = xlCenter

-                .ShrinkToFit = True

-            End With

-        Next i

-

-' Корректируем названия зон

-

-        With .Worksheets(wks_name)

-            Set rDst = .Range(.Cells(3, 1), .Cells(AreaCount, 1))

-        End With

-

-        Set rSrc = .Worksheets(WKS_FIX_AREAS_NAME).Range(WKS_A3)

-        

-        AreaCount = GetLinesCount(rSrc) + 3

-

-        With .Worksheets(WKS_FIX_AREAS_NAME)

-            Set rSrc = .Range(.Cells(2, 1), .Cells(AreaCount, 1))

-        End With

-

-        Dim b As Range

-        Dim c As Range

-        For Each c In rDst

-            Set b = rSrc.Find(c, LookIn:=xlValues, MatchByte:=True)

-            If Not b Is Nothing Then

-                If c.Offset(0, idx_eDescr) <> b.Offset(0, idx_eDescr) Or c.Offset(0, idx_rDescr) <> b.Offset(0, idx_rDescr) Then

-                    c.Offset(0, idx_eDescr) = b.Offset(0, idx_eDescr)

-                    c.Offset(0, idx_rDescr) = b.Offset(0, idx_rDescr)

-                    c.Offset(0, idx_GLStatus) = "Fixed"

-                    With c.EntireRow

-                        .Font.Bold = True

-                        .Font.ColorIndex = xlColorIndexAutomatic

-                    End With

-                Else

-                    c.Offset(0, idx_GLStatus) = "-"

-                End If

-            Else

-                If c.Offset(0, idx_sCode) <> "" Then

-                    Dim FixedList As Range

-                    c.Offset(0, idx_GLStatus) = "New"

-                    With c.EntireRow

-                        .Font.Bold = True

-                        .Font.ColorIndex = 3 ' Red

-                    End With

-                End If

-                

-'                Set Fixed

-            End If

-        Next c

-        

-        Application.ScreenUpdating = True

-        

-    End With

-End Sub

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Sub ClearWorkArea(DstName As String, Optional StartRange As String = WKS_A3)

-    Dim DstRange As Range

-    With ThisWorkbook

-       

-        Set DstRange = .Worksheets(DstName).Range(StartRange)

-        Worksheets(DstName).Select

-        DstRange.Select

-        Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select

-        Range(Selection, Selection.End(xlDown)).Select

-        Selection.Delete Shift:=xlUp

-        Selection.Font.Bold = False

-        Selection.Font.ColorIndex = xlColorIndexAutomatic

-        Set DstRange = .Worksheets(DstName).Range(StartRange)

-        DstRange.Select

-    End With

-End Sub

-

-Function SheetExist(SheetName As String) As Boolean

-    Dim Count, i As Integer

-

-    Count = ThisWorkbook.Sheets.Count

-    SheetExist = False

-    For i = 1 To Count

-        If ThisWorkbook.Sheets(i).Name = SheetName Then

-            SheetExist = True

-            i = Count

-        End If

-    Next i

-End Function

-

-Function GetLinesCount(r As Range) As Integer

-

-    Dim LinesCount As Integer

-    Dim rr As Range

-    

-    Set rr = r

-    

-    LinesCount = 0

-

-    While rr <> ""

-        LinesCount = LinesCount + 1

-        Set rr = rr.Offset(1, 0)

-    Wend

-    

-    GetLinesCount = LinesCount

-End Function

-

-Sub CreateComSheet(wks_name As String)

-    Dim theRange As Range

-    With ThisWorkbook

-        If Not SheetExist(wks_name) Then

-            .Sheets.Add.Name = wks_name

-        End If

-            

-        .Sheets(wks_name).Visible = True

-        .Sheets(wks_name).Select

-        Cells.Select

-        Selection.ClearContents

-        Selection.Interior.ColorIndex = xlNone

-        Selection.Borders(xlLeft).LineStyle = xlNone

-        Selection.Borders(xlRight).LineStyle = xlNone

-        Selection.Borders(xlTop).LineStyle = xlNone

-        Selection.Borders(xlBottom).LineStyle = xlNone

-        Selection.BorderAround LineStyle:=xlNone

-        Selection.Font.ColorIndex = 0

-        Selection.EntireColumn.ColumnWidth = ActiveSheet.StandardWidth

-    

-        With .Worksheets(wks_name)

-            .Range("a1") = wks_name

-            With .Range("a2")

-                .Offset(0, idx_sCode) = "sCode"

-                .Offset(0, idx_Code) = "Code"

-                .Offset(0, idx_eDescr) = "Descr_E"

-                .Offset(0, idx_rDescr) = "Descr_R"

-                .Offset(0, idx_Price) = "Price"

-                .Offset(0, idx_Traffic) = "Traffic"

-                .Offset(0, idx_Calls) = "Calls"

-                .Offset(0, idx_Status) = "Status"

-            End With

-            With .Rows("2:2")

-                .Font.Bold = False

-                .WrapText = False

-                .HorizontalAlignment = xlCenter

-            End With

-            .Range("A1").Select

-        End With

-    End With

-End Sub

-

-' Возвращает index имени зоны синонима из сортированного списка имен зон, начиная со StartIndex

-' Пример для зоны Russia, Moscow глобальной будет являться зона с именем Russia

-' Результаты функции:

-' -1 исследуемая зона уже является глобальной

-' > 0 - глобальной зоны найденной глобальной зоны в списке

-

-Function GetAliasDescrIdx(Dst As Range, AreaCount As Integer, Optional StartIndex As Integer = 1) As Integer

-    Dim s As String

-    Dim idx As Integer

-    

-    s = Dst

-    idx = StartIndex

-    

-    GetAliasDescrIdx = -1

-    

-    With Dst.Worksheet

-        Do

-            idx = FindVIndex(Dst.EntireColumn, AreaCount, s, idx)

-            If idx > 0 Then

-                If idx <> Dst.Row Then

-                    GetAliasDescrIdx = idx

-                    Exit Do

-                Else

-                    idx = idx + 1

-                End If

-            End If

-        Loop While (idx <> -1)

-    End With

-End Function

-

-' Возвращает index глобального имени зоны из сортированного списка имен зон

-' Пример для зоны Russia, Moscow глобальной будет являться зона с именем Russia

-' Результаты функции:

-' -1 исследуемая зона уже является глобальной

-' > 0 - глобальной зоны найденной глобальной зоны в списке

-

-Function GetGlobalDescrIdx(Dst As Range, AreaCount As Integer, Optional StartIndex As Integer = 1) As Integer

-    Dim iStrPos As Integer

-    Dim s As String

-    Dim idx As Integer

-    

-    s = Dst

-    idx = StartIndex

-    iStrPos = Len(s)

-    

-    GetGlobalDescrIdx = -1

-    

-    With Dst.Worksheet

-        Do

-            idx = FindVIndex(Dst.EntireColumn, AreaCount, s, idx)

-            If idx > 0 Then

-                If idx <> Dst.Row Then

-                    GetGlobalDescrIdx = idx

-                    Exit Do

-                Else

-                    idx = idx + 1

-                End If

-            Else

-                iStrPos = InStrRev(s, " ") - 1

-                If iStrPos = -1 Then

-                    iStrPos = InStrRev(s, ",") - 1

-                End If

-                If iStrPos <> -1 Then

-                    idx = 1

-                    s = Left(s, iStrPos)

-                End If

-            End If

-        Loop While (idx <> -1 And iStrPos <> 0)

-    End With

-End Function

-

-' Возвращает index глобальной зоны из сортированного списка зон

-' Пример для зоны s709643 глобальной будут являться зоны s7096 и s7

-

-' Результаты функции:

-' -1 исследуемая зона является глобальной

-' > 0 - индекс в списке глобальной зоны

-

-Function FindGlobalAreaIdx(Dst As Range, AreaCount As Integer) As Integer

-    Dim iStrPos As Integer

-    Dim s As String

-    Dim idx As Integer

-    

-    FindGlobalAreaIdx = -1

-    

-    s = Dst

-    If s = "" Then

-        Exit Function

-    End If

-    

-    idx = 1

-    iStrPos = Len(s) - 1

-    

-    With Dst.Worksheet

-        s = Left(s, iStrPos)

-        Do

-            idx = FindVIndex(Dst.EntireColumn, AreaCount, s, idx)

-            If idx > 0 Then

-                If idx <> Dst.Row Then

-                    FindGlobalAreaIdx = idx

-                    Exit Do

-                Else

-                    idx = idx + 1

-                End If

-            Else

-                iStrPos = iStrPos - 1

-                If iStrPos > 1 Then

-                    s = Left(s, iStrPos)

-                    idx = 1

-                End If

-            End If

-        Loop While (idx <> -1 And iStrPos <> 0)

-    End With

-End Function

-

-' Возвращает index глобальной зоны из сортированного списка зон

-' Пример для зоны 709643 глобальной будут являться зоны 7096 и 7

-

-' Результаты функции:

-' -1 исследуемая зона является глобальной

-' > 0 - индекс в списке глобальной зоны

-

-Function GetGlobalAreaIdx(wks_name As String, range_name As String, AreaCount As Integer, scDst) As Integer

-    Dim i As Integer

-    Dim s As String

-    Dim Answer As Integer

-    

-    GetGlobalAreaIdx = -1

-    

-    With ThisWorkbook.Worksheets(wks_name)

-        For i = Len(scDst) To 2 Step -1

-            s = Left(scDst, i)

-            Answer = FindVIndex(.Range(range_name), AreaCount, s)

-            If Answer > 0 Then

-                GetGlobalAreaIdx = Answer

-                Exit Function

-            End If

-        Next i

-    End With

-End Function

-

-Function FindVIndex(Src As Range, AreaCount As Integer, s As String, Optional Start As Integer = 1) As Integer

-    Dim l As Long

-    FindVIndex = -1

-    For l = Start To AreaCount

-        If s = Src.Cells(l, 1) Then

-            FindVIndex = l

-            Exit Function

-        End If

-    Next l

-End Function

-

-Sub MarkDublicates(Src As Range)

-    Dim Dst As Range

-    Set Dst = Src.Offset(1, 0)

-    While Dst <> ""

-        If Dst = Src Then

-            With Dst.EntireRow

-                .Font.Bold = True

-                .Font.ColorIndex = 3

-            End With

-            Set Dst = Dst.Offset(1, 0)

-        Else

-            Set Src = Dst

-            Set Dst = Src.Offset(1, 0)

-        End If

-    Wend

-End Sub

-

-Function RC2ADDR(RowIdx As Integer, ColIdx As Integer) As String

-    Dim s As String

-    Dim Chars As String

-    Dim idx As Integer

-    idx = ColIdx

-    Chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-    While idx > 1

-        s = Mid(Chars, idx Mod Len(Chars), 1) & s

-        idx = idx \ Len(Chars)

-    Wend

-    RC2ADDR = s & RowIdx

-End Function

-<<<<<<
-======================
-mbConstatnts
->>>>>>
-Attribute VB_Name = "mbConstatnts"

-Option Explicit

-

-Public Const UNKNOWN_AREA As String = "UNKNOWN_"

-Public Const NONAME_AREA As String = "*"

-

-Public Const WKS_AREAS_NAME As String = "GlobalList"

-Public Const WKS_PRICE_NAME As String = "OpPrices"

-Public Const WKS_COMPACT_NAME As String = "CompactPrices"

-Public Const WKS_TRAFFIC_NAME As String = "OpTraffic"

-Public Const WKS_FIX_AREAS_NAME As String = "GLFixed"

-Public Const WKS_HOME_NAME As String = "Home"

-

-Public Const Ofs_InPriceList As Integer = 2

-Public Const Ofs_ChkParent As Integer = 3

-Public Const Ofs_ChkChild As Integer = 4

-Public Const Ofs_ChkAlias As Integer = 5

-

-

-Public Const WKS_A3 As String = "A3"

-Public Const idx_sCode As Integer = 0

-Public Const idx_Code As Integer = 1

-Public Const idx_eDescr As Integer = 2

-Public Const idx_rDescr As Integer = 3

-Public Const idx_Price As Integer = 4

-Public Const idx_Traffic As Integer = 5

-Public Const idx_Calls As Integer = 6

-Public Const idx_Status As Integer = 7

-Public Const idx_Price2 As Integer = 8

-

-Public Const idx_DatTraffic As Integer = 2

-Public Const idx_DatCalls As Integer = 3

-

-Public Const idx_GLStatus As Integer = 4 ' колонка статуса зоны в листе WKS_AREAS_NAME

-

-Public Const idx_GLZType As Integer = 5 ' колонка типа зоны в листе WKS_FIX_AREAS_NAME

-Public Const GLZType_Mobile As String = "M" ' маркер мобильных зон в листе WKS_FIX_AREAS_NAME

-Public Const GLZType_Static As String = "D" ' маркер обычных зон в листе WKS_FIX_AREAS_NAME

-

-Public Const ADD_CODE_ONLY As Integer = 0

-Public Const ADD_CODE_PRICE As Integer = 1

-Public Const ADD_CODE_TRAFFIC As Integer = 2

-

-<<<<<<
-======================
-Sheet22
->>>>>>
-Attribute VB_Name = "Sheet22"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet24
->>>>>>
-Attribute VB_Name = "Sheet24"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet25
->>>>>>
-Attribute VB_Name = "Sheet25"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet28
->>>>>>
-Attribute VB_Name = "Sheet28"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet29
->>>>>>
-Attribute VB_Name = "Sheet29"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mCompact
->>>>>>
-Attribute VB_Name = "mCompact"

-Option Explicit

-

-' для работы этой процедуры необходимо установить правильно значения констант

-Private Const SHEET_NAME As String = "CompactPrices"

-Private Const START_CELL_ADDR As String = "W3"

-Private Const DST_CELL_ADDR As String = "B3"

-

-Sub zzz_CopactCodes()

-    Dim Src As Range

-    Dim Dst As Range

-    Dim r As Range

-    Dim AreaCount As Integer

-    Dim GlobalIdx As Integer

-    

-    

-    Set Src = ThisWorkbook.Worksheets(SHEET_NAME).Range(START_CELL_ADDR)

-    Set Dst = ThisWorkbook.Worksheets(SHEET_NAME).Range(DST_CELL_ADDR)

-    

-    While Dst <> ""

-        If Src <> "" Then

-            Dst = ""

-            Set r = Src

-            While r <> ""

-                If Dst = "" Then

-                    Dst = r

-                Else

-                    Dst = Dst & ";" & r

-                End If

-                Set r = r.Offset(0, 1)

-            Wend

-        End If

-        Set Dst = Dst.Offset(1, 0)

-        Set Src = Src.Offset(1, 0)

-    Wend

-    Dst.EntireColumn.AutoFit

-End Sub

-

-<<<<<<
-======================
-Sheet31
->>>>>>
-Attribute VB_Name = "Sheet31"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-zTest
->>>>>>
-Attribute VB_Name = "zTest"

-Sub z_CheckGLFixed()

-    Dim r As Range

-    Set r = ThisWorkbook.Worksheets(WKS_FIX_AREAS_NAME).Range(WKS_A3)

-    

-    MarkDublicates r

-End Sub

-

-Sub z_SetZoneType()

-    Dim r As Range

-    Set r = ThisWorkbook.Worksheets(WKS_FIX_AREAS_NAME).Range(WKS_A3)

-    While r <> ""

-        If InStr(r.Offset(0, idx_eDescr), "Cell") > 0 Then

-            r.Offset(0, idx_GLZType) = GLZType_Mobile

-        Else

-            r.Offset(0, idx_GLZType) = GLZType_Static

-        End If

-        Set r = r.Offset(1, 0)

-    Wend

-    With r.EntireColumn

-        .HorizontalAlignment = xlCenter

-        .AutoFit

-    End With

-    

-End Sub

-

-<<<<<<
-======================
-Sheet30
->>>>>>
-Attribute VB_Name = "Sheet30"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Option Explicit

-

-Type PriceRecord

-    Aria As String

-    Description As String

-    Description2 As String

-    Price As Double

-End Type

-

-Dim SourcePrData() As PriceRecord

-

-Sub a()

-    ReDim SourcePrData(1 To 5)

-    Erase SourcePrData

-End Sub

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-ForecastPrice
->>>>>>
-Attribute VB_Name = "ForecastPrice"

-Option Explicit

-

-Sub Step_4_ForecastBlankCodes()

-    Dim ListsRange As Range

-    Dim i As Integer

-    Dim AreaCount As Integer

-    

-    With ThisWorkbook

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        

-        Dim s As String

-        Dim r As Range

-        

-        AreaCount = 0

-        Set r = .Worksheets(WKS_PRICE_NAME).Range(WKS_A3)

-        AreaCount = GetLinesCount(r)

-

-        For i = 1 To ListsRange.Count

-            Set r = .Worksheets(WKS_PRICE_NAME).Range(WKS_A3).Offset(0, idx_PriceIN + i - 1)

-            DoForecast r, AreaCount

-        Next i

-    End With

-    MsgBox "Step_4_ForecastBlankCodes is done!"

-End Sub

-

-

-Sub DoForecast(Src As Range, AreaCount As Integer)

-    Dim i As Integer

-    Dim Dst As Range

-    Dim scDst As String

-    Dim scDstDscr As String

-    

-    Static PriceAvailable As Boolean

-    

-    With ThisWorkbook

-        Set Dst = Src.Offset(1, 0)

-    

-        For i = 1 To AreaCount - 1

-            PriceAvailable = Application.WorksheetFunction.IsNumber(Dst)

-            

-            If PriceAvailable = True Then

-                Set Src = Dst

-                Set Dst = Src.Offset(1, 0)

-            Else

-                Dim Idx As Integer

-                

-

-'==========================================================================

-                Dim iStrPos As Integer

-                Dim s As String

-                

-                s = Dst.Worksheet.Range("C:C").Cells(Dst.Row, 1)

-                iStrPos = Len(s)

-                With Dst.Worksheet

-                    Idx = 1

-                    

-                    Do

-                        Idx = FindVIndex(Dst.Worksheet.Range("C:C"), AreaCount, s, Idx)

-                        If Idx > 0 Then

-                            If Application.WorksheetFunction.IsNumber(.Cells(Idx, Dst.Column)) Then

-                                Exit Do

-                            Else

-                                Idx = Idx + 1

-                            End If

-                        Else

-                            iStrPos = InStrRev(s, " ") - 1

-                            If iStrPos = -1 Then

-                                iStrPos = InStrRev(s, ",") - 1

-                            End If

-                            If iStrPos <> -1 Then

-                                Idx = 1

-                                s = Left(s, iStrPos)

-                            End If

-                        End If

-                    Loop While (Idx <> -1 And iStrPos <> 0)

-                End With

-'==========================================================================

-                

-                If Idx = -1 Then

-                    scDst = .Worksheets(WKS_PRICE_NAME).Range("A:A").Cells(Dst.Row, 1)

-                    Idx = GetGlobalAreaIdx(WKS_PRICE_NAME, "A:A", AreaCount, Left(scDst, Len(scDst) - 1))

-                    If Idx > 0 Then

-                        If Application.WorksheetFunction.IsNumber(.Worksheets(WKS_PRICE_NAME).Cells(Idx, Dst.Column)) = False Then

-                            Idx = -1

-                        End If

-                    End If

-                End If

-                

-                If Idx <> -1 Then

-                    Set Src = .Worksheets(WKS_PRICE_NAME).Cells(Idx, Src.Column)

-                    

-                    Dst = Src

-                    Dst.Font.Bold = False

-                    Dst.Font.ColorIndex = 29 ' magenta

-                    Set Dst = Dst.Offset(1, 0)

-                Else

-'                    Dst = "*"

-'                    Dst.Font.ColorIndex = xlColorIndexAutomatic

-'                    Dst.Font.Bold = True

-                    Set Dst = Dst.Offset(1, 0)

-                End If

-            End If

-        Next i

-    End With

-End Sub

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet19
->>>>>>
-Attribute VB_Name = "Sheet19"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-mAnalisys
->>>>>>
-Attribute VB_Name = "mAnalisys"

-Option Explicit

-

-Public Const idx_PriceIN As Integer = 4

-

-

-Sub AnalyzeOpPricesData(wks_name As String, DATA_fmt As String)

-

-' Формируем список зон на рабочем листе

-' Удаляем предыдущий расчет

-    ClearWorkArea (wks_name)

-    

-    ThisWorkbook.Worksheets(wks_name).Activate

-    ThisWorkbook.Worksheets(wks_name).Cells.Select

-    With Selection

-        .ClearContents

-        .Interior.ColorIndex = xlNone

-        .Font.Bold = False

-        .Font.ColorIndex = 0

-        .HorizontalAlignment = xlGeneral

-        .VerticalAlignment = xlBottom

-        .WrapText = False

-        .Orientation = 0

-        .AddIndent = False

-        .ShrinkToFit = False

-        .MergeCells = False

-    End With

-    ThisWorkbook.Worksheets(wks_name).Range("A1").Select

-' Форматируем заголовок рабочего листа

-

-    Dim SrcRange As Range

-    Dim DstRange As Range

-    Dim ListsRange As Range

-    Dim i As Integer

-    Dim j As Integer

-

-    With ThisWorkbook

-        .Application.ScreenUpdating = False

-        

-        Set DstRange = .Worksheets(wks_name).Range(WKS_A3)

-        Set SrcRange = .Worksheets(WKS_AREAS_NAME).Range(WKS_A3)

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-

-

-        With DstRange

-            .Offset(-2, idx_sCode) = "Common"

-            .Offset(-1, idx_sCode) = "sCode"

-            .Offset(-1, idx_Code) = "Code"

-            .Offset(-1, idx_eDescr) = "Descr_E"

-            .Offset(-1, idx_rDescr) = "Descr_R"

-            .Offset(-2, idx_PriceIN) = "Price (In)"

-            For i = 1 To ListsRange.Count

-                .Offset(-1, i + idx_PriceIN - 1) = ListsRange(i, 1)

-            Next i

-            .Offset(-2, idx_PriceIN + ListsRange.Count) = "Stat of Price (IN)"

-            .Offset(-1, idx_PriceIN + ListsRange.Count) = "Count"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 1) = "Min"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 1) = "Min"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 2) = "Max"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 3) = "Avg"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 4) = "Down"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 5) = "Up"

-            .Offset(-2, idx_PriceIN + ListsRange.Count + 6) = "Operators"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 6) = "Price"

-            .Offset(-2, idx_PriceIN + ListsRange.Count + 7) = "Profit[x100%]"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 7) = "Avg"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 8) = "Min"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 9) = "Max"

-            .Offset(-2, idx_PriceIN + ListsRange.Count + 10) = "Op Profit[x100%] (Routing type 1)"

-            j = idx_PriceIN + ListsRange.Count + 10

-            For i = 1 To ListsRange.Count

-                .Offset(-1, i + j - 1) = ListsRange(i, 1)

-            Next i

-            With .Offset(-2, 0).EntireRow

-                .HorizontalAlignment = xlLeft

-                .Font.Bold = True

-            End With

-            With .Offset(-1, 0).EntireRow

-                .HorizontalAlignment = xlCenter

-                .Font.Bold = True

-            End With

-            

-        End With

-

-' Копируем созданный список на рабочий лист

-

-        

-        CopyAreasList DstRange, SrcRange

-        

-        Set DstRange = .Worksheets(wks_name).Range(WKS_A3)

-    End With

-

-' Подсчитываем общее количество зон

-

-    Dim AreaCount As Integer

-    AreaCount = GetLinesCount(DstRange)

-

-

-' Форматируем полученный результат

-        

-    For i = 1 To 4

-        Set DstRange = ThisWorkbook.Worksheets(wks_name) _

-                    .Range(Cells(2, i), Cells(2 + AreaCount, i))

-        With DstRange

-            .EntireColumn.AutoFit

-            If i Mod 2 = 1 Then

-                .Interior.ColorIndex = 36 ' LightYellow

-            Else

-                .Interior.ColorIndex = xlNone  'White

-            End If

-        End With

-    Next i

-

-' Перебираем цены/данные всех операторов и формируем общий список цен по зонам

-' Копируем цены операторов для зон

-

-    With ThisWorkbook

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        

-        Dim s As String

-    

-        For i = 1 To ListsRange.Count

-            Set DstRange = .Worksheets(wks_name).Range(WKS_A3)

-            s = ListsRange.Cells(i, 1).Value

-            If wks_name = WKS_TRAFFIC_NAME Then

-                s = s & ".Data"

-            End If

-            

-            If SheetExist(s) Then

-                Set SrcRange = .Worksheets(s).Range(WKS_A3)

-    

-                AddOpPriceData DstRange, SrcRange, i - 1

-                

-            End If

-            

-' Форматируем полученный результат

-            With .Worksheets(wks_name)

-                Set DstRange = .Range(.Cells(2, idx_Price + i), .Cells(2 + AreaCount, idx_Price + i))

-            End With

-            With DstRange

-                .NumberFormat = DATA_fmt

-                .Font.Bold = True

-                .HorizontalAlignment = xlCenter

-                .VerticalAlignment = xlBottom

-                .WrapText = False

-                .Orientation = 0

-                .AddIndent = False

-                .ShrinkToFit = False

-                .MergeCells = False

-                If i Mod 2 = 1 Then

-                    .Interior.ColorIndex = 36 ' LightYellow

-                Else

-                    .Interior.ColorIndex = xlNone  'White

-                End If

-            End With

-        Next i

-        With Worksheets(wks_name)

-            Set DstRange = .Range(.Cells(2, idx_Price + 1), .Cells(2 + AreaCount, idx_Price + ListsRange.Count))

-        End With

-        

-'        DstRange.Select

-        

-        For Each SrcRange In DstRange

-            If SrcRange = "" Then

-                SrcRange = "-"

-            End If

-        Next SrcRange

-        

-        Set SrcRange = .Worksheets(wks_name).Range(WKS_A3)

-    End With

-    

-' Рассчитываем статистику по ценам

-    Set DstRange = ThisWorkbook.Worksheets(wks_name).Range(WKS_A3).Offset(0, idx_PriceIN + ListsRange.Count)

-    DstRange.Select

-    

-    Dim Stat1stCol As Integer

-    Dim StatMinCol As Integer

-    Dim StatMaxCol As Integer

-    Dim StatAvgCol As Integer

-    Dim StatDnCol As Integer

-    Dim StatUpCol As Integer

-    

-    Dim offsetMinCol As Integer

-    Dim offsetMaxCol As Integer

-    Dim offsetAvgCol As Integer

-    Dim offsetUpCol As Integer

-    Dim offsetDnCol As Integer

-    Dim offsetPriceCol As Integer

-    Dim offsetAvgPtCol As Integer

-    Dim offsetMinPtCol As Integer

-    Dim offsetMaxPtCol As Integer

-    

-    

-    Stat1stCol = idx_PriceIN + ListsRange.Count + 1

-    

-    offsetMinCol = 1

-    offsetMaxCol = 2

-    offsetAvgCol = 3

-    offsetUpCol = 4

-    offsetDnCol = 5

-    offsetPriceCol = 6

-    offsetAvgPtCol = 7

-    offsetMinPtCol = 8

-    offsetMaxPtCol = 9

-    

-    StatMinCol = Stat1stCol + offsetMinCol

-    StatMaxCol = Stat1stCol + offsetMaxCol

-    StatAvgCol = Stat1stCol + offsetAvgCol

-    StatUpCol = Stat1stCol + offsetUpCol

-    StatDnCol = Stat1stCol + offsetDnCol

-    

-    For i = 0 To AreaCount - 1

-        s = RC2ADDR(i + 3, idx_PriceIN + 1) & ":" & RC2ADDR(i + 3, idx_PriceIN + ListsRange.Count)

-        DstRange.Offset(i, 0).Formula = "=count(" & s & ")"

-        

-        Dim AnchorCell As String

-        AnchorCell = RC2ADDR(i + 3, Stat1stCol)

-        

-        DstRange.Offset(i, offsetMinCol).Formula = "=if(" & AnchorCell & ">0, min(" & s & "), ""-"")"

-        DstRange.Offset(i, offsetMaxCol).Formula = "=if(" & AnchorCell & ">0, max(" & s & "), ""-"")"

-        DstRange.Offset(i, offsetAvgCol).Formula = "=if(" & AnchorCell & ">0, average(" & s & "), ""-"")"

-        s = "=if(" & AnchorCell & ">0, (" & RC2ADDR(i + 3, StatAvgCol) & "-" & RC2ADDR(i + 3, StatMaxCol) & ")/" & RC2ADDR(i + 3, StatAvgCol) & ", ""-"")"

-        With DstRange.Offset(i, offsetDnCol)

-            .Formula = s

-            .NumberFormat = "0.00%_);[Red](0.00)%"

-        End With

-        s = "=if(" & AnchorCell & ">0, (" & RC2ADDR(i + 3, StatAvgCol) & "-" & RC2ADDR(i + 3, StatMinCol) & ")/" & RC2ADDR(i + 3, StatAvgCol) & ", ""-"")"

-        With DstRange.Offset(i, offsetUpCol)

-            .Formula = s

-            .NumberFormat = "0.00%"

-        End With

-

-' Расчет отпускной цены по формуле.

-        s = "=if(" & AnchorCell & ">0, if(" & RC2ADDR(i + 3, StatAvgCol) & "<=Trigger, " & RC2ADDR(i + 3, StatAvgCol) & "+FixedV," & RC2ADDR(i + 3, StatAvgCol) & "* FIxedP), ""-"")"

-        With DstRange.Offset(i, offsetPriceCol)

-            .Formula = s

-            .NumberFormat = "0.000"

-        End With

-

-' Расчет Прибыли и Убытков.

-        s = "=if(" & AnchorCell & ">0, (" & RC2ADDR(i + 3, Stat1stCol + offsetPriceCol) & "-" & RC2ADDR(i + 3, StatAvgCol) & ")/" & RC2ADDR(i + 3, StatAvgCol) & ", ""-"")"

-        With DstRange.Offset(i, offsetAvgPtCol)

-            .Formula = s

-            .NumberFormat = "0.00%_);[Red](0.00)%"

-        End With

-

-        s = "=if(" & AnchorCell & ">0, (" & RC2ADDR(i + 3, Stat1stCol + offsetPriceCol) & "-" & RC2ADDR(i + 3, StatMaxCol) & ")/" & RC2ADDR(i + 3, StatMaxCol) & ", ""-"")"

-        With DstRange.Offset(i, offsetMinPtCol)

-            .Formula = s

-            .NumberFormat = "0.00%_);[Red](0.00)%"

-        End With

-

-        s = "=if(" & AnchorCell & ">0, (" & RC2ADDR(i + 3, Stat1stCol + offsetPriceCol) & "-" & RC2ADDR(i + 3, StatMinCol) & ")/" & RC2ADDR(i + 3, StatMinCol) & ", ""-"")"

-        With DstRange.Offset(i, offsetMaxPtCol)

-            .Formula = s

-            .NumberFormat = "0.00%_);[Red](0.00%)"

-        End With

-

-' Расчет Прибыли и Убытков по операторам (Routing type 1)

-        

-'        Set ListsRange = ThisWorkbook.Worksheets(WKS_HOME_NAME).Range("OpList")

-

-        For j = 1 To ListsRange.Count

-            AnchorCell = RC2ADDR(i + 3, idx_PriceIN + j)

-            s = "=if(isnumber(" & AnchorCell & "), (" & RC2ADDR(i + 3, Stat1stCol + offsetPriceCol) & "-" & AnchorCell & ")/" & AnchorCell & ", ""-"")"

-            With DstRange.Offset(i, offsetMaxPtCol + j)

-                .Formula = s

-                .NumberFormat = "0.00%_);[Red](0.00)%"

-            End With

-        Next j

-    Next i

-

-

-' Форматируем полученный результат

-' Статистика

-    For i = 0 To 5

-        With ThisWorkbook.Worksheets(wks_name)

-            Set DstRange = .Range(.Cells(2, Stat1stCol + i), .Cells(2 + AreaCount, Stat1stCol + i))

-        End With

-        With DstRange

-            If i > 0 And i <= 3 Then

-                .NumberFormat = DATA_fmt

-            End If

-            .HorizontalAlignment = xlCenter

-            .VerticalAlignment = xlBottom

-            .WrapText = False

-            .Orientation = 0

-            .AddIndent = False

-            .ShrinkToFit = False

-            .MergeCells = False

-            If i Mod 2 = 0 Then

-                .Interior.ColorIndex = 35 ' LightLightGreen

-            Else

-                .Interior.ColorIndex = 34  ' LightLightBlue

-            End If

-        End With

-    Next i

-

-' Формат колонки "Operators price"

-

-    With ThisWorkbook.Worksheets(wks_name)

-        Set DstRange = .Range(.Cells(2, Stat1stCol + offsetPriceCol), .Cells(2 + AreaCount, Stat1stCol + offsetPriceCol))

-        With DstRange

-            .Interior.ColorIndex = 36 ' LightYellow

-            .Font.ColorIndex = 10

-            .Font.Bold = True

-            .NumberFormat = "0.0000"

-            .HorizontalAlignment = xlCenter

-            .VerticalAlignment = xlBottom

-        End With

-    End With

-

-' Формат Прибыли и Убытков по операторам (Routing type 1)

-    For j = 1 To ListsRange.Count

-        With ThisWorkbook.Worksheets(wks_name)

-            Set DstRange = .Range(.Cells(2, Stat1stCol + offsetMaxPtCol + j), .Cells(2 + AreaCount, Stat1stCol + offsetMaxPtCol + j))

-        End With

-        With DstRange

-            .HorizontalAlignment = xlCenter

-            .VerticalAlignment = xlBottom

-            .WrapText = False

-            .Orientation = 0

-            .AddIndent = False

-            .ShrinkToFit = False

-            .MergeCells = False

-            If j Mod 2 = 0 Then

-                .Interior.ColorIndex = 34  ' LightLightBlue

-            Else

-                .Interior.ColorIndex = 35 ' LightLightGreen

-            End If

-        End With

-    Next j

-    Application.ScreenUpdating = True

-End Sub

-

-Sub CopyAreasList(Dst As Range, Src As Range)

-    While Src <> ""

-        Dst.Offset(0, idx_sCode).Value = Src.Offset(0, idx_sCode).Value

-        Dst.Offset(0, idx_Code).Value = Src.Offset(0, idx_Code).Value

-        Dst.Offset(0, idx_eDescr).Value = Src.Offset(0, idx_eDescr).Value

-        Dst.Offset(0, idx_rDescr).Value = Src.Offset(0, idx_rDescr).Value

-        Set Src = Src.Offset(1, 0)

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-End Sub

-

-

-Sub AddOpPriceData(Dst As Range, Src As Range, index As Integer)

-    While Src <> ""

-'        If Dst < Src Then

-'            Dst.Offset(0, idx_Price + index) = "-"

-'        End If

-        If Dst = Src Then

-            Dst.Offset(0, idx_Price + index) = Src.Offset(0, idx_Price)

-            Set Src = Src.Offset(1, 0)

-        End If

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-'    While Dst <> ""

-'        Dst.Offset(0, idx_Price + index) = "-"

-'        Set Dst = Dst.Offset(1, 0)

-'    Wend

-End Sub

-

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet27
->>>>>>
-Attribute VB_Name = "Sheet27"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet23
->>>>>>
-Attribute VB_Name = "Sheet23"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-GlobalList
->>>>>>
-Attribute VB_Name = "GlobalList"

-Option Explicit

-

-

-

-Sub Step_2_CreateGlobalCodeList()

-

-' Перебираем названия всех операторов и формируем общий список зон

-' Удаляем предыдущий расчет

-    ClearWorkArea (WKS_AREAS_NAME)

-    

-' Формируем общий список зон

-

-    

-    BuildAreasList (WKS_AREAS_NAME)

-    

-    BuildAreasStatus (WKS_AREAS_NAME)

-

-    

-End Sub

-

-Sub Step_1_BuildWorkPriceLists()

-

-    Dim SrcRange As Range

-    Dim DstRange As Range

-    Dim ListsRange As Range

-    

-    

-    With ThisWorkbook

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        

-        Dim s As String

-        Dim i As Integer

-    

-' Перебираем названия всех операторов и формируем общий список зон

-        With .Application

-            .Calculation = xlCalculationManual

-            .ScreenUpdating = False

-        End With

-

-        For i = 1 To ListsRange.Count

-            s = ListsRange.Cells(i, 1).Value

-            

-            CreateComSheet (s)

-            

-            Set DstRange = .Worksheets(s).Range(WKS_A3)

-            Set SrcRange = .Worksheets(s & ".Tarif").Range(WKS_A3)

-            

-            MarkDublicates SrcRange

-            

-            Set SrcRange = .Worksheets(s & ".Tarif").Range(WKS_A3)

-            AddOpArea DstRange, SrcRange, ADD_CODE_PRICE

-            

-            Set DstRange = .Worksheets(s).Range(WKS_A3)

-            

-            If SheetExist(s & ".Data") Then

-                Set SrcRange = .Worksheets(s & ".Data").Range(WKS_A3)

-                AddOpArea DstRange, SrcRange, ADD_CODE_TRAFFIC

-            End If

-            

-' Присваиваем зонам статус:

-' 00 - не известная, не используется

-' 01 - не известная, используется

-' 10 - известная, не используется

-' 11 - известная, используется

-            

-            Set DstRange = .Worksheets(s).Range(WKS_A3)

-            While DstRange <> ""

-                If DstRange.Offset(0, idx_Price) = 0 Or DstRange.Offset(0, idx_Price) = "-" Then

-                    If DstRange.Offset(0, idx_Traffic) = 0 Then

-                        DstRange.Offset(0, idx_Status) = 0

-                    Else

-                        DstRange.Offset(0, idx_Status) = 1

-                    End If

-                Else

-                    If DstRange.Offset(0, idx_Traffic) = 0 Then

-                        DstRange.Offset(0, idx_Status) = 10

-                    Else

-                        DstRange.Offset(0, idx_Status) = 11

-                    End If

-                End If

-                Set DstRange = DstRange.Offset(1, 0)

-            Wend

-                

-            With .Worksheets(s)

-                With .Columns("A:H")

-                    .HorizontalAlignment = xlHAlignGeneral

-                    .VerticalAlignment = xlBottom

-                    .WrapText = False

-                    .Orientation = 0

-                    .AddIndent = False

-                    .ShrinkToFit = True

-                    .MergeCells = False

-                End With

-                .Columns("A:A").HorizontalAlignment = xlLeft

-                .Columns("B:B").NumberFormat = "#"

-                With .Rows("2:2")

-                    .Font.Bold = False

-                    .WrapText = False

-                    .HorizontalAlignment = xlCenter

-                End With

-                With .Columns("G:G")

-                    .HorizontalAlignment = xlHAlignCenter

-                    .NumberFormat = "0#"

-                End With

-            End With

-            MarkDublicates (.Worksheets(s).Range(WKS_A3))

-        Next i

-        With .Application

-            .Calculation = xlCalculationAutomatic

-            .ScreenUpdating = True

-            .Calculate

-        End With

-        

-    End With

-

-End Sub

-

-Sub BuildAreasList(DstName As String)

-

-    Dim SrcRange As Range

-    Dim DstRange As Range

-    Dim ListsRange As Range

-    

-    With ThisWorkbook

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        

-        Dim s As String

-        Dim i As Integer

-    

-        With .Application

-            .Calculation = xlCalculationManual

-            .ScreenUpdating = False

-        End With

-' Перебираем названия всех операторов и формируем общий список зон

-

-        For i = 1 To ListsRange.Count

-            s = ListsRange.Cells(i, 1).Value

-            

-            If SheetExist(s) Then

-                Set DstRange = .Worksheets(WKS_AREAS_NAME).Range(WKS_A3)

-                Set SrcRange = .Worksheets(s).Range(WKS_A3)

-        

-                AddGlobalOpArea DstRange, SrcRange

-            End If

-        Next i

-        Set SrcRange = .Worksheets(DstName).Range(WKS_A3)

-        .Worksheets(DstName).Select

-                

-        MarkDublicates (.Worksheets(DstName).Range(WKS_A3))

-        

-        With .Application

-            .Calculation = xlCalculationAutomatic

-            .ScreenUpdating = True

-            .Calculate

-        End With

-    End With

-End Sub

-

-Sub AddGlobalOpArea(Dst As Range, Src As Range)

-    While Src <> ""

-        If Dst > Src Then

-            Dst.Worksheet.Range(Dst, Dst.Offset(0, 50)).Insert Shift:=xlShiftDown

-            Set Dst = Dst.Offset(-1, 0)

-        End If

-        If Dst = "" Then

-            Dst.Offset(0, idx_sCode) = Src.Offset(0, idx_sCode)

-            Dst.Offset(0, idx_Code) = Src.Offset(0, idx_Code)

-        End If

-        If Dst = Src Then

-            CheckNameOpArea Dst, Src, ADD_CODE_ONLY

-            Set Src = Src.Offset(1, 0)

-        End If

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-    

-    Dst.Worksheet.Columns("A:H").AutoFit

-    

-    Set Dst = Dst.Worksheet.Range(WKS_A3)

-    

-End Sub

-

-Sub CheckNameOpArea(Dst As Range, Src As Range, ByVal add_type As Integer)

-    

-    Dim Exist_SrcEng As Boolean

-    Dim Exist_SrcRus As Boolean

-    Dim Exist_DstEng As Boolean

-    Dim Exist_DstRus As Boolean

-    

-    Dim Unknown_Src As Boolean

-    Dim Unknown_Dst As Boolean

-    

-    With Dst

-        Exist_DstEng = .Offset(0, idx_eDescr) <> "" And .Offset(0, idx_eDescr) <> UNKNOWN_AREA And .Offset(0, idx_eDescr) <> NONAME_AREA

-        Exist_DstRus = .Offset(0, idx_rDescr) <> "" And .Offset(0, idx_rDescr) <> UNKNOWN_AREA And .Offset(0, idx_rDescr) <> NONAME_AREA

-    End With

-    

-    Unknown_Dst = Not (Exist_DstEng Or Exist_DstRus)

-    

-    If add_type = ADD_CODE_TRAFFIC Then

-        If Unknown_Dst Then

-            Dst.Offset(0, idx_eDescr) = UNKNOWN_AREA & Dst.Offset(0, idx_Code)

-            Dst.Offset(0, idx_rDescr) = UNKNOWN_AREA & Dst.Offset(0, idx_Code)

-        End If

-        Exit Sub

-    End If

-    

-    With Src

-        Exist_SrcEng = .Offset(0, idx_eDescr) <> "" And .Offset(0, idx_eDescr) <> UNKNOWN_AREA And .Offset(0, idx_eDescr) <> NONAME_AREA

-        Exist_SrcRus = .Offset(0, idx_rDescr) <> "" And .Offset(0, idx_rDescr) <> UNKNOWN_AREA And .Offset(0, idx_rDescr) <> NONAME_AREA

-    End With

-    

-    Unknown_Src = Not (Exist_SrcEng Or Exist_SrcRus)

-    

-    If Unknown_Src And Unknown_Dst Then

-        Dst.Offset(0, idx_eDescr) = UNKNOWN_AREA

-        Dst.Offset(0, idx_rDescr) = UNKNOWN_AREA

-        Exit Sub

-    End If

-    

-    If Unknown_Src Then

-        If Not Exist_DstRus Then

-            Dst.Offset(0, idx_rDescr) = NONAME_AREA

-        End If

-        If Not Exist_DstEng Then

-            Dst.Offset(0, idx_eDescr) = NONAME_AREA

-        End If

-    Else

-        If Not Exist_DstEng Then

-            If Exist_SrcEng Then

-                Dst.Offset(0, idx_eDescr) = Src.Offset(0, idx_eDescr)

-            Else

-                Dst.Offset(0, idx_eDescr) = NONAME_AREA

-            End If

-        End If

-        If Not Exist_DstRus Then

-            If Exist_SrcRus Then

-                Dst.Offset(0, idx_rDescr) = Src.Offset(0, idx_rDescr)

-            Else

-                Dst.Offset(0, idx_rDescr) = NONAME_AREA

-            End If

-        End If

-    End If

-End Sub

-

-Sub AddOpArea(Dst As Range, Src As Range, Optional add_type = ADD_CODE_ONLY)

-    

-    While Src <> ""

-        If Dst > Src Then

-            Dst.Worksheet.Range(Dst, Dst.Offset(0, 50)).Insert Shift:=xlShiftDown

-            Set Dst = Dst.Offset(-1, 0)

-        End If

-        If Dst = "" Then

-            Dst.Offset(0, idx_sCode) = Src.Offset(0, idx_sCode)

-            Dst.Offset(0, idx_Code) = Src.Offset(0, idx_Code)

-        End If

-        If Dst = Src Then

-            Select Case add_type

-                Case ADD_CODE_PRICE

-                    Dst.Offset(0, idx_Price) = Src.Offset(0, idx_Price)

-                    If Dst.Offset(0, idx_Price) = "" Then

-                        Dst.Offset(0, idx_Price) = "-"

-                    End If

-                Case ADD_CODE_TRAFFIC

-                    Dst.Offset(0, idx_Traffic) = Src.Offset(0, idx_DatTraffic)

-            End Select

-            

-            CheckNameOpArea Dst, Src, add_type

-                        

-            Set Src = Src.Offset(1, 0)

-        End If

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-    

-    Select Case add_type

-        Case ADD_CODE_PRICE

-            Dst.Worksheet.Columns("E:E").NumberFormat = "0.0000"

-        Case ADD_CODE_TRAFFIC

-            Dst.Worksheet.Columns("F:F").NumberFormat = "0.00"

-    End Select

-    

-    Dst.Worksheet.Columns("A:H").AutoFit

-    

-    Set Dst = Dst.Worksheet.Range("A1")

-End Sub

-

-Sub BuildAreasStatus(wks_name As String)

-    Dim rSrc As Range

-    Dim rDst As Range

-    Dim ListsRange As Range

-    Dim i As Integer

-    Dim j As Integer

-    Dim s As String

-    Dim WS_Name As String

-    

-    With ThisWorkbook

-        .Application.ScreenUpdating = False

-        

-        

-' Вычисляем размер списка

-

-        Dim AreaCount As Integer

-

-        Set rDst = .Worksheets(wks_name).Range(WKS_A3)

-        

-        AreaCount = GetLinesCount(rDst) + 3

-

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        Set rDst = .Worksheets(wks_name).Range(WKS_A3)

-        j = 3

-        

-        For i = 1 To ListsRange.Count

-            rDst.Offset(-1, i + idx_GLStatus).Formula = ListsRange(i, 1)

-        Next i

-        

-' Вычисляем статусы зон для списка операторов

-        While rDst <> ""

-            For i = 1 To ListsRange.Count

-                WS_Name = ListsRange(i, 1)

-                If SheetExist(WS_Name) Then

-                    s = "INDEX(" & WS_Name & "!G1:$G$" & AreaCount & ", MATCH($A" & j & "," & WS_Name & "!$A$1:$A$" & AreaCount & ",0), 1)"

-                    s = "=if(iserror(" & s & "), ""-""," & s & ")"

-                Else

-                    s = "-"

-                End If

-                rDst.Offset(0, i + idx_GLStatus).Formula = s

-                rDst.Offset(0, i + idx_GLStatus).NumberFormat = "0#"

-            Next i

-            j = j + 1

-            Set rDst = rDst.Offset(1, 0)

-        Wend

-        

-' Форматируем результат

-        For i = 0 To ListsRange.Count

-            With rDst.Offset(-1, i + idx_GLStatus).EntireColumn

-                .HorizontalAlignment = xlCenter

-                .ShrinkToFit = True

-            End With

-        Next i

-

-' Корректируем названия зон

-

-        With .Worksheets(wks_name)

-            Set rDst = .Range(.Cells(3, 1), .Cells(AreaCount, 1))

-        End With

-

-        Set rSrc = .Worksheets(WKS_FIX_AREAS_NAME).Range(WKS_A3)

-        

-        AreaCount = GetLinesCount(rSrc) + 3

-

-        With .Worksheets(WKS_FIX_AREAS_NAME)

-            Set rSrc = .Range(.Cells(2, 1), .Cells(AreaCount, 1))

-        End With

-

-        Dim b As Range

-        Dim c As Range

-        For Each c In rDst

-            Set b = rSrc.Find(c, LookIn:=xlValues, MatchByte:=True)

-            If Not b Is Nothing Then

-                If c.Offset(0, idx_eDescr) <> b.Offset(0, idx_eDescr) Or c.Offset(0, idx_rDescr) <> b.Offset(0, idx_rDescr) Then

-                    c.Offset(0, idx_eDescr) = b.Offset(0, idx_eDescr)

-                    c.Offset(0, idx_rDescr) = b.Offset(0, idx_rDescr)

-                    c.Offset(0, idx_GLStatus) = "Fixed"

-                    With c.EntireRow

-                        .Font.Bold = True

-                        .Font.ColorIndex = xlColorIndexAutomatic

-                    End With

-                Else

-                    c.Offset(0, idx_GLStatus) = "-"

-                End If

-            Else

-                If c.Offset(0, idx_sCode) <> "" Then

-                    Dim FixedList As Range

-                    c.Offset(0, idx_GLStatus) = "New"

-                    With c.EntireRow

-                        .Font.Bold = True

-                        .Font.ColorIndex = 3 ' Red

-                    End With

-                End If

-                

-'                Set Fixed

-            End If

-        Next c

-        

-        Application.ScreenUpdating = True

-        

-    End With

-End Sub

-<<<<<<
-======================
-Tools
->>>>>>
-Attribute VB_Name = "Tools"

-Option Explicit

-

-Sub ClearWorkArea(DstName As String)

-    Dim DstRange As Range

-    With ThisWorkbook

-       

-        Set DstRange = .Worksheets(DstName).Range(WKS_A3)

-        Worksheets(DstName).Select

-        DstRange.Select

-        Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select

-        Range(Selection, Selection.End(xlDown)).Select

-        Selection.Delete Shift:=xlUp

-        Selection.Font.Bold = False

-        Selection.Font.ColorIndex = xlColorIndexAutomatic

-        Set DstRange = .Worksheets(DstName).Range(WKS_A3)

-        DstRange.Select

-    End With

-End Sub

-

-Function SheetExist(SheetName As String) As Boolean

-    Dim Count, i As Integer

-

-    Count = ThisWorkbook.Sheets.Count

-    SheetExist = False

-    For i = 1 To Count

-        If ThisWorkbook.Sheets(i).Name = SheetName Then

-            SheetExist = True

-            i = Count

-        End If

-    Next i

-End Function

-

-Function GetLinesCount(r As Range) As Integer

-

-    Dim LinesCount As Integer

-    LinesCount = 0

-

-    While r <> ""

-        LinesCount = LinesCount + 1

-        Set r = r.Offset(1, 0)

-    Wend

-    

-    GetLinesCount = LinesCount

-End Function

-

-Sub CreateComSheet(wks_name As String)

-    Dim theRange As Range

-    With ThisWorkbook

-        If Not SheetExist(wks_name) Then

-            .Sheets.Add.Name = wks_name

-        End If

-            

-        .Sheets(wks_name).Visible = True

-        .Sheets(wks_name).Select

-        Cells.Select

-        Selection.ClearContents

-        Selection.Interior.ColorIndex = xlNone

-        Selection.Borders(xlLeft).LineStyle = xlNone

-        Selection.Borders(xlRight).LineStyle = xlNone

-        Selection.Borders(xlTop).LineStyle = xlNone

-        Selection.Borders(xlBottom).LineStyle = xlNone

-        Selection.BorderAround LineStyle:=xlNone

-        Selection.Font.ColorIndex = 0

-        Selection.EntireColumn.ColumnWidth = ActiveSheet.StandardWidth

-    

-        With .Worksheets(wks_name)

-            .Range("a1") = wks_name

-            With .Range("a2")

-                .Offset(0, idx_sCode) = "sCode"

-                .Offset(0, idx_Code) = "Code"

-                .Offset(0, idx_eDescr) = "Descr_E"

-                .Offset(0, idx_rDescr) = "Descr_R"

-                .Offset(0, idx_Price) = "Price"

-                .Offset(0, idx_Traffic) = "Traffic"

-                .Offset(0, idx_Status) = "Status"

-                .Offset(0, idx_Price2) = "Price2"

-            End With

-            With .Rows("2:2")

-                .Font.Bold = False

-                .WrapText = False

-                .HorizontalAlignment = xlCenter

-            End With

-            .Range("A1").Select

-        End With

-    End With

-End Sub

-

-Function GetGlobalAreaIdx(wks_name As String, range_name As String, AreaCount As Integer, scDst) As Integer

-    Dim i As Integer

-    Dim s As String

-    Dim Answer As Integer

-    

-    GetGlobalAreaIdx = -1

-    

-    With ThisWorkbook.Worksheets(wks_name)

-        For i = Len(scDst) To 2 Step -1

-            s = Left(scDst, i)

-            Answer = FindVIndex(.Range(range_name), AreaCount, s)

-            If Answer > 0 Then

-                GetGlobalAreaIdx = Answer

-                Exit Function

-            End If

-        Next i

-    End With

-End Function

-

-Function FindVIndex(Src As Range, AreaCount As Integer, s As String, Optional Start As Integer = 1) As Integer

-    Dim l As Long

-    FindVIndex = -1

-    For l = Start To AreaCount

-        If s = Src.Cells(l, 1) Then

-            FindVIndex = l

-            Exit Function

-        End If

-    Next l

-End Function

-

-Sub MarkDublicates(Src As Range)

-    Dim Dst As Range

-    Set Dst = Src.Offset(1, 0)

-    While Dst <> ""

-        If Dst = Src Then

-            With Dst.EntireRow

-                .Font.Bold = True

-                .Font.ColorIndex = 3

-            End With

-            Set Dst = Dst.Offset(1, 0)

-        Else

-            Set Src = Dst

-            Set Dst = Src.Offset(1, 0)

-        End If

-    Wend

-End Sub

-

-Function RC2ADDR(RowIdx As Integer, ColIdx As Integer) As String

-    Dim s As String

-    Dim Chars As String

-    Dim Idx As Integer

-    Idx = ColIdx

-    Chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-    While Idx > 1

-        s = Mid(Chars, Idx Mod Len(Chars), 1) & s

-        Idx = Idx \ Len(Chars)

-    Wend

-    RC2ADDR = s & RowIdx

-End Function

-<<<<<<
-======================
-Constatnts
->>>>>>
-Attribute VB_Name = "Constatnts"

-Option Explicit

-

-Public Const UNKNOWN_AREA As String = "UNKNOWN_"

-Public Const NONAME_AREA As String = "*"

-

-Public Const WKS_AREAS_NAME As String = "GlobalList"

-Public Const WKS_PRICE_NAME As String = "OpPrices"

-Public Const WKS_COMPACT_NAME As String = "CompactPrices"

-Public Const WKS_TRAFFIC_NAME As String = "OpTraffic"

-Public Const WKS_FIX_AREAS_NAME As String = "GLFixed"

-Public Const WKS_HOME_NAME As String = "Home"

-

-Public Const WKS_A3 As String = "A3"

-Public Const idx_sCode As Integer = 0

-Public Const idx_Code As Integer = 1

-Public Const idx_eDescr As Integer = 2

-Public Const idx_rDescr As Integer = 3

-Public Const idx_Price As Integer = 4

-Public Const idx_Traffic As Integer = 5

-Public Const idx_Status As Integer = 6

-Public Const idx_Price2 As Integer = 7

-

-Public Const idx_DatTraffic As Integer = 2

-Public Const idx_GLStatus As Integer = 4

-

-Public Const ADD_CODE_ONLY As Integer = 0

-Public Const ADD_CODE_PRICE As Integer = 1

-Public Const ADD_CODE_TRAFFIC As Integer = 2

-

-

-

-

-Sub Step_3_Recalc_1st_Prices()

-    AnalyzeOpPricesData WKS_PRICE_NAME, "0.0000"

-End Sub

-

-Sub Step_5_Compact_1st_Prices()

-    CompactOpPricesData WKS_COMPACT_NAME

-End Sub

-

-Sub AnalyzeData()

-'    AnalyzeOpPricesData WKS_TRAFFIC_NAME, "0."

-    MsgBox "This code not debuged"

-End Sub

-

-<<<<<<
-======================
-Sheet22
->>>>>>
-Attribute VB_Name = "Sheet22"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet24
->>>>>>
-Attribute VB_Name = "Sheet24"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet25
->>>>>>
-Attribute VB_Name = "Sheet25"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet28
->>>>>>
-Attribute VB_Name = "Sheet28"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet29
->>>>>>
-Attribute VB_Name = "Sheet29"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mCompact
->>>>>>
-Attribute VB_Name = "mCompact"

-Option Explicit

-

-Sub CompactOpPricesData(wks_name As String)

-

-' Формируем список зон на рабочем листе

-' Удаляем предыдущий расчет

-    ClearWorkArea (wks_name)

-    

-    ThisWorkbook.Worksheets(wks_name).Activate

-    ThisWorkbook.Worksheets(wks_name).Cells.Select

-    With Selection

-        .ClearContents

-        .Interior.ColorIndex = xlNone

-        .Font.Bold = False

-        .Font.ColorIndex = 0

-        .HorizontalAlignment = xlGeneral

-        .VerticalAlignment = xlBottom

-        .WrapText = False

-        .Orientation = 0

-        .AddIndent = False

-        .ShrinkToFit = False

-        .MergeCells = False

-    End With

-    ThisWorkbook.Worksheets(wks_name).Range("A1").Select

-' Форматируем заголовок рабочего листа

-

-    Dim SrcRange As Range

-    Dim DstRange As Range

-    Dim ListsRange As Range

-    Dim i As Integer

-    Dim j As Integer

-

-    With ThisWorkbook

-        .Application.ScreenUpdating = False

-        

-        Set DstRange = .Worksheets(wks_name).Range(WKS_A3)

-        Set SrcRange = .Worksheets(WKS_PRICE_NAME).Range(WKS_A3)

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-

-

-        With DstRange

-            .Offset(-2, idx_sCode) = "Compact"

-            .Offset(-1, idx_sCode) = "sCode"

-            .Offset(-1, idx_Code) = "Code"

-            .Offset(-1, idx_eDescr) = "Descr_E"

-            .Offset(-1, idx_rDescr) = "Descr_R"

-            .Offset(-2, idx_PriceIN) = "Price (In)"

-            For i = 1 To ListsRange.Count

-                .Offset(-1, i + idx_PriceIN - 1) = ListsRange(i, 1)

-            Next i

-            .Offset(-2, idx_PriceIN + ListsRange.Count) = "Stat of Price (IN)"

-            .Offset(-1, idx_PriceIN + ListsRange.Count) = "Count"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 1) = "Min"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 1) = "Min"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 2) = "Max"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 3) = "Avg"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 4) = "Down"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 5) = "Up"

-            .Offset(-2, idx_PriceIN + ListsRange.Count + 6) = "Operators"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 6) = "Price"

-            .Offset(-2, idx_PriceIN + ListsRange.Count + 7) = "Profit[x100%]"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 7) = "Avg"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 8) = "Min"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 9) = "Max"

-            .Offset(-2, idx_PriceIN + ListsRange.Count + 10) = "Op Profit[x100%] (Routing type 1)"

-            j = idx_PriceIN + ListsRange.Count + 10

-            For i = 1 To ListsRange.Count

-                .Offset(-1, i + j - 1) = ListsRange(i, 1)

-            Next i

-            With .Offset(-2, 0).EntireRow

-                .HorizontalAlignment = xlLeft

-                .Font.Bold = True

-            End With

-            With .Offset(-1, 0).EntireRow

-                .HorizontalAlignment = xlCenter

-                .Font.Bold = True

-            End With

-            

-        End With

-

-' Копируем созданный список на рабочий лист

-

-        

-        CopyCompactAreasList DstRange, SrcRange

-        

-        

-        For i = 0 To ListsRange.Count - 1

-            Set DstRange = .Worksheets(wks_name).Range(WKS_A3)

-            Set SrcRange = .Worksheets(WKS_PRICE_NAME).Range(WKS_A3)

-            AddCompactOpPriceData DstRange, SrcRange, i

-        Next i

-        

-        Set DstRange = .Worksheets(wks_name).Range(WKS_A3)

-    End With

-End Sub

-

-Sub CopyCompactAreasList(Dst As Range, Src As Range)

-    Dim s As String

-    Dim Idx As Integer

-    Dim AreaCount As Integer

-    Dim r As Range

-    

-    Set r = Src

-    

-    AreaCount = GetLinesCount(r)

-    

-    While Src <> ""

-        s = Src.Offset(0, idx_eDescr).Value

-        Idx = FindVIndex(Dst.Worksheet.Range("C:C"), AreaCount, s, 1)

-        If Idx = -1 Then

-            Dst.Offset(0, idx_sCode).Value = "-"

-            Dst.Offset(0, idx_Code).Value = "-"

-            Dst.Offset(0, idx_eDescr).Value = Src.Offset(0, idx_eDescr).Value

-            Dst.Offset(0, idx_rDescr).Value = Src.Offset(0, idx_rDescr).Value

-            Set Dst = Dst.Offset(1, 0)

-        End If

-        Set Src = Src.Offset(1, 0)

-    Wend

-End Sub

-

-Sub AddCompactOpPriceData(Dst As Range, Src As Range, index As Integer)

-    Dim Idx As Integer

-    Dim Val As Variant

-    Dim scSrc As Range

-        

-Set scSrc = Src

-    

-    While Dst.Offset(0, idx_eDescr) <> ""

-        Do While scSrc <> ""

-            If Dst.Offset(0, idx_eDescr) = scSrc.Offset(0, idx_eDescr) Then

-                Val = scSrc.Offset(0, idx_Price + index)

-                If Application.WorksheetFunction.IsNumber(Val) Then

-                    Dst.Offset(0, idx_Price + index) = Val

-                    Exit Do

-                Else

-                    Set scSrc = scSrc.Offset(1, 0)

-                End If

-            Else

-                Set scSrc = scSrc.Offset(1, 0)

-            End If

-        Loop

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-End Sub

-

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Option Explicit

-

-Type PriceRecord

-    Aria As String

-    Description As String

-    Description2 As String

-    Price As Double

-End Type

-

-Dim SourcePrData() As PriceRecord

-

-Sub a()

-    ReDim SourcePrData(1 To 5)

-    Erase SourcePrData

-End Sub

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet37
->>>>>>
-Attribute VB_Name = "Sheet37"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-mAnalisys
->>>>>>
-Attribute VB_Name = "mAnalisys"

-Option Explicit

-

-Public Const idx_PriceIN As Integer = 4

-

-

-Sub AnalyzeOpPricesData(wks_name As String, DATA_fmt As String)

-

-' Формируем список зон на рабочем листе

-' Удаляем предыдущий расчет

-    ClearWorkArea (wks_name)

-

-' Форматируем заголовок рабочего листа

-

-    Dim SrcRange As Range

-    Dim DstRange As Range

-    Dim ListsRange As Range

-    Dim i As Integer

-    Dim j As Integer

-

-    With ThisWorkbook

-        .Application.ScreenUpdating = False

-        

-        Set DstRange = .Worksheets(wks_name).Range(WKS_A3)

-        Set SrcRange = .Worksheets(WKS_AREAS_NAME).Range(WKS_A3)

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-

-

-        With DstRange

-            .Offset(-2, idx_sCode) = "Common"

-            .Offset(-1, idx_sCode) = "sCode"

-            .Offset(-1, idx_Code) = "Code"

-            .Offset(-1, idx_eDescr) = "Descr_E"

-            .Offset(-1, idx_rDescr) = "Descr_R"

-            .Offset(-2, idx_PriceIN) = "Price (In)"

-            For i = 1 To ListsRange.Count

-                .Offset(-1, i + idx_PriceIN - 1) = ListsRange(i, 1)

-            Next i

-            .Offset(-2, idx_PriceIN + ListsRange.Count) = "Stat of Price (IN)"

-            .Offset(-1, idx_PriceIN + ListsRange.Count) = "Count"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 1) = "Min"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 1) = "Min"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 2) = "Max"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 3) = "Avg"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 4) = "Down"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 5) = "Up"

-            .Offset(-2, idx_PriceIN + ListsRange.Count + 6) = "Operators"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 6) = "Price"

-            .Offset(-2, idx_PriceIN + ListsRange.Count + 7) = "Profit[x100%]"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 7) = "Avg"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 8) = "Min"

-            .Offset(-1, idx_PriceIN + ListsRange.Count + 9) = "Max"

-            .Offset(-2, idx_PriceIN + ListsRange.Count + 10) = "Op Profit[x100%] (Ruting type 1)"

-            j = idx_PriceIN + ListsRange.Count + 10

-            For i = 1 To ListsRange.Count

-                .Offset(-1, i + j - 1) = ListsRange(i, 1)

-            Next i

-            With .Offset(-2, 0).EntireRow

-                .HorizontalAlignment = xlLeft

-                .Font.Bold = True

-            End With

-            With .Offset(-1, 0).EntireRow

-                .HorizontalAlignment = xlCenter

-                .Font.Bold = True

-            End With

-            

-        End With

-

-' Копируем созданный список на рабочий лист

-

-        

-        CopyAreasList DstRange, SrcRange

-        

-        Set DstRange = .Worksheets(wks_name).Range(WKS_A3)

-    End With

-

-' Подсчитываем общее количество зон

-

-    Dim AreaCount As Integer

-    AreaCount = GetLinesCount(DstRange)

-

-

-' Форматируем полученный результат

-        

-    For i = 1 To 4

-        Set DstRange = ThisWorkbook.Worksheets(wks_name) _

-                    .Range(Cells(2, i), Cells(2 + AreaCount, i))

-        With DstRange

-            .EntireColumn.AutoFit

-            If i Mod 2 = 1 Then

-                .Interior.ColorIndex = 36 ' LightYellow

-            Else

-                .Interior.ColorIndex = xlNone  'White

-            End If

-        End With

-    Next i

-

-' Перебираем цены/данные всех операторов и формируем общий список цен рл зонам

-' Копируем цены операторов для зон

-

-    With ThisWorkbook

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        

-        Dim s As String

-    

-        For i = 1 To ListsRange.Count

-            Set DstRange = .Worksheets(wks_name).Range(WKS_A3)

-            s = ListsRange.Cells(i, 1).Value

-            If wks_name = WKS_TRAFFIC_NAME Then

-                s = s & ".Data"

-            End If

-            

-            If SheetExist(s) Then

-                Set SrcRange = .Worksheets(s).Range(WKS_A3)

-    

-                AddOpPriceData DstRange, SrcRange, i - 1

-                

-            End If

-            

-' Форматируем полученный результат

-            With .Worksheets(wks_name)

-                Set DstRange = .Range(.Cells(2, idx_Price + i), .Cells(2 + AreaCount, idx_Price + i))

-            End With

-            With DstRange

-                .NumberFormat = DATA_fmt

-                .Font.Bold = True

-                .HorizontalAlignment = xlCenter

-                .VerticalAlignment = xlBottom

-                .WrapText = False

-                .Orientation = 0

-                .AddIndent = False

-                .ShrinkToFit = False

-                .MergeCells = False

-                If i Mod 2 = 1 Then

-                    .Interior.ColorIndex = 36 ' LightYellow

-                Else

-                    .Interior.ColorIndex = xlNone  'White

-                End If

-            End With

-        Next i

-        With Worksheets(wks_name)

-            Set DstRange = .Range(.Cells(2, idx_Price + 1), .Cells(2 + AreaCount, idx_Price + ListsRange.Count))

-        End With

-        

-'        DstRange.Select

-        

-        For Each SrcRange In DstRange

-            If SrcRange = "" Then

-                SrcRange = "-"

-            End If

-        Next SrcRange

-        

-        Set SrcRange = .Worksheets(wks_name).Range(WKS_A3)

-    End With

-    

-'' Рассчитываем статистику по ценам

-'    Set DstRange = ThisWorkbook.Worksheets(wks_name).Range(WKS_A3).Offset(0, idx_PriceIN + ListsRange.Count)

-'    DstRange.Select

-'

-'    DstRange.Column

-'

-'    For i = 0 To AreaCount - 1

-'        s = "(E" & i + 3 & ":K" & i + 3 & ")"

-'        DstRange.Offset(i, 0).Formula = "=count" + s

-'        DstRange.Offset(i, 1).Formula = "=if(L" & i + 3 & ">0, min" & s & ", ""-"")"

-'        DstRange.Offset(i, 2).Formula = "=if(L" & i + 3 & ">0, max" & s & ", ""-"")"

-'        DstRange.Offset(i, 3).Formula = "=if(L" & i + 3 & ">0, average" & s & ", ""-"")"

-'        s = "=if(L" & (i + 3) & ">0, (O" & (i + 3) & "-M" & (i + 3) & ")/O" & (i + 3) & ", ""-"")"

-'        With DstRange.Offset(i, 4)

-'            .Formula = s

-'            .NumberFormat = "0.00%"

-'        End With

-'        s = "=if(L" & i + 3 & ">0, (N" & (i + 3) & "-O" & (i + 3) & ")/O" & (i + 3) & ", ""-"")"

-'        With DstRange.Offset(i, 5)

-'            .Formula = s

-'            .NumberFormat = "0.00%"

-'        End With

-'

-'' Расчет отпускной цены по формуле.

-'        s = "=if(L" & i + 3 & ">0, if(O" & (i + 3) & "<=Trigger, O" & (i + 3) & "+FixedV, O" & (i + 3) & "* FIxedP), ""-"")"

-'        With DstRange.Offset(i, 6)

-'            .Formula = s

-'        End With

-'

-'' Расчет Прибыли и Убытков.

-'        s = "=if(isnumber(R" & i + 3 & "), (R" & (i + 3) & "- O" & (i + 3) & ")/ O" & (i + 3) & ", ""-"")"

-'        With DstRange.Offset(i, 7)

-'            .Formula = s

-'            .NumberFormat = "0.00%_);[Red](0.00%)"

-'        End With

-'

-'        s = "=if(isnumber(R" & i + 3 & "), (R" & (i + 3) & "- N" & (i + 3) & ")/ N" & (i + 3) & ", ""-"")"

-'        With DstRange.Offset(i, 8)

-'            .Formula = s

-'            .NumberFormat = "0.00%_);[Red](0.00%)"

-'        End With

-'

-'        s = "=if(isnumber(R" & i + 3 & "), (R" & (i + 3) & "- M" & (i + 3) & ")/ M" & (i + 3) & ", ""-"")"

-'        With DstRange.Offset(i, 9)

-'            .Formula = s

-'            .NumberFormat = "0.00%_);[Red](0.00%)"

-'        End With

-'

-'' Расчет Прибыли и Убытков по операторам

-'

-'    Next i

-'

-'

-'' Форматируем полученный результат

-'' Статистика

-'    For i = 0 To 5

-'        With ThisWorkbook.Worksheets(wks_name)

-'            Set DstRange = .Range(.Cells(2, idx_Price + ListsRange.Count + 1 + i), .Cells(2 + AreaCount, idx_Price + ListsRange.Count + 1 + i))

-'        End With

-'        With DstRange

-'            If i <> 0 Then

-'                .NumberFormat = DATA_fmt

-'            End If

-'            .HorizontalAlignment = xlCenter

-'            .VerticalAlignment = xlBottom

-'            .WrapText = False

-'            .Orientation = 0

-'            .AddIndent = False

-'            .ShrinkToFit = False

-'            .MergeCells = False

-'            If i Mod 2 = 0 Then

-'                .Interior.ColorIndex = 35 ' LightLightGreen

-'            Else

-'                .Interior.ColorIndex = 34  ' LightLightBlue

-'            End If

-'            .Application.ScreenUpdating = True

-'

-'        End With

-'    Next i

-'

-'' Формат колонки "Operators price"

-'

-'    With ThisWorkbook.Worksheets(wks_name)

-'        Set DstRange = .Range(.Cells(2, idx_Price + ListsRange.Count + 7), .Cells(2 + AreaCount, idx_Price + ListsRange.Count + 7))

-'        DstRange.Interior.ColorIndex = 36 ' LightYellow

-'        DstRange.Font.ColorIndex = 10

-'        DstRange.Font.Bold = True

-'        DstRange.NumberFormat = "0.0000"

-'    End With

-'

-'' Прибыли/убытки

-'    For i = 0 To 2

-'        With ThisWorkbook.Worksheets(wks_name)

-'            Set DstRange = .Range(.Cells(2, idx_Price + ListsRange.Count + 8 + i), .Cells(2 + AreaCount, idx_Price + ListsRange.Count + 8 + i))

-'        End With

-'        With DstRange

-'            .HorizontalAlignment = xlCenter

-'            .VerticalAlignment = xlBottom

-'            .WrapText = False

-'            .Orientation = 0

-'            .AddIndent = False

-'            .ShrinkToFit = False

-'            .MergeCells = False

-'            If i Mod 2 = 0 Then

-'                .Interior.ColorIndex = 34  ' LightLightBlue

-'            Else

-'                .Interior.ColorIndex = 35 ' LightLightGreen

-'            End If

-'            .Application.ScreenUpdating = True

-'

-'        End With

-'    Next i

-End Sub

-

-Sub CopyAreasList(Dst As Range, Src As Range)

-    While Src <> ""

-        Dst.Offset(0, idx_sCode).Value = Src.Offset(0, idx_sCode).Value

-        Dst.Offset(0, idx_Code).Value = Src.Offset(0, idx_Code).Value

-        Dst.Offset(0, idx_eDescr).Value = Src.Offset(0, idx_eDescr).Value

-        Dst.Offset(0, idx_rDescr).Value = Src.Offset(0, idx_rDescr).Value

-        Set Src = Src.Offset(1, 0)

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-End Sub

-

-

-Sub AddOpPriceData(Dst As Range, Src As Range, index As Integer)

-    While Src <> ""

-'        If Dst < Src Then

-'            Dst.Offset(0, idx_Price + index) = "-"

-'        End If

-        If Dst = Src Then

-            Dst.Offset(0, idx_Price + index) = Src.Offset(0, idx_Price)

-            Set Src = Src.Offset(1, 0)

-        End If

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-'    While Dst <> ""

-'        Dst.Offset(0, idx_Price + index) = "-"

-'        Set Dst = Dst.Offset(1, 0)

-'    Wend

-End Sub

-

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet23
->>>>>>
-Attribute VB_Name = "Sheet23"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet36
->>>>>>
-Attribute VB_Name = "Sheet36"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-GlobalList
->>>>>>
-Attribute VB_Name = "GlobalList"

-Option Explicit

-

-

-

-Sub CreateGlobalCodeList()

-

-' Перебираем названия всех операторов и формируем общий список зон

-' Удаляем предыдущий расчет

-    ClearWorkArea (WKS_AREAS_NAME)

-    

-' Формируем общий список зон

-

-    BuildAreasList (WKS_AREAS_NAME)

-    

-    BuildAreasStatus (WKS_AREAS_NAME)

-

-End Sub

-

-Sub BuildWorkPriceLists()

-

-    Dim SrcRange As Range

-    Dim DstRange As Range

-    Dim ListsRange As Range

-    

-    

-    With ThisWorkbook

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        

-        Dim s As String

-        Dim i As Integer

-    

-' Перебираем названия всех операторов и формируем общий список зон

-        With .Application

-            .Calculation = xlCalculationManual

-            .ScreenUpdating = False

-        End With

-

-

-        For i = 1 To ListsRange.Count

-            s = ListsRange.Cells(i, 1).Value

-            

-            CreateComSheet (s)

-            

-            Set DstRange = .Worksheets(s).Range(WKS_A3)

-            Set SrcRange = .Worksheets(s & ".Tarif").Range(WKS_A3)

-            

-            MarkDublicates SrcRange

-            

-            Set SrcRange = .Worksheets(s & ".Tarif").Range(WKS_A3)

-            AddOpArea DstRange, SrcRange, ADD_CODE_PRICE

-            

-            Set DstRange = .Worksheets(s).Range(WKS_A3)

-            

-            If SheetExist(s & ".Data") Then

-                Set SrcRange = .Worksheets(s & ".Data").Range(WKS_A3)

-                AddOpArea DstRange, SrcRange, ADD_CODE_TRAFFIC

-            End If

-            

-' Присваиваем зонам статус:

-' 00 - не известная, не используется

-' 01 - не известная, используется

-' 10 - известная, не используется

-' 11 - известная, используется

-            

-            Set DstRange = .Worksheets(s).Range(WKS_A3)

-            While DstRange <> ""

-                If DstRange.Offset(0, idx_Price) = 0 Or DstRange.Offset(0, idx_Price) = "-" Then

-                    If DstRange.Offset(0, idx_Traffic) = 0 Then

-                        DstRange.Offset(0, idx_Status) = 0

-                    Else

-                        DstRange.Offset(0, idx_Status) = 1

-                    End If

-                Else

-                    If DstRange.Offset(0, idx_Traffic) = 0 Then

-                        DstRange.Offset(0, idx_Status) = 10

-                    Else

-                        DstRange.Offset(0, idx_Status) = 11

-                    End If

-                End If

-                Set DstRange = DstRange.Offset(1, 0)

-            Wend

-                

-            With .Worksheets(s)

-                With .Columns("A:H")

-                    .HorizontalAlignment = xlHAlignGeneral

-                    .VerticalAlignment = xlBottom

-                    .WrapText = False

-                    .Orientation = 0

-                    .AddIndent = False

-                    .ShrinkToFit = True

-                    .MergeCells = False

-                End With

-                .Columns("A:A").HorizontalAlignment = xlLeft

-                .Columns("B:B").NumberFormat = "#"

-                With .Rows("2:2")

-                    .Font.Bold = False

-                    .WrapText = False

-                    .HorizontalAlignment = xlCenter

-                End With

-                With .Columns("G:G")

-                    .HorizontalAlignment = xlHAlignCenter

-                    .NumberFormat = "0#"

-                End With

-            End With

-            MarkDublicates (.Worksheets(s).Range(WKS_A3))

-        Next i

-        With .Application

-            .Calculation = xlCalculationAutomatic

-            .ScreenUpdating = True

-            .Calculate

-        End With

-    End With

-

-End Sub

-

-Sub BuildAreasList(DstName As String)

-

-    Dim SrcRange As Range

-    Dim DstRange As Range

-    Dim ListsRange As Range

-    

-    With ThisWorkbook

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        

-        Dim s As String

-        Dim i As Integer

-    

-        With .Application

-            .Calculation = xlCalculationManual

-            .ScreenUpdating = False

-        End With

-' Перебираем названия всех операторов и формируем общий список зон

-

-        For i = 1 To ListsRange.Count

-            s = ListsRange.Cells(i, 1).Value

-            

-            Set DstRange = .Worksheets(WKS_AREAS_NAME).Range(WKS_A3)

-            Set SrcRange = .Worksheets(s).Range(WKS_A3)

-        

-            AddGlobalOpArea DstRange, SrcRange

-        Next i

-        Set SrcRange = .Worksheets(DstName).Range(WKS_A3)

-        .Worksheets(DstName).Select

-                

-        MarkDublicates (.Worksheets(DstName).Range(WKS_A3))

-        

-        With .Application

-            .Calculation = xlCalculationAutomatic

-            .ScreenUpdating = True

-            .Calculate

-        End With

-    End With

-End Sub

-

-Sub AddGlobalOpArea(Dst As Range, Src As Range)

-    While Src <> ""

-        If Dst > Src Then

-            Dst.Worksheet.Range(Dst, Dst.Offset(0, 50)).Insert Shift:=xlShiftDown

-            Set Dst = Dst.Offset(-1, 0)

-        End If

-        If Dst = "" Then

-            Dst.Offset(0, idx_sCode) = Src.Offset(0, idx_sCode)

-            Dst.Offset(0, idx_Code) = Src.Offset(0, idx_Code)

-        End If

-        If Dst = Src Then

-            CheckNameOpArea Dst, Src, ADD_CODE_ONLY

-            Set Src = Src.Offset(1, 0)

-        End If

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-    

-    Dst.Worksheet.Columns("A:H").AutoFit

-    

-    Set Dst = Dst.Worksheet.Range(WKS_A3)

-    

-End Sub

-

-Sub CheckNameOpArea(Dst As Range, Src As Range, ByVal add_type As Integer)

-    

-    Dim Exist_SrcEng As Boolean

-    Dim Exist_SrcRus As Boolean

-    Dim Exist_DstEng As Boolean

-    Dim Exist_DstRus As Boolean

-    

-    Dim Unknown_Src As Boolean

-    Dim Unknown_Dst As Boolean

-    

-    With Dst

-        Exist_DstEng = .Offset(0, idx_eDescr) <> "" And .Offset(0, idx_eDescr) <> UNKNOWN_AREA And .Offset(0, idx_eDescr) <> NONAME_AREA

-        Exist_DstRus = .Offset(0, idx_rDescr) <> "" And .Offset(0, idx_rDescr) <> UNKNOWN_AREA And .Offset(0, idx_rDescr) <> NONAME_AREA

-    End With

-    

-    Unknown_Dst = Not (Exist_DstEng Or Exist_DstRus)

-    

-    If add_type = ADD_CODE_TRAFFIC Then

-        If Unknown_Dst Then

-            Dst.Offset(0, idx_eDescr) = UNKNOWN_AREA

-            Dst.Offset(0, idx_rDescr) = UNKNOWN_AREA

-        End If

-        Exit Sub

-    End If

-    

-    With Src

-        Exist_SrcEng = .Offset(0, idx_eDescr) <> "" And .Offset(0, idx_eDescr) <> UNKNOWN_AREA And .Offset(0, idx_eDescr) <> NONAME_AREA

-        Exist_SrcRus = .Offset(0, idx_rDescr) <> "" And .Offset(0, idx_rDescr) <> UNKNOWN_AREA And .Offset(0, idx_rDescr) <> NONAME_AREA

-    End With

-    

-    Unknown_Src = Not (Exist_SrcEng Or Exist_SrcRus)

-    

-    If Unknown_Src And Unknown_Dst Then

-        Dst.Offset(0, idx_eDescr) = UNKNOWN_AREA

-        Dst.Offset(0, idx_rDescr) = UNKNOWN_AREA

-        Exit Sub

-    End If

-    

-    If Unknown_Src Then

-        If Not Exist_DstRus Then

-            Dst.Offset(0, idx_rDescr) = NONAME_AREA

-        End If

-        If Not Exist_DstEng Then

-            Dst.Offset(0, idx_eDescr) = NONAME_AREA

-        End If

-    Else

-        If Not Exist_DstEng Then

-            If Exist_SrcEng Then

-                Dst.Offset(0, idx_eDescr) = Src.Offset(0, idx_eDescr)

-            Else

-                Dst.Offset(0, idx_eDescr) = NONAME_AREA

-            End If

-        End If

-        If Not Exist_DstRus Then

-            If Exist_SrcRus Then

-                Dst.Offset(0, idx_rDescr) = Src.Offset(0, idx_rDescr)

-            Else

-                Dst.Offset(0, idx_rDescr) = NONAME_AREA

-            End If

-        End If

-    End If

-End Sub

-

-Sub AddOpArea(Dst As Range, Src As Range, Optional add_type = ADD_CODE_ONLY)

-    

-    While Src <> ""

-        If Dst > Src Then

-            Dst.Worksheet.Range(Dst, Dst.Offset(0, 50)).Insert Shift:=xlShiftDown

-            Set Dst = Dst.Offset(-1, 0)

-        End If

-        If Dst = "" Then

-            Dst.Offset(0, idx_sCode) = Src.Offset(0, idx_sCode)

-            Dst.Offset(0, idx_Code) = Src.Offset(0, idx_Code)

-        End If

-        If Dst = Src Then

-            Select Case add_type

-                Case ADD_CODE_PRICE

-                    Dst.Offset(0, idx_Price) = Src.Offset(0, idx_Price)

-                    If Dst.Offset(0, idx_Price) = "" Then

-                        Dst.Offset(0, idx_Price) = "-"

-                    End If

-                Case ADD_CODE_TRAFFIC

-                    Dst.Offset(0, idx_Traffic) = Src.Offset(0, idx_DatTraffic)

-            End Select

-            

-            CheckNameOpArea Dst, Src, add_type

-                        

-            Set Src = Src.Offset(1, 0)

-        End If

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-    

-    Select Case add_type

-        Case ADD_CODE_PRICE

-            Dst.Worksheet.Columns("E:E").NumberFormat = "0.0000"

-        Case ADD_CODE_TRAFFIC

-            Dst.Worksheet.Columns("F:F").NumberFormat = "0.00"

-    End Select

-    

-    Dst.Worksheet.Columns("A:H").AutoFit

-    

-    Set Dst = Dst.Worksheet.Range("A1")

-End Sub

-

-Sub BuildAreasStatus(wks_name As String)

-    Dim rSrc As Range

-    Dim rDst As Range

-    Dim ListsRange As Range

-    Dim i As Integer

-    Dim j As Integer

-    Dim s As String

-    Dim WS_Name As String

-    

-    With ThisWorkbook

-        .Application.ScreenUpdating = False

-        

-        

-' Вычисляем размер списка

-

-        Dim AreaCount As Integer

-

-        AreaCount = 3

-        Set rDst = .Worksheets(wks_name).Range(WKS_A3)

-        While rDst <> ""

-            Set rDst = rDst.Offset(1, 0)

-            AreaCount = AreaCount + 1

-        Wend

-

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        Set rDst = .Worksheets(wks_name).Range(WKS_A3)

-        j = 3

-        

-        For i = 1 To ListsRange.Count

-            rDst.Offset(-1, i + idx_GLStatus).Formula = ListsRange(i, 1)

-        Next i

-        

-' Вычисляем статусы зон для списка операторов

-        While rDst <> ""

-            For i = 1 To ListsRange.Count

-                WS_Name = ListsRange(i, 1)

-                s = "INDEX(" & WS_Name & "!G1:$G$" & AreaCount & ", MATCH($A" & j & "," & WS_Name & "!$A$1:$A$" & AreaCount & ",0), 1)"

-                s = "=if(iserror(" & s & "), ""-""," & s & ")"

-                rDst.Offset(0, i + idx_GLStatus).Formula = s

-                rDst.Offset(0, i + idx_GLStatus).NumberFormat = "0#"

-            Next i

-            j = j + 1

-            Set rDst = rDst.Offset(1, 0)

-        Wend

-        

-' Форматируем результат

-        For i = 0 To ListsRange.Count

-            With rDst.Offset(-1, i + idx_GLStatus).EntireColumn

-                .HorizontalAlignment = xlCenter

-                .ShrinkToFit = True

-            End With

-        Next i

-

-' Корректируем названия зон

-

-        With .Worksheets(wks_name)

-            Set rDst = .Range(.Cells(3, 1), .Cells(AreaCount, 1))

-        End With

-

-        AreaCount = 3

-        Set rSrc = .Worksheets(WKS_FIX_AREAS_NAME).Range(WKS_A3)

-        While rSrc <> ""

-            Set rSrc = rSrc.Offset(1, 0)

-            AreaCount = AreaCount + 1

-        Wend

-

-        With .Worksheets(WKS_FIX_AREAS_NAME)

-            Set rSrc = .Range(.Cells(2, 1), .Cells(AreaCount, 1))

-        End With

-

-        Dim b As Range

-        Dim c As Range

-        For Each c In rDst

-            Set b = rSrc.Find(c, LookIn:=xlValues, MatchByte:=True)

-            If Not b Is Nothing Then

-                If c.Offset(0, idx_eDescr) <> b.Offset(0, idx_eDescr) Or c.Offset(0, idx_rDescr) <> b.Offset(0, idx_rDescr) Then

-                    c.Offset(0, idx_eDescr) = b.Offset(0, idx_eDescr)

-                    c.Offset(0, idx_rDescr) = b.Offset(0, idx_rDescr)

-                    c.Offset(0, idx_GLStatus) = "Fixed"

-                    With c.EntireRow

-                        .Font.Bold = True

-                        .Font.ColorIndex = xlColorIndexAutomatic

-                    End With

-                Else

-                    c.Offset(0, idx_GLStatus) = "-"

-                End If

-            Else

-                Dim FixedList As Range

-                c.Offset(0, idx_GLStatus) = "New"

-                With c.EntireRow

-                    .Font.Bold = True

-                    .Font.ColorIndex = 3 ' Red

-                End With

-                

-'                Set Fixed

-            End If

-        Next c

-        

-        Application.ScreenUpdating = True

-        

-    End With

-End Sub

-<<<<<<
-======================
-Tools
->>>>>>
-Attribute VB_Name = "Tools"

-Option Explicit

-

-Sub ClearWorkArea(DstName As String)

-    Dim DstRange As Range

-    With ThisWorkbook

-       

-        Set DstRange = .Worksheets(DstName).Range(WKS_A3)

-        Worksheets(DstName).Select

-        DstRange.Select

-        Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select

-        Range(Selection, Selection.End(xlDown)).Select

-        Selection.Delete Shift:=xlUp

-        Selection.Font.Bold = False

-        Selection.Font.ColorIndex = xlColorIndexAutomatic

-        Set DstRange = .Worksheets(DstName).Range(WKS_A3)

-        DstRange.Select

-    End With

-End Sub

-

-Function SheetExist(SheetName As String) As Boolean

-    Dim Count, i As Integer

-

-    Count = ThisWorkbook.Sheets.Count

-    SheetExist = False

-    For i = 1 To Count

-        If ThisWorkbook.Sheets(i).Name = SheetName Then

-            SheetExist = True

-            i = Count

-        End If

-    Next i

-End Function

-

-Function GetLinesCount(r As Range) As Integer

-

-    Dim LinesCount As Integer

-    LinesCount = 0

-

-    While r <> ""

-        LinesCount = LinesCount + 1

-        Set r = r.Offset(1, 0)

-    Wend

-    

-    GetLinesCount = LinesCount

-End Function

-

-Sub CreateComSheet(wks_name As String)

-    Dim theRange As Range

-    With ThisWorkbook

-        If Not SheetExist(wks_name) Then

-            .Sheets.Add.Name = wks_name

-        End If

-            

-        .Sheets(wks_name).Visible = True

-        .Sheets(wks_name).Select

-        Cells.Select

-        Selection.ClearContents

-        Selection.Interior.ColorIndex = xlNone

-        Selection.Borders(xlLeft).LineStyle = xlNone

-        Selection.Borders(xlRight).LineStyle = xlNone

-        Selection.Borders(xlTop).LineStyle = xlNone

-        Selection.Borders(xlBottom).LineStyle = xlNone

-        Selection.BorderAround LineStyle:=xlNone

-        Selection.Font.ColorIndex = 0

-        Selection.EntireColumn.ColumnWidth = ActiveSheet.StandardWidth

-    

-        With .Worksheets(wks_name)

-            .Range("a1") = wks_name

-            With .Range("a2")

-                .Offset(0, idx_sCode) = "sCode"

-                .Offset(0, idx_Code) = "Code"

-                .Offset(0, idx_eDescr) = "Descr_E"

-                .Offset(0, idx_rDescr) = "Descr_R"

-                .Offset(0, idx_Price) = "Price"

-                .Offset(0, idx_Traffic) = "Traffic"

-                .Offset(0, idx_Status) = "Status"

-                .Offset(0, idx_Price2) = "Price2"

-            End With

-            With .Rows("2:2")

-                .Font.Bold = False

-                .WrapText = False

-                .HorizontalAlignment = xlCenter

-            End With

-            .Range("A1").Select

-        End With

-    End With

-End Sub

-

-Function GetGlobalAreaIdx(wks_name As String, AreaCount As Integer, scDst, scSrc) As Integer

-    Dim i As Integer

-    Dim s As String

-    Dim Answer As Integer

-    

-    GetGlobalAreaIdx = -1

-    

-    With ThisWorkbook.Worksheets(wks_name)

-        For i = Len(scSrc) To 2 Step -1

-            s = Left(scSrc, i)

-            If InStr(scDst, s) And i > 1 Then

-                Answer = FindVIndex(.Range("A:A"), AreaCount, s)

-                If Answer > 0 Then

-                    GetGlobalAreaIdx = Answer

-                    Exit Function

-                End If

-            End If

-        Next i

-    End With

-End Function

-

-

-Function FindVIndex(Src As Range, AreaCount As Integer, s As String) As Integer

-    Dim l As Long

-    FindVIndex = -1

-    For l = 1 To AreaCount

-        If s = Src.Cells(l, 1) Then

-            FindVIndex = l

-            Exit Function

-        End If

-    Next l

-End Function

-

-Sub MarkDublicates(Src As Range)

-    Dim Dst As Range

-    Set Dst = Src.Offset(1, 0)

-    While Dst <> ""

-        If Dst = Src Then

-            With Dst.EntireRow

-                .Font.Bold = True

-                .Font.ColorIndex = 3

-            End With

-            Set Dst = Dst.Offset(1, 0)

-        Else

-            Set Src = Dst

-            Set Dst = Src.Offset(1, 0)

-        End If

-    Wend

-End Sub

-

-<<<<<<
-======================
-Constatnts
->>>>>>
-Attribute VB_Name = "Constatnts"

-Option Explicit

-

-Public Const UNKNOWN_AREA As String = "UNKNOWN_AREA"

-Public Const NONAME_AREA As String = "*"

-

-Public Const WKS_AREAS_NAME As String = "GlobalList"

-Public Const WKS_PRICE_NAME As String = "OpPrices"

-Public Const WKS_TRAFFIC_NAME As String = "OpTraffic"

-Public Const WKS_FIX_AREAS_NAME As String = "GLFixed"

-Public Const WKS_HOME_NAME As String = "Home"

-

-Public Const WKS_A3 As String = "A3"

-Public Const idx_sCode As Integer = 0

-Public Const idx_Code As Integer = 1

-Public Const idx_eDescr As Integer = 2

-Public Const idx_rDescr As Integer = 3

-Public Const idx_Price As Integer = 4

-Public Const idx_Traffic As Integer = 5

-Public Const idx_Status As Integer = 6

-Public Const idx_Price2 As Integer = 7

-

-Public Const idx_DatTraffic As Integer = 2

-Public Const idx_GLStatus As Integer = 4

-

-Public Const ADD_CODE_ONLY As Integer = 0

-Public Const ADD_CODE_PRICE As Integer = 1

-Public Const ADD_CODE_TRAFFIC As Integer = 2

-

-

-

-

-Sub AnalyzePrices()

-    AnalyzeOpPricesData WKS_PRICE_NAME, "0.0000"

-End Sub

-

-

-Sub AnalyzeData()

-'    AnalyzeOpPricesData WKS_TRAFFIC_NAME, "0."

-    MsgBox "This code not debuged"

-End Sub

-

-<<<<<<
-======================
-ForecastPrice
->>>>>>
-Attribute VB_Name = "ForecastPrice"

-Option Explicit

-

-Sub ForecastBlankCodes()

-    Dim ListsRange As Range

-    Dim i As Integer

-    Dim AreaCount As Integer

-    

-    With ThisWorkbook

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        

-        Dim s As String

-        Dim r As Range

-        

-        AreaCount = 0

-        Set r = .Worksheets(WKS_PRICE_NAME).Range(WKS_A3)

-        While r <> ""

-            AreaCount = AreaCount + 1

-            Set r = r.Offset(1, 0)

-        Wend

-

-        For i = 1 To ListsRange.Count

-            Set r = .Worksheets(WKS_PRICE_NAME).Range(WKS_A3).Offset(0, idx_PriceIN + i - 1)

-            DoForecast r, AreaCount

-        Next i

-    End With

-End Sub

-

-

-Sub DoForecast(Src As Range, AreaCount As Integer)

-    Dim i As Integer

-    Dim Dst As Range

-    Dim scSrc As String

-    Dim scDst As String

-    

-    Static PriceAvailable As Boolean

-    

-    With ThisWorkbook

-        Set Dst = Src.Offset(1, 0)

-    

-        For i = 1 To AreaCount

-            PriceAvailable = Application.WorksheetFunction.IsNumber(Dst)

-            

-            If PriceAvailable = True Then

-                Set Src = Dst

-                Set Dst = Src.Offset(1, 0)

-            Else

-                scSrc = .Worksheets(WKS_PRICE_NAME).Range("A:A").Cells(Src.Row, 1)

-                scDst = .Worksheets(WKS_PRICE_NAME).Range("A:A").Cells(Dst.Row, 1)

-                

-                Dim idx As Integer

-                

-                idx = GetGlobalAreaIdx(WKS_AREAS_NAME, AreaCount, scDst, scSrc)

-                If idx <> -1 Then

-                    Set Src = .Worksheets(WKS_PRICE_NAME).Cells(idx, Src.Column)

-                    

-                    Dst = Src

-                    Dst.Font.Bold = False

-                    Dst.Font.ColorIndex = 29 ' magenta

-                    Set Dst = Dst.Offset(1, 0)

-                Else

-'                    Dst = "*"

-'                    Dst.Font.ColorIndex = xlColorIndexAutomatic

-'                    Dst.Font.Bold = True

-                    Set Dst = Dst.Offset(1, 0)

-                End If

-            End If

-        Next i

-    End With

-End Sub

-

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet27
->>>>>>
-Attribute VB_Name = "Sheet27"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet35
->>>>>>
-Attribute VB_Name = "Sheet35"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet32
->>>>>>
-Attribute VB_Name = "Sheet32"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet33
->>>>>>
-Attribute VB_Name = "Sheet33"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet34
->>>>>>
-Attribute VB_Name = "Sheet34"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet28
->>>>>>
-Attribute VB_Name = "Sheet28"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Option Explicit

-

-Type PriceRecord

-    Aria As String

-    Description As String

-    Description2 As String

-    Price As Double

-End Type

-

-Dim SourcePrData() As PriceRecord

-

-Sub a()

-    ReDim SourcePrData(1 To 5)

-    Erase SourcePrData

-End Sub

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Sub Home_Click()

-Attribute Home_Click.VB_Description = "Macro recorded 11/04/2001 by Nickolai Garbuz"

-Attribute Home_Click.VB_ProcData.VB_Invoke_Func = " \n14"

-    Sheets("Home").Select

-    Range("A1").Select

-End Sub

-Sub CPriceDraft_Click()

-    Sheets("Price.Draft").Select

-    Range("A1").Select

-End Sub

-Sub COperSetup_Click()

-    Sheets("Operators.Setup").Select

-    Range("A1").Select

-End Sub

-Sub COperPrice_Click()

-    Sheets("Operators.Price").Select

-    Range("A1").Select

-End Sub

-Sub CDealerSetup_Click()

-    Sheets("Dealers.Setup").Select

-    Range("A1").Select

-End Sub

-Sub CDealerPrice_Click()

-    Sheets("Dealers.Price").Select

-    Range("A1").Select

-End Sub

-

-Sub CClientSetup_Click()

-    Sheets("Corporate.Setup").Select

-    Range("A1").Select

-End Sub

-Sub CClientGPL_Click()

-    Sheets("Corporate.GPL").Select

-    Range("A1").Select

-End Sub

-Sub CClientGPL10_Click()

-    Sheets("Corporate.GPL-10").Select

-    Range("A1").Select

-End Sub

-Sub CClientGPL20_Click()

-    Sheets("Corporate.GPL-20").Select

-    Range("A1").Select

-End Sub

-

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet24
->>>>>>
-Attribute VB_Name = "Sheet24"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-mAnalisys
->>>>>>
-Attribute VB_Name = "mAnalisys"

-Option Explicit

-

-

-Sub AnalyzeOpPricesData(wks_name As String, DATA_fmt As String)

-

-' Формируем список зон на рабочем листе

-' Удаляем предыдущий расчет

-    ClearWorkArea (wks_name)

-

-' Копируем созданный список на рабочий лист

-

-    Dim SrcRange As Range

-    Dim DstRange As Range

-

-    With ThisWorkbook

-        .Application.ScreenUpdating = False

-        

-        Set DstRange = .Worksheets(wks_name).Range("A3")

-        Set SrcRange = .Worksheets(WKS_AREAS_NAME).Range("A3")

-  

-        CopyAreasList DstRange, SrcRange

-        

-        Set DstRange = .Worksheets(wks_name).Range("A3")

-    End With

-

-' Подсчитываем общее количество зон

-

-    Dim AreaCount As Integer

-    AreaCount = GetLinesCount(DstRange)

-

-

-' Форматируем полученный результат

-    Dim i As Integer

-        

-    For i = 1 To 3

-        Set DstRange = ThisWorkbook.Worksheets(wks_name) _

-                    .Range(Cells(2, i), Cells(2 + AreaCount, i))

-        With DstRange

-            .EntireColumn.AutoFit

-            If i Mod 2 = 1 Then

-                .Interior.ColorIndex = 36 ' LightYellow

-            Else

-                .Interior.ColorIndex = xlNone  'White

-            End If

-        End With

-    Next i

-

-' Перебираем цены/данные всех операторов и формируем общий список цен рл зонам

-' Копируем цены операторов для зон

-

-    Dim ListsRange As Range

-    

-    With ThisWorkbook

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        

-        Dim s As String

-    

-        For i = 1 To ListsRange.Count

-            Set DstRange = .Worksheets(wks_name).Range("A3")

-            s = ListsRange.Cells(i, 1).Value

-            If wks_name = WKS_TRAFFIC_NAME Then

-                s = s & ".Data"

-            End If

-            Set SrcRange = .Worksheets(s).Range("A3")

-

-            AddOpPriceData DstRange, SrcRange, i

-            

-' Форматируем полученный результат

-            With .Worksheets(wks_name)

-                Set DstRange = .Range(.Cells(2, 3 + i), .Cells(2 + AreaCount, 3 + i))

-            End With

-            With DstRange

-                .NumberFormat = DATA_fmt

-                .HorizontalAlignment = xlCenter

-                .VerticalAlignment = xlBottom

-                .WrapText = False

-                .Orientation = 0

-                .AddIndent = False

-                .ShrinkToFit = False

-                .MergeCells = False

-                If i Mod 2 = 0 Then

-                    .Interior.ColorIndex = 36 ' LightYellow

-                Else

-                    .Interior.ColorIndex = xlNone  'White

-                End If

-            End With

-        Next i

-        With Worksheets(wks_name)

-            Set DstRange = .Range(.Cells(2, 4), .Cells(2 + AreaCount, 9))

-        End With

-        

-        For Each SrcRange In DstRange

-            If SrcRange = "" Then

-                SrcRange = "-"

-            End If

-        Next SrcRange

-        

-        Set SrcRange = .Worksheets(wks_name).Range("A3")

-    End With

-    

-' Рассчитываем статистику по ценам

-    Set DstRange = ThisWorkbook.Worksheets(wks_name).Range("J3")

-    DstRange.Select

-        

-    For i = 0 To AreaCount - 1

-        s = "(D" & i + 3 & ":I" & i + 3 & ")"

-        DstRange.Offset(i, 0).Formula = "=count" + s

-        DstRange.Offset(i, 1).Formula = "=if(J" & i + 3 & ">0, min" & s & ", ""-"")"

-        DstRange.Offset(i, 2).Formula = "=if(J" & i + 3 & ">0, max" & s & ", ""-"")"

-        DstRange.Offset(i, 3).Formula = "=if(J" & i + 3 & ">0, average" & s & ", ""-"")"

-        s = "=if(J" & (i + 3) & ">0, (M" & (i + 3) & "-K" & (i + 3) & ")/M" & (i + 3) & ", ""-"")"

-        DstRange.Offset(i, 4).Formula = s

-        s = "=if(J" & i + 3 & ">0, (L" & (i + 3) & "-M" & (i + 3) & ")/M" & (i + 3) & ", ""-"")"

-        DstRange.Offset(i, 5).Formula = s

-    Next i

-

-' Форматируем полученный результат

-    For i = 0 To 5

-        With ThisWorkbook.Worksheets(wks_name)

-            Set DstRange = .Range(.Cells(2, 10 + i), .Cells(2 + AreaCount, 10 + i))

-        End With

-        With DstRange

-            If i <> 0 Then

-                .NumberFormat = DATA_fmt

-            End If

-            .HorizontalAlignment = xlCenter

-            .VerticalAlignment = xlBottom

-            .WrapText = False

-            .Orientation = 0

-            .AddIndent = False

-            .ShrinkToFit = False

-            .MergeCells = False

-            If i Mod 2 = 0 Then

-                .Interior.ColorIndex = 35 ' LightLightGreen

-            Else

-                .Interior.ColorIndex = 34  ' LightLightBlue

-            End If

-            .Application.ScreenUpdating = True

-

-        End With

-    Next i

-End Sub

-

-Sub CopyAreasList(Dst As Range, Src As Range)

-    While Src <> ""

-        Dst = Src

-        Dst.Offset(0, 1) = Src.Offset(0, 1)

-        Dst.Offset(0, 2) = Src.Offset(0, 2)

-        Set Src = Src.Offset(1, 0)

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-End Sub

-

-

-Sub AddOpPriceData(Dst As Range, Src As Range, index As Integer)

-    While Src <> ""

-        If Dst < Src Then

-            Dst.Offset(0, 2 + index) = "-"

-        End If

-        If Dst = Src Then

-            Dst.Offset(0, 2 + index) = Src.Offset(0, 3)

-            Set Src = Src.Offset(1, 0)

-        End If

-        Dst.Offset(0, 2 + index).Font.Bold = True

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-    While Dst <> ""

-        Dst.Offset(0, 2 + index) = "-"

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-

-End Sub

-

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-GlobalList
->>>>>>
-Attribute VB_Name = "GlobalList"

-Option Explicit

-

-

-

-Sub CreateGlobalCodeList()

-

-' Перебираем названия всех операторов и формируем общий список зон

-' Удаляем предыдущий расчет

-    ClearWorkArea (WKS_AREAS_NAME)

-    

-' Формируем общий список зон

-

-    BuildAreasList (WKS_AREAS_NAME)

-    

-    BuildAreasStatus (WKS_AREAS_NAME)

-

-End Sub

-

-Sub BuildWorkPriceLists()

-

-    Dim SrcRange As Range

-    Dim DstRange As Range

-    Dim ListsRange As Range

-    

-    With ThisWorkbook

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        

-        Dim s As String

-        Dim i As Integer

-    

-' Перебираем названия всех операторов и формируем общий список зон

-        With .Application

-            .Calculation = xlCalculationManual

-            .ScreenUpdating = False

-        End With

-

-

-        For i = 1 To ListsRange.Count

-            s = ListsRange.Cells(i, 1).Value

-            

-            CreateSheet (s)

-            

-            Set DstRange = .Worksheets(s).Range("A3")

-            Set SrcRange = .Worksheets(s & ".Tarif").Range("A3")

-            

-            AddOpArea DstRange, SrcRange, 1

-            

-            Set DstRange = .Worksheets(s).Range("A3")

-            Set SrcRange = .Worksheets(s & ".Data").Range("A3")

-            

-            AddOpArea DstRange, SrcRange, 2

-            

-' Присваиваем зонам статус:

-' 00 - не известная, не используется

-' 01 - не известная, используется

-' 10 - известная, не используется

-' 11 - известная, используется

-            

-            Set DstRange = .Worksheets(s).Range("A3")

-            While DstRange <> ""

-                If DstRange.Offset(0, 3) = 0 Or DstRange.Offset(0, 3) = "-" Then

-                    If DstRange.Offset(0, 4) = 0 Then

-                        DstRange.Offset(0, 5) = 0

-                    Else

-                        DstRange.Offset(0, 5) = 1

-                    End If

-                Else

-                    If DstRange.Offset(0, 4) = 0 Then

-                        DstRange.Offset(0, 5) = 10

-                    Else

-                        DstRange.Offset(0, 5) = 11

-                    End If

-                End If

-                Set DstRange = DstRange.Offset(1, 0)

-            Wend

-                

-            With .Worksheets(s).Columns("A:F")

-                .HorizontalAlignment = xlHAlignGeneral

-                .VerticalAlignment = xlBottom

-                .WrapText = False

-                .Orientation = 0

-                .AddIndent = False

-                .ShrinkToFit = True

-                .MergeCells = False

-            End With

-            .Worksheets(s).Columns("F:F").HorizontalAlignment = xlHAlignCenter

-

-        Next i

-        With .Application

-            .Calculation = xlCalculationAutomatic

-            .ScreenUpdating = True

-            .Calculate

-        End With

-    End With

-

-End Sub

-

-Sub BuildAreasList(DstName As String)

-

-    Dim SrcRange As Range

-    Dim DstRange As Range

-    Dim ListsRange As Range

-    

-    With ThisWorkbook

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        

-        Dim s As String

-        Dim i As Integer

-    

-        With .Application

-            .Calculation = xlCalculationManual

-            .ScreenUpdating = False

-        End With

-' Перебираем названия всех операторов и формируем общий список зон

-

-        For i = 1 To ListsRange.Count

-            s = ListsRange.Cells(i, 1).Value

-            

-            Set DstRange = .Worksheets(WKS_AREAS_NAME).Range("A3")

-            Set SrcRange = .Worksheets(s).Range("A3")

-        

-            AddOpArea DstRange, SrcRange

-        Next i

-        Set SrcRange = .Worksheets(DstName).Range("A3")

-        .Worksheets(DstName).Select

-        With .Application

-            .Calculation = xlCalculationAutomatic

-            .ScreenUpdating = True

-            .Calculate

-        End With

-    End With

-End Sub

-

-Sub AddOpArea(Dst As Range, Src As Range, Optional add_field_num = 0)

-    

-    While Src <> ""

-        If Dst > Src Then

-            Dst.Worksheet.Range(Dst, Dst.Offset(0, 50)).Insert Shift:=xlShiftDown

-            Set Dst = Dst.Offset(-1, 0)

-        End If

-        If Dst = "" Then

-            Dst = Src

-            Dst.Offset(0, 1) = Src.Offset(0, 1)

-            Dst.Offset(0, 2) = Src.Offset(0, 2)

-            If (Dst.Offset(0, 2) = "") Then

-                Dst.Offset(0, 2) = UNKNOWN_AREA

-            End If

-        End If

-        If Dst = Src Then

-            If Dst.Offset(0, 2) = UNKNOWN_AREA And Src.Offset(0, 2) <> UNKNOWN_AREA And Src.Offset(0, 2) <> "" Then

-                Dst.Offset(0, 2) = Src.Offset(0, 2)

-            End If

-            

-            Select Case add_field_num

-                Case 1

-                    Dst.Offset(0, 3) = Src.Offset(0, 3)

-                    If Dst.Offset(0, 3) = "" Then

-                        Dst.Offset(0, 3) = "-"

-                    End If

-                Case 2

-                    Dst.Offset(0, 4) = Src.Offset(0, 3)

-            End Select

-            Set Src = Src.Offset(1, 0)

-        End If

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-    

-    Select Case add_field_num

-        Case 1

-            Dst.Worksheet.Columns("D:D").NumberFormat = "0.0000"

-        Case 2

-            Dst.Worksheet.Columns("E:E").NumberFormat = "0.00"

-    End Select

-    

-    Dst.Worksheet.Columns("A:E").AutoFit

-    

-    Set Dst = Dst.Worksheet.Range("A1")

-End Sub

-

-Sub BuildAreasStatus(wks_name As String)

-    Dim rSrc As Range

-    Dim rDst As Range

-    Dim i As Integer

-        

-    With ThisWorkbook

-        Set rDst = .Worksheets(wks_name).Range("A3")

-        i = 3

-        

-        .Application.ScreenUpdating = False

-

-' Вычисляем статусы зон для списка операторов

-        While rDst <> ""

-            rDst.Offset(0, 4).Formula = "=INDEX(Edge2Net!F1:$F$1500, MATCH($A" & i & ",Edge2Net!$A$1:$A$1500,0), 1)"

-            rDst.Offset(0, 5).Formula = "=INDEX(LineCom!F1:$F$1500, MATCH($A" & i & ",LineCom!$A$1:$A$1500,0), 1)"

-            rDst.Offset(0, 6).Formula = "=INDEX(MTX!F1:$F$1500, MATCH($A" & i & ",MTX!$A$1:$A$1500,0), 1)"

-            rDst.Offset(0, 7).Formula = "=INDEX(Elcatel!F1:$F$1500, MATCH($A" & i & ",Elcatel!$A$1:$A$1500,0), 1)"

-            rDst.Offset(0, 8).Formula = "=INDEX(MC_MTT!F1:$F$1500, MATCH($A" & i & ",MC_MTT!$A$1:$A$1500,0), 1)"

-            rDst.Offset(0, 9).Formula = "=INDEX(Nova!F1:$F$1500, MATCH($A" & i & ",Nova!$A$1:$A$1500,0), 1)"

-            

-            i = i + 1

-            Set rDst = rDst.Offset(1, 0)

-        Wend

-        

-' Корректируем названия зон

-        Dim AreaCount As Integer

-

-        AreaCount = 3

-        Set rDst = .Worksheets(wks_name).Range("A3")

-        While rDst <> ""

-            Set rDst = rDst.Offset(1, 0)

-            AreaCount = AreaCount + 1

-        Wend

-

-        With .Worksheets(wks_name)

-            Set rDst = .Range(.Cells(3, 1), .Cells(AreaCount, 1))

-        End With

-

-        AreaCount = 3

-        Set rSrc = .Worksheets(WKS_FIX_AREAS_NAME).Range("A3")

-        While rSrc <> ""

-            Set rSrc = rSrc.Offset(1, 0)

-            AreaCount = AreaCount + 1

-        Wend

-

-        With .Worksheets(WKS_FIX_AREAS_NAME)

-            Set rSrc = .Range(.Cells(2, 1), .Cells(AreaCount, 1))

-        End With

-

-        Dim b As Range

-        Dim c As Range

-

-        For Each c In rDst

-            Set b = rSrc.Find(c, LookIn:=xlValues, MatchByte:=True)

-            If Not b Is Nothing Then

-                If c.Offset(0, 2) <> b.Offset(0, 2) Then

-                    c.Offset(0, 2) = b.Offset(0, 2)

-                    c.Offset(0, 3) = "Fixed"

-                    With .Worksheets(wks_name).Range(c.Offset(0, 0), c.Offset(0, 3))

-                        .Font.Bold = True

-                        .Font.ColorIndex = xlColorIndexAutomatic

-                    End With

-                Else

-                    c.Offset(0, 3) = "-"

-                End If

-            Else

-                Dim FixedList As Range

-                c.Offset(0, 3) = "New"

-                With .Worksheets(wks_name).Range(c.Offset(0, 0), c.Offset(0, 3))

-                    .Font.Bold = True

-                    .Font.ColorIndex = 3 ' Red

-                End With

-                

-'                Set Fixed

-            End If

-        Next c

-        

-        Application.ScreenUpdating = True

-        

-    End With

-End Sub

-<<<<<<
-======================
-Tools
->>>>>>
-Attribute VB_Name = "Tools"

-Option Explicit

-

-Sub ClearWorkArea(DstName As String)

-    Dim DstRange As Range

-    With ThisWorkbook

-       

-        Set DstRange = .Worksheets(DstName).Range("A3")

-        Worksheets(DstName).Select

-        DstRange.Select

-        Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select

-        Range(Selection, Selection.End(xlDown)).Select

-        Selection.Delete Shift:=xlUp

-        Selection.Font.Bold = False

-        Selection.Font.ColorIndex = xlColorIndexAutomatic

-        Set DstRange = .Worksheets(DstName).Range("A3")

-        DstRange.Select

-    End With

-End Sub

-

-Function SheetExist(SheetName As String) As Boolean

-    Dim Count, i As Integer

-

-    Count = ThisWorkbook.Sheets.Count

-    SheetExist = False

-    For i = 1 To Count

-        If ThisWorkbook.Sheets(i).Name = SheetName Then

-            SheetExist = True

-            i = Count

-        End If

-    Next i

-End Function

-

-Function GetLinesCount(r As Range) As Integer

-

-    Dim LinesCount As Integer

-    LinesCount = 0

-

-    While r <> ""

-        LinesCount = LinesCount + 1

-        Set r = r.Offset(1, 0)

-    Wend

-    

-    GetLinesCount = LinesCount

-End Function

-

-Sub CreateSheet(wks_name As String)

-    Dim theRange As Range

-    With ThisWorkbook

-        If Not SheetExist(wks_name) Then

-            .Sheets.Add.Name = wks_name

-        End If

-            

-        .Sheets(wks_name).Visible = True

-        .Sheets(wks_name).Select

-        Cells.Select

-        Selection.ClearContents

-        Selection.Interior.ColorIndex = xlNone

-        Selection.Borders(xlLeft).LineStyle = xlNone

-        Selection.Borders(xlRight).LineStyle = xlNone

-        Selection.Borders(xlTop).LineStyle = xlNone

-        Selection.Borders(xlBottom).LineStyle = xlNone

-        Selection.BorderAround LineStyle:=xlNone

-        Selection.Font.ColorIndex = 0

-        Selection.EntireColumn.ColumnWidth = ActiveSheet.StandardWidth

-    

-        With .Worksheets(wks_name)

-            .Range("a1") = wks_name

-            .Range("a2") = "sCode"

-            .Range("b2") = "Code"

-            .Range("c2") = "Description"

-            .Range("d2") = "Price"

-            .Range("e2") = "Traffic"

-            .Range("f2") = "Status"

-            .Range("g2") = "Price2"

-            With .Range("a2:f2")

-                .Font.Bold = False

-                .WrapText = False

-                .HorizontalAlignment = xlCenter

-            End With

-            .Range("A1").Select

-        End With

-    End With

-End Sub

-

-Function GetGlobalAreaIdx(wks_name As String, AreaCount As Integer, scDst, scSrc) As Integer

-    Dim i As Integer

-    Dim s As String

-    Dim Answer As Integer

-    

-    GetGlobalAreaIdx = -1

-    

-    With ThisWorkbook.Worksheets(wks_name)

-        For i = Len(scSrc) To 1 Step -1

-            s = Left(scSrc, i)

-            If InStr(scDst, s) And i > 1 Then

-                Answer = FindVIndex(.Range("A:A"), AreaCount, s)

-                If Answer > 0 Then

-                    GetGlobalAreaIdx = Answer

-                    Exit Function

-                End If

-            End If

-        Next i

-    End With

-End Function

-

-

-Function FindVIndex(Src As Range, AreaCount As Integer, s As String) As Integer

-    Dim l As Long

-    FindVIndex = -1

-    For l = 1 To AreaCount

-        If s = Src.Cells(l, 1) Then

-            FindVIndex = l

-            Exit Function

-        End If

-    Next l

-End Function

-

-

-<<<<<<
-======================
-Constatnts
->>>>>>
-Attribute VB_Name = "Constatnts"

-Option Explicit

-

-Public Const UNKNOWN_AREA As String = "UNKNOWN_AREA"

-Public Const WKS_AREAS_NAME As String = "GlobalList"

-Public Const WKS_PRICE_NAME As String = "OpPrices"

-Public Const WKS_TRAFFIC_NAME As String = "OpTraffic"

-Public Const WKS_FIX_AREAS_NAME As String = "GLFixed"

-Public Const WKS_HOME_NAME As String = "Home"

-

-

-

-Sub AnalyzePrices()

-    AnalyzeOpPricesData WKS_PRICE_NAME, "0.0000"

-End Sub

-

-

-Sub AnalyzeData()

-    AnalyzeOpPricesData WKS_TRAFFIC_NAME, "0."

-End Sub

-

-<<<<<<
-======================
-ForecastPrice
->>>>>>
-Attribute VB_Name = "ForecastPrice"

-Option Explicit

-

-Sub ForecastBlankCodes()

-    Dim ListsRange As Range

-    Dim i As Integer

-    Dim AreaCount As Integer

-    

-    With ThisWorkbook

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        

-        Dim s As String

-        Dim r As Range

-        

-        AreaCount = 0

-        Set r = .Worksheets(WKS_PRICE_NAME).Range("A3")

-        While r <> ""

-            AreaCount = AreaCount + 1

-            Set r = r.Offset(1, 0)

-        Wend

-

-        For i = 1 To ListsRange.Count

-            s = ListsRange.Cells(i, 1).Value

-            Set r = .Worksheets(WKS_PRICE_NAME).Range("D2:I2").Find(s, LookIn:=xlValues, MatchByte:=True).Offset(1, 0)

-            DoForecast r, AreaCount

-        Next i

-    End With

-End Sub

-

-

-Sub DoForecast(Src As Range, AreaCount As Integer)

-    Dim i As Integer

-    Dim Dst As Range

-    Dim scSrc As String

-    Dim scDst As String

-    

-    Static PriceAvailable As Boolean

-    

-    With ThisWorkbook

-        Set Dst = Src.Offset(1, 0)

-    

-        If Application.WorksheetFunction.IsNumber(Src) = False Then

-            Src = "-"

-            Src.Font.Bold = True

-            Src.Font.ColorIndex = xlColorIndexAutomatic

-        End If

-        

-        For i = 1 To AreaCount

-            PriceAvailable = Application.WorksheetFunction.IsNumber(Dst)

-            

-            If PriceAvailable = True Then

-                Set Src = Dst

-                Set Dst = Src.Offset(1, 0)

-            Else

-                scSrc = .Worksheets(WKS_PRICE_NAME).Range("A:A").Cells(Src.Row, 1)

-                scDst = .Worksheets(WKS_PRICE_NAME).Range("A:A").Cells(Dst.Row, 1)

-                

-                Dim idx As Integer

-                

-                idx = GetGlobalAreaIdx(WKS_AREAS_NAME, AreaCount, scDst, scSrc)

-                If idx <> -1 Then

-                    Set Src = .Worksheets(WKS_PRICE_NAME).Cells(idx, Src.Column)

-                    

-                    Dst = Src

-                    Dst.Font.Bold = False

-                    Dst.Font.ColorIndex = 29 ' magenta

-                    Set Dst = Dst.Offset(1, 0)

-                Else

-                    Dst = "-"

-                    Dst.Font.ColorIndex = xlColorIndexAutomatic

-                    Dst.Font.Bold = True

-                    Set Dst = Dst.Offset(1, 0)

-                End If

-            End If

-        Next i

-    End With

-End Sub

-

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet19
->>>>>>
-Attribute VB_Name = "Sheet19"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet22
->>>>>>
-Attribute VB_Name = "Sheet22"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet23
->>>>>>
-Attribute VB_Name = "Sheet23"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet25
->>>>>>
-Attribute VB_Name = "Sheet25"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet24
->>>>>>
-Attribute VB_Name = "Sheet24"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-mAnalisys
->>>>>>
-Attribute VB_Name = "mAnalisys"

-Option Explicit

-

-

-Sub AnalyzeOpPricesData(wks_name As String, DATA_fmt As String)

-

-' Формируем список зон на рабочем листе

-' Удаляем предыдущий расчет

-    ClearWorkArea (wks_name)

-

-' Копируем созданный список на рабочий лист

-

-    Dim SrcRange As Range

-    Dim DstRange As Range

-

-    With ThisWorkbook

-        .Application.ScreenUpdating = False

-        

-        Set DstRange = .Worksheets(wks_name).Range("A3")

-        Set SrcRange = .Worksheets(WKS_AREAS_NAME).Range("A3")

-  

-        CopyAreasList DstRange, SrcRange

-        

-        Set DstRange = .Worksheets(wks_name).Range("A3")

-    End With

-

-' Подсчитываем общее количество зон

-

-    Dim AreaCount As Integer

-    AreaCount = GetLinesCount(DstRange)

-

-

-' Форматируем полученный результат

-    Dim i As Integer

-        

-    For i = 1 To 3

-        Set DstRange = ThisWorkbook.Worksheets(wks_name) _

-                    .Range(Cells(2, i), Cells(2 + AreaCount, i))

-        With DstRange

-            .EntireColumn.AutoFit

-            If i Mod 2 = 1 Then

-                .Interior.ColorIndex = 36 ' LightYellow

-            Else

-                .Interior.ColorIndex = xlNone  'White

-            End If

-        End With

-    Next i

-

-' Перебираем цены/данные всех операторов и формируем общий список цен рл зонам

-' Копируем цены операторов для зон

-

-    Dim ListsRange As Range

-    

-    With ThisWorkbook

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        

-        Dim s As String

-    

-        For i = 1 To ListsRange.Count

-            Set DstRange = .Worksheets(wks_name).Range("A3")

-            s = ListsRange.Cells(i, 1).Value

-            If wks_name = WKS_TRAFFIC_NAME Then

-                s = s & ".Data"

-            End If

-            Set SrcRange = .Worksheets(s).Range("A3")

-

-            AddOpPriceData DstRange, SrcRange, i

-            

-' Форматируем полученный результат

-            With .Worksheets(wks_name)

-                Set DstRange = .Range(.Cells(2, 3 + i), .Cells(2 + AreaCount, 3 + i))

-            End With

-            With DstRange

-                .NumberFormat = DATA_fmt

-                .HorizontalAlignment = xlCenter

-                .VerticalAlignment = xlBottom

-                .WrapText = False

-                .Orientation = 0

-                .AddIndent = False

-                .ShrinkToFit = False

-                .MergeCells = False

-                If i Mod 2 = 0 Then

-                    .Interior.ColorIndex = 36 ' LightYellow

-                Else

-                    .Interior.ColorIndex = xlNone  'White

-                End If

-            End With

-        Next i

-        With Worksheets(wks_name)

-            Set DstRange = .Range(.Cells(2, 4), .Cells(2 + AreaCount, 9))

-        End With

-        

-        For Each SrcRange In DstRange

-            If SrcRange = "" Then

-                SrcRange = "-"

-            End If

-        Next SrcRange

-        

-        Set SrcRange = .Worksheets(wks_name).Range("A3")

-    End With

-    

-' Рассчитываем статистику по ценам

-    Set DstRange = ThisWorkbook.Worksheets(wks_name).Range("J3")

-    DstRange.Select

-        

-    For i = 0 To AreaCount - 1

-        s = "(D" & i + 3 & ":I" & i + 3 & ")"

-        DstRange.Offset(i, 0).Formula = "=count" + s

-        DstRange.Offset(i, 1).Formula = "=if(J" & i + 3 & ">0, min" & s & ", ""-"")"

-        DstRange.Offset(i, 2).Formula = "=if(J" & i + 3 & ">0, max" & s & ", ""-"")"

-        DstRange.Offset(i, 3).Formula = "=if(J" & i + 3 & ">0, average" & s & ", ""-"")"

-        s = "=if(J" & (i + 3) & ">0, (M" & (i + 3) & "-K" & (i + 3) & ")/M" & (i + 3) & ", ""-"")"

-        DstRange.Offset(i, 4).Formula = s

-        s = "=if(J" & i + 3 & ">0, (L" & (i + 3) & "-M" & (i + 3) & ")/M" & (i + 3) & ", ""-"")"

-        DstRange.Offset(i, 5).Formula = s

-    Next i

-

-' Форматируем полученный результат

-    For i = 0 To 5

-        With ThisWorkbook.Worksheets(wks_name)

-            Set DstRange = .Range(.Cells(2, 10 + i), .Cells(2 + AreaCount, 10 + i))

-        End With

-        With DstRange

-            If i <> 0 Then

-                .NumberFormat = DATA_fmt

-            End If

-            .HorizontalAlignment = xlCenter

-            .VerticalAlignment = xlBottom

-            .WrapText = False

-            .Orientation = 0

-            .AddIndent = False

-            .ShrinkToFit = False

-            .MergeCells = False

-            If i Mod 2 = 0 Then

-                .Interior.ColorIndex = 35 ' LightLightGreen

-            Else

-                .Interior.ColorIndex = 34  ' LightLightBlue

-            End If

-            .Application.ScreenUpdating = True

-

-        End With

-    Next i

-End Sub

-

-Sub CopyAreasList(Dst As Range, Src As Range)

-    While Src <> ""

-        Dst = Src

-        Dst.Offset(0, 1) = Src.Offset(0, 1)

-        Dst.Offset(0, 2) = Src.Offset(0, 2)

-        Set Src = Src.Offset(1, 0)

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-End Sub

-

-

-Sub AddOpPriceData(Dst As Range, Src As Range, index As Integer)

-    While Src <> ""

-        If Dst < Src Then

-            Dst.Offset(0, 2 + index) = "-"

-        End If

-        If Dst = Src Then

-            Dst.Offset(0, 2 + index) = Src.Offset(0, 3)

-            Set Src = Src.Offset(1, 0)

-        End If

-        Dst.Offset(0, 2 + index).Font.Bold = True

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-    While Dst <> ""

-        Dst.Offset(0, 2 + index) = "-"

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-

-End Sub

-

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-GlobalList
->>>>>>
-Attribute VB_Name = "GlobalList"

-Option Explicit

-

-

-

-Sub CreateGlobalCodeList()

-

-' Перебираем названия всех операторов и формируем общий список зон

-' Удаляем предыдущий расчет

-    ClearWorkArea (WKS_AREAS_NAME)

-    

-' Формируем общий список зон

-

-    BuildAreasList (WKS_AREAS_NAME)

-    

-    BuildAreasStatus (WKS_AREAS_NAME)

-

-End Sub

-

-Sub BuildWorkPriceLists()

-

-    Dim SrcRange As Range

-    Dim DstRange As Range

-    Dim ListsRange As Range

-    

-    With ThisWorkbook

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        

-        Dim s As String

-        Dim i As Integer

-    

-' Перебираем названия всех операторов и формируем общий список зон

-        With .Application

-            .Calculation = xlCalculationManual

-            .ScreenUpdating = False

-        End With

-

-

-        For i = 1 To ListsRange.Count

-            s = ListsRange.Cells(i, 1).Value

-            

-            CreateSheet (s)

-            

-            Set DstRange = .Worksheets(s).Range("A3")

-            Set SrcRange = .Worksheets(s & ".Tarif").Range("A3")

-            

-            AddOpArea DstRange, SrcRange, 1

-            

-            Set DstRange = .Worksheets(s).Range("A3")

-            Set SrcRange = .Worksheets(s & ".Data").Range("A3")

-            

-            AddOpArea DstRange, SrcRange, 2

-            

-' Присваиваем зонам статус:

-' 00 - не известная, не используется

-' 01 - не известная, используется

-' 10 - известная, не используется

-' 11 - известная, используется

-            

-            Set DstRange = .Worksheets(s).Range("A3")

-            While DstRange <> ""

-                If DstRange.Offset(0, 3) = 0 Or DstRange.Offset(0, 3) = "-" Then

-                    If DstRange.Offset(0, 4) = 0 Then

-                        DstRange.Offset(0, 5) = 0

-                    Else

-                        DstRange.Offset(0, 5) = 1

-                    End If

-                Else

-                    If DstRange.Offset(0, 4) = 0 Then

-                        DstRange.Offset(0, 5) = 10

-                    Else

-                        DstRange.Offset(0, 5) = 11

-                    End If

-                End If

-                Set DstRange = DstRange.Offset(1, 0)

-            Wend

-                

-            With .Worksheets(s).Columns("A:F")

-                .HorizontalAlignment = xlHAlignGeneral

-                .VerticalAlignment = xlBottom

-                .WrapText = False

-                .Orientation = 0

-                .AddIndent = False

-                .ShrinkToFit = True

-                .MergeCells = False

-            End With

-            .Worksheets(s).Columns("F:F").HorizontalAlignment = xlHAlignCenter

-

-        Next i

-        With .Application

-            .Calculation = xlCalculationAutomatic

-            .ScreenUpdating = True

-            .Calculate

-        End With

-    End With

-

-End Sub

-

-Sub BuildAreasList(DstName As String)

-

-    Dim SrcRange As Range

-    Dim DstRange As Range

-    Dim ListsRange As Range

-    

-    With ThisWorkbook

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        

-        Dim s As String

-        Dim i As Integer

-    

-        With .Application

-            .Calculation = xlCalculationManual

-            .ScreenUpdating = False

-        End With

-' Перебираем названия всех операторов и формируем общий список зон

-

-        For i = 1 To ListsRange.Count

-            s = ListsRange.Cells(i, 1).Value

-            

-            Set DstRange = .Worksheets(WKS_AREAS_NAME).Range("A3")

-            Set SrcRange = .Worksheets(s).Range("A3")

-        

-            AddOpArea DstRange, SrcRange

-        Next i

-        Set SrcRange = .Worksheets(DstName).Range("A3")

-        .Worksheets(DstName).Select

-        With .Application

-            .Calculation = xlCalculationAutomatic

-            .ScreenUpdating = True

-            .Calculate

-        End With

-    End With

-End Sub

-

-Sub AddOpArea(Dst As Range, Src As Range, Optional add_field_num = 0)

-    

-    While Src <> ""

-        If Dst > Src Then

-            Dst.Worksheet.Range(Dst, Dst.Offset(0, 50)).Insert Shift:=xlShiftDown

-            Set Dst = Dst.Offset(-1, 0)

-        End If

-        If Dst = "" Then

-            Dst = Src

-            Dst.Offset(0, 1) = Src.Offset(0, 1)

-            Dst.Offset(0, 2) = Src.Offset(0, 2)

-            If (Dst.Offset(0, 2) = "") Then

-                Dst.Offset(0, 2) = UNKNOWN_AREA

-            End If

-        End If

-        If Dst = Src Then

-            If Dst.Offset(0, 2) = UNKNOWN_AREA And Src.Offset(0, 2) <> UNKNOWN_AREA And Src.Offset(0, 2) <> "" Then

-                Dst.Offset(0, 2) = Src.Offset(0, 2)

-            End If

-            

-            Select Case add_field_num

-                Case 1

-                    Dst.Offset(0, 3) = Src.Offset(0, 3)

-                    If Dst.Offset(0, 3) = "" Then

-                        Dst.Offset(0, 3) = "-"

-                    End If

-                Case 2

-                    Dst.Offset(0, 4) = Src.Offset(0, 3)

-            End Select

-            Set Src = Src.Offset(1, 0)

-        End If

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-    

-    Select Case add_field_num

-        Case 1

-            Dst.Worksheet.Columns("D:D").NumberFormat = "0.0000"

-        Case 2

-            Dst.Worksheet.Columns("E:E").NumberFormat = "0.00"

-    End Select

-    

-    Dst.Worksheet.Columns("A:E").AutoFit

-    

-    Set Dst = Dst.Worksheet.Range("A1")

-End Sub

-

-Sub BuildAreasStatus(wks_name As String)

-    Dim rSrc As Range

-    Dim rDst As Range

-    Dim i As Integer

-        

-    With ThisWorkbook

-        Set rDst = .Worksheets(wks_name).Range("A3")

-        i = 3

-        

-        .Application.ScreenUpdating = False

-

-' Вычисляем статусы зон для списка операторов

-        While rDst <> ""

-            rDst.Offset(0, 4).Formula = "=INDEX(Edge2Net!F1:$F$1500, MATCH($A" & i & ",Edge2Net!$A$1:$A$1500,0), 1)"

-            rDst.Offset(0, 5).Formula = "=INDEX(LineCom!F1:$F$1500, MATCH($A" & i & ",LineCom!$A$1:$A$1500,0), 1)"

-            rDst.Offset(0, 6).Formula = "=INDEX(MTX!F1:$F$1500, MATCH($A" & i & ",MTX!$A$1:$A$1500,0), 1)"

-            rDst.Offset(0, 7).Formula = "=INDEX(Elcatel!F1:$F$1500, MATCH($A" & i & ",Elcatel!$A$1:$A$1500,0), 1)"

-            rDst.Offset(0, 8).Formula = "=INDEX(MC_MTT!F1:$F$1500, MATCH($A" & i & ",MC_MTT!$A$1:$A$1500,0), 1)"

-            rDst.Offset(0, 9).Formula = "=INDEX(Nova!F1:$F$1500, MATCH($A" & i & ",Nova!$A$1:$A$1500,0), 1)"

-            

-            i = i + 1

-            Set rDst = rDst.Offset(1, 0)

-        Wend

-        

-' Корректируем названия зон

-        Dim AreaCount As Integer

-

-        AreaCount = 3

-        Set rDst = .Worksheets(wks_name).Range("A3")

-        While rDst <> ""

-            Set rDst = rDst.Offset(1, 0)

-            AreaCount = AreaCount + 1

-        Wend

-

-        With .Worksheets(wks_name)

-            Set rDst = .Range(.Cells(3, 1), .Cells(AreaCount, 1))

-        End With

-

-        AreaCount = 3

-        Set rSrc = .Worksheets(WKS_FIX_AREAS_NAME).Range("A3")

-        While rSrc <> ""

-            Set rSrc = rSrc.Offset(1, 0)

-            AreaCount = AreaCount + 1

-        Wend

-

-        With .Worksheets(WKS_FIX_AREAS_NAME)

-            Set rSrc = .Range(.Cells(2, 1), .Cells(AreaCount, 1))

-        End With

-

-        Dim b As Range

-        Dim c As Range

-

-        For Each c In rDst

-            Set b = rSrc.Find(c, LookIn:=xlValues, MatchByte:=True)

-            If Not b Is Nothing Then

-                If c.Offset(0, 2) <> b.Offset(0, 2) Then

-                    c.Offset(0, 2) = b.Offset(0, 2)

-                    c.Offset(0, 3) = "Fixed"

-                    With .Worksheets(wks_name).Range(c.Offset(0, 0), c.Offset(0, 3))

-                        .Font.Bold = True

-                        .Font.ColorIndex = xlColorIndexAutomatic

-                    End With

-                Else

-                    c.Offset(0, 3) = "-"

-                End If

-            Else

-                Dim FixedList As Range

-                c.Offset(0, 3) = "New"

-                With .Worksheets(wks_name).Range(c.Offset(0, 0), c.Offset(0, 3))

-                    .Font.Bold = True

-                    .Font.ColorIndex = 3 ' Red

-                End With

-                

-'                Set Fixed

-            End If

-        Next c

-        

-        Application.ScreenUpdating = True

-        

-    End With

-End Sub

-<<<<<<
-======================
-Tools
->>>>>>
-Attribute VB_Name = "Tools"

-Option Explicit

-

-Sub ClearWorkArea(DstName As String)

-    Dim DstRange As Range

-    With ThisWorkbook

-       

-        Set DstRange = .Worksheets(DstName).Range("A3")

-        Worksheets(DstName).Select

-        DstRange.Select

-        Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select

-        Range(Selection, Selection.End(xlDown)).Select

-        Selection.Delete Shift:=xlUp

-        Selection.Font.Bold = False

-        Selection.Font.ColorIndex = xlColorIndexAutomatic

-        Set DstRange = .Worksheets(DstName).Range("A3")

-        DstRange.Select

-    End With

-End Sub

-

-Function SheetExist(SheetName As String) As Boolean

-    Dim Count, i As Integer

-

-    Count = ThisWorkbook.Sheets.Count

-    SheetExist = False

-    For i = 1 To Count

-        If ThisWorkbook.Sheets(i).Name = SheetName Then

-            SheetExist = True

-            i = Count

-        End If

-    Next i

-End Function

-

-Function GetLinesCount(r As Range) As Integer

-

-    Dim LinesCount As Integer

-    LinesCount = 0

-

-    While r <> ""

-        LinesCount = LinesCount + 1

-        Set r = r.Offset(1, 0)

-    Wend

-    

-    GetLinesCount = LinesCount

-End Function

-

-Sub CreateSheet(wks_name As String)

-    Dim theRange As Range

-    With ThisWorkbook

-        If Not SheetExist(wks_name) Then

-            .Sheets.Add.Name = wks_name

-        End If

-            

-        .Sheets(wks_name).Visible = True

-        .Sheets(wks_name).Select

-        Cells.Select

-        Selection.ClearContents

-        Selection.Interior.ColorIndex = xlNone

-        Selection.Borders(xlLeft).LineStyle = xlNone

-        Selection.Borders(xlRight).LineStyle = xlNone

-        Selection.Borders(xlTop).LineStyle = xlNone

-        Selection.Borders(xlBottom).LineStyle = xlNone

-        Selection.BorderAround LineStyle:=xlNone

-        Selection.Font.ColorIndex = 0

-        Selection.EntireColumn.ColumnWidth = ActiveSheet.StandardWidth

-    

-        With .Worksheets(wks_name)

-            .Range("a1") = wks_name

-            .Range("a2") = "sCode"

-            .Range("b2") = "Code"

-            .Range("c2") = "Description"

-            .Range("d2") = "Price"

-            .Range("e2") = "Traffic"

-            .Range("f2") = "Status"

-            .Range("g2") = "Price2"

-            With .Range("a2:f2")

-                .Font.Bold = False

-                .WrapText = False

-                .HorizontalAlignment = xlCenter

-            End With

-            .Range("A1").Select

-        End With

-    End With

-End Sub

-

-Function GetGlobalAreaIdx(wks_name As String, AreaCount As Integer, scDst, scSrc) As Integer

-    Dim i As Integer

-    Dim s As String

-    Dim Answer As Integer

-    

-    GetGlobalAreaIdx = -1

-    

-    With ThisWorkbook.Worksheets(wks_name)

-        For i = Len(scSrc) To 1 Step -1

-            s = Left(scSrc, i)

-            If InStr(scDst, s) And i > 1 Then

-                Answer = FindVIndex(.Range("A:A"), AreaCount, s)

-                If Answer > 0 Then

-                    GetGlobalAreaIdx = Answer

-                    Exit Function

-                End If

-            End If

-        Next i

-    End With

-End Function

-

-

-Function FindVIndex(Src As Range, AreaCount As Integer, s As String) As Integer

-    Dim l As Long

-    FindVIndex = -1

-    For l = 1 To AreaCount

-        If s = Src.Cells(l, 1) Then

-            FindVIndex = l

-            Exit Function

-        End If

-    Next l

-End Function

-

-

-<<<<<<
-======================
-Constatnts
->>>>>>
-Attribute VB_Name = "Constatnts"

-Option Explicit

-

-Public Const UNKNOWN_AREA As String = "UNKNOWN_AREA"

-Public Const WKS_AREAS_NAME As String = "GlobalList"

-Public Const WKS_PRICE_NAME As String = "OpPrices"

-Public Const WKS_TRAFFIC_NAME As String = "OpTraffic"

-Public Const WKS_FIX_AREAS_NAME As String = "GLFixed"

-Public Const WKS_HOME_NAME As String = "Home"

-

-

-

-Sub AnalyzePrices()

-    AnalyzeOpPricesData WKS_PRICE_NAME, "0.0000"

-End Sub

-

-

-Sub AnalyzeData()

-    AnalyzeOpPricesData WKS_TRAFFIC_NAME, "0."

-End Sub

-

-<<<<<<
-======================
-ForecastPrice
->>>>>>
-Attribute VB_Name = "ForecastPrice"

-Option Explicit

-

-Sub ForecastBlankCodes()

-    Dim ListsRange As Range

-    Dim i As Integer

-    Dim AreaCount As Integer

-    

-    With ThisWorkbook

-        Set ListsRange = .Worksheets(WKS_HOME_NAME).Range("OpList")

-        

-        Dim s As String

-        Dim r As Range

-        

-        AreaCount = 0

-        Set r = .Worksheets(WKS_PRICE_NAME).Range("A3")

-        While r <> ""

-            AreaCount = AreaCount + 1

-            Set r = r.Offset(1, 0)

-        Wend

-

-        For i = 1 To ListsRange.Count

-            s = ListsRange.Cells(i, 1).Value

-            Set r = .Worksheets(WKS_PRICE_NAME).Range("D2:I2").Find(s, LookIn:=xlValues, MatchByte:=True).Offset(1, 0)

-            DoForecast r, AreaCount

-        Next i

-    End With

-End Sub

-

-

-Sub DoForecast(Src As Range, AreaCount As Integer)

-    Dim i As Integer

-    Dim Dst As Range

-    Dim scSrc As String

-    Dim scDst As String

-    

-    Static PriceAvailable As Boolean

-    

-    With ThisWorkbook

-        Set Dst = Src.Offset(1, 0)

-    

-        If Application.WorksheetFunction.IsNumber(Src) = False Then

-            Src = "-"

-            Src.Font.Bold = True

-            Src.Font.ColorIndex = xlColorIndexAutomatic

-        End If

-        

-        For i = 1 To AreaCount

-            PriceAvailable = Application.WorksheetFunction.IsNumber(Dst)

-            

-            If PriceAvailable = True Then

-                Set Src = Dst

-                Set Dst = Src.Offset(1, 0)

-            Else

-                scSrc = .Worksheets(WKS_PRICE_NAME).Range("A:A").Cells(Src.Row, 1)

-                scDst = .Worksheets(WKS_PRICE_NAME).Range("A:A").Cells(Dst.Row, 1)

-                

-                Dim idx As Integer

-                

-                idx = GetGlobalAreaIdx(WKS_AREAS_NAME, AreaCount, scDst, scSrc)

-                If idx <> -1 Then

-                    Set Src = .Worksheets(WKS_PRICE_NAME).Cells(idx, Src.Column)

-                    

-                    Dst = Src

-                    Dst.Font.Bold = False

-                    Dst.Font.ColorIndex = 29 ' magenta

-                    Set Dst = Dst.Offset(1, 0)

-                Else

-                    Dst = "-"

-                    Dst.Font.ColorIndex = xlColorIndexAutomatic

-                    Dst.Font.Bold = True

-                    Set Dst = Dst.Offset(1, 0)

-                End If

-            End If

-        Next i

-    End With

-End Sub

-

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet19
->>>>>>
-Attribute VB_Name = "Sheet19"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet22
->>>>>>
-Attribute VB_Name = "Sheet22"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet23
->>>>>>
-Attribute VB_Name = "Sheet23"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet25
->>>>>>
-Attribute VB_Name = "Sheet25"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Option Explicit

-

-Sub CalcCommonArea()

-    Dim SrcRange As Range

-    Dim DstRange As Range

-    Dim ListsRange As Range

-    

-    With ThisWorkbook

-        Set ListsRange = .Worksheets("Setup").Range("OpList")

-        

-        Dim s As String

-        Dim i As Integer

-        

-        For i = 1 To ListsRange.Count

-            s = ListsRange.Cells(i, 1).Value

-            Set DstRange = .Worksheets("Common").Range("A3")

-            Set SrcRange = .Worksheets(s).Range("A3")

-        

-            AddOpArea DstRange, SrcRange, i

-        Next i

-        Set SrcRange = .Worksheets("Common").Range("A3")

-        

-        Dim AreaCount As Integer

-        AreaCount = 0

-        

-        While SrcRange <> ""

-            AreaCount = AreaCount + 1

-            Set SrcRange = SrcRange.Offset(1, 0)

-        Wend

-        

-        For i = 1 To ListsRange.Count

-            s = ListsRange.Cells(i, 1).Value

-            DoOptimize s, AreaCount

-        Next i

-    End With

-End Sub

-

-Sub AddOpArea(Dst As Range, Src As Range, index As Integer)

-    While Src <> ""

-        If Dst > Src Then

-            Dst.Worksheet.Range(Dst, Dst.Offset(0, 50)).Insert Shift:=xlShiftDown

-            Set Dst = Dst.Offset(-1, 0)

-        End If

-        If Dst = "" Then

-            Dst = Src

-            Dst.Offset(0, 1) = Src.Offset(0, 1)

-            Dst.Offset(0, 2) = Src.Offset(0, 2)

-        End If

-        If Dst = Src Then

-            Dst.Offset(0, 2 + index) = Src.Offset(0, 3)

-            Set Src = Src.Offset(1, 0)

-        End If

-        Set Dst = Dst.Offset(1, 0)

-    Wend

-End Sub

-

-Sub DoOptimize(SrcName As String, AreaCount As Integer)

-    Dim i As Integer

-    Dim Src As Range

-    Dim Dst As Range

-    Dim scSrc As String

-    Dim scDst As String

-    

-    Static PriceAvailable As Boolean

-    

-    With ThisWorkbook

-        Set Src = .Worksheets("Common").Range(SrcName).Cells(1, 1)

-        Set Dst = Src.Offset(1, 0)

-    

-        For i = 1 To AreaCount

-            PriceAvailable = Application.WorksheetFunction.IsNumber(Dst)

-            

-            If PriceAvailable = True Then

-                Set Src = Dst

-                Set Dst = Src.Offset(1, 0)

-            Else

-                scSrc = .Worksheets("Common").Range("A:A").Cells(Src.Row, 1)

-                scDst = .Worksheets("Common").Range("A:A").Cells(Dst.Row, 1)

-                

-                Dim idx As Integer

-                

-                idx = GetGlobalAreaIdx(scDst, scSrc)

-                

-                Set Src = .Worksheets("Common").Range(SrcName).Cells(idx, 1)

-                

-                Dst = Src

-                Set Dst = Dst.Offset(1, 0)

-            End If

-        Next i

-    End With

-End Sub

-

-Function GetGlobalAreaIdx(scDst, scSrc) As Integer

-    Dim i As Integer

-    Dim s As String

-    Dim Answer As Integer

-    

-    GetGlobalAreaIdx = -1

-    

-    With ThisWorkbook.Worksheets("Common")

-        For i = Len(scSrc) To 1 Step -1

-            s = Left(scSrc, i)

-            If InStr(scDst, s) And i > 1 Then

-                Answer = FindVIndex(.Range("sCode"), s)

-                If Answer > 0 Then

-                    GetGlobalAreaIdx = Answer

-                    Exit Function

-                End If

-            End If

-        Next i

-    End With

-End Function

-

-

-Function FindVIndex(Src As Range, s As String) As Integer

-    Dim l As Long

-    FindVIndex = -1

-    For l = 1 To Src.Count

-        If s = Src.Cells(l, 1) Then

-            FindVIndex = l

-            Exit Function

-        End If

-    Next l

-End Function

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Option Explicit

-

-Type PriceRecord

-    Aria As String

-    Description As String

-    Description2 As String

-    Price As Double

-End Type

-

-Dim SourcePrData() As PriceRecord

-

-Sub a()

-    ReDim SourcePrData(1 To 5)

-    Erase SourcePrData

-End Sub

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-AppEv_ISP
->>>>>>
-Attribute VB_Name = "AppEv_ISP"

-

-

-Sub dummy()

-Attribute dummy.VB_ProcData.VB_Invoke_Func = " \n14"

-

-End Sub

-

-Sub Set_Default_Hosting()

-Attribute Set_Default_Hosting.VB_ProcData.VB_Invoke_Func = " \n14"

-    With ThisWorkbook.Worksheets("Prices.Hosting")

-        .Range("C5") = 1

-        .Range("c18") = 1

-        .Range("c23") = 1

-    End With

-End Sub

-

-Sub Set_Default_Intel()

-Attribute Set_Default_Intel.VB_ProcData.VB_Invoke_Func = " \n14"

-    With ThisWorkbook.Worksheets("Prices.Intel")

-        If .Range("B3") = 1 Then ' ISP 1100

-            .Range("b9") = 1

-            .Range("f15") = 1

-            .Range("b21") = 1

-            .Range("b30") = 1

-            .Range("b37") = 1

-            .Range("b45") = 1

-            .Range("b51") = 1

-            .Range("b57") = 1

-        Else

-            .Range("f9") = 1

-            .Range("f15") = 1

-            .Range("f21") = 1

-            .Range("f30") = 1

-            .Range("f37") = 1

-            .Range("f45") = 1

-            .Range("f51") = 1

-            .Range("f57") = 1

-        End If

-    End With

-

-End Sub

-

-Sub evISP_ModelChange()

-Attribute evISP_ModelChange.VB_ProcData.VB_Invoke_Func = " \n14"

-    SetCPUList

-    SetRAMList

-    SetHDDList

-    SetADDList

-    Set_Default_Intel

-End Sub

-

-Sub SetCPUList()

-Attribute SetCPUList.VB_ProcData.VB_Invoke_Func = " \n14"

-    Dim NewCbxRange, NewCbxIndex As String

-    With ThisWorkbook.Worksheets("Prices.Intel")

-        If .Range("B3") = 1 Then ' ISP 1100

-            NewCbxRange = .Name & "!" & .Range("b10:b12").Address

-            NewCbxIndex = .Name & "!" & .Range("b9").Address

-        Else

-            NewCbxRange = .Name & "!" & .Range("f10:f11").Address

-            NewCbxIndex = .Name & "!" & .Range("f9").Address

-        End If

-    End With

-    With ThisWorkbook.Worksheets("Intel-ISP").Shapes("ISP_CPU")

-        .ControlFormat.ListFillRange = NewCbxRange

-        .ControlFormat.LinkedCell = NewCbxIndex

-    End With

-    With ThisWorkbook.Worksheets("Prices.Intel")

-        If .Range("B3") = 1 Then ' ISP 1100

-            NewCbxRange = .Name & "!" & .Range("b16:b16").Address

-            NewCbxIndex = .Name & "!" & .Range("b15").Address

-        Else

-            NewCbxRange = .Name & "!" & .Range("f16:f17").Address

-            NewCbxIndex = .Name & "!" & .Range("f15").Address

-        End If

-    End With

-    With ThisWorkbook.Worksheets("Intel-ISP").Shapes("ISP_CPU_CNT")

-        .ControlFormat.ListFillRange = NewCbxRange

-        .ControlFormat.LinkedCell = NewCbxIndex

-    End With

-End Sub

-

-Sub SetRAMList()

-Attribute SetRAMList.VB_ProcData.VB_Invoke_Func = " \n14"

-    Dim NewCbxRange, NewCbxIndex As String

-    With ThisWorkbook.Worksheets("Prices.Intel")

-        If .Range("B3") = 1 Then ' ISP 1100

-            NewCbxRange = .Name & "!" & .Range("b22:b26").Address

-            NewCbxIndex = .Name & "!" & .Range("b21").Address

-        Else

-            NewCbxRange = .Name & "!" & .Range("f22:f26").Address

-            NewCbxIndex = .Name & "!" & .Range("f21").Address

-        End If

-    End With

-    With ThisWorkbook.Worksheets("Intel-ISP").Shapes("ISP_RAM")

-        .ControlFormat.ListFillRange = NewCbxRange

-        .ControlFormat.LinkedCell = NewCbxIndex

-    End With

-End Sub

-

-Sub SetHDDList()

-Attribute SetHDDList.VB_ProcData.VB_Invoke_Func = " \n14"

-    Dim NewCbxRange, NewCbxIndex As String

-    With ThisWorkbook.Worksheets("Prices.Intel")

-        If .Range("B3") = 1 Then ' ISP 1100

-            NewCbxRange = .Name & "!" & .Range("b31:b33").Address

-            NewCbxIndex = .Name & "!" & .Range("b30").Address

-        Else

-            NewCbxRange = .Name & "!" & .Range("f31:f33").Address

-            NewCbxIndex = .Name & "!" & .Range("f30").Address

-        End If

-    End With

-    With ThisWorkbook.Worksheets("Intel-ISP").Shapes("ISP_HDD")

-        .ControlFormat.ListFillRange = NewCbxRange

-        .ControlFormat.LinkedCell = NewCbxIndex

-    End With

-    With ThisWorkbook.Worksheets("Prices.Intel")

-        If .Range("B3") = 1 Then ' ISP 1100

-            NewCbxRange = .Name & "!" & .Range("b38:b39").Address

-            NewCbxIndex = .Name & "!" & .Range("b37").Address

-        Else

-            NewCbxRange = .Name & "!" & .Range("f38:f41").Address

-            NewCbxIndex = .Name & "!" & .Range("f37").Address

-        End If

-    End With

-    With ThisWorkbook.Worksheets("Intel-ISP").Shapes("ISP_HDD_CNT")

-        .ControlFormat.ListFillRange = NewCbxRange

-        .ControlFormat.LinkedCell = NewCbxIndex

-    End With

-End Sub

-

-Sub SetADDList()

-Attribute SetADDList.VB_ProcData.VB_Invoke_Func = " \n14"

-    Dim NewCbxRange, NewCbxIndex As String

-    With ThisWorkbook.Worksheets("Prices.Intel")

-        If .Range("B3") = 1 Then ' ISP 1100

-            NewCbxRange = .Name & "!" & .Range("b46:b47").Address

-            NewCbxIndex = .Name & "!" & .Range("b45").Address

-        Else

-            NewCbxRange = .Name & "!" & .Range("f46:f47").Address

-            NewCbxIndex = .Name & "!" & .Range("f45").Address

-        End If

-    End With

-    With ThisWorkbook.Worksheets("Intel-ISP").Shapes("ISP_CDRW")

-        .ControlFormat.ListFillRange = NewCbxRange

-        .ControlFormat.LinkedCell = NewCbxIndex

-    End With

-    With ThisWorkbook.Worksheets("Prices.Intel")

-        If .Range("B3") = 1 Then ' ISP 1100

-            NewCbxRange = .Name & "!" & .Range("b52:b53").Address

-            NewCbxIndex = .Name & "!" & .Range("b51").Address

-        Else

-            NewCbxRange = .Name & "!" & .Range("f52:f52").Address

-            NewCbxIndex = .Name & "!" & .Range("f51").Address

-        End If

-    End With

-    With ThisWorkbook.Worksheets("Intel-ISP").Shapes("ISP_SVGA")

-        .ControlFormat.ListFillRange = NewCbxRange

-        .ControlFormat.LinkedCell = NewCbxIndex

-    End With

-    With ThisWorkbook.Worksheets("Prices.Intel")

-        If .Range("B3") = 1 Then ' ISP 1100

-            NewCbxRange = .Name & "!" & .Range("b58:b59").Address

-            NewCbxIndex = .Name & "!" & .Range("b57").Address

-        Else

-            NewCbxRange = .Name & "!" & .Range("f58:f59").Address

-            NewCbxIndex = .Name & "!" & .Range("f57").Address

-        End If

-    End With

-    With ThisWorkbook.Worksheets("Intel-ISP").Shapes("ISP_ETH2")

-        .ControlFormat.ListFillRange = NewCbxRange

-        .ControlFormat.LinkedCell = NewCbxIndex

-    End With

-End Sub

-

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-AppEv_ISP1100
->>>>>>
-Attribute VB_Name = "AppEv_ISP1100"

-Const PRICES_ISP1100 As String = "Prices.ISP1100"

-Const CALC_INTEL As String = "Calc.Intel"

-

-Sub dummy()

-Attribute dummy.VB_ProcData.VB_Invoke_Func = " \n14"

-

-End Sub

-

-

-

-Sub Set_Default_Intel_1100()

-Attribute Set_Default_Intel_1100.VB_ProcData.VB_Invoke_Func = " \n14"

-    With ThisWorkbook.Worksheets(PRICES_ISP1100)

-        .Range("b6") = 1

-        .Range("b11") = 1

-        .Range("f17") = 1

-        .Range("b23") = 1

-        .Range("b32") = 1

-        .Range("b39") = 1

-        .Range("b47") = 1

-        .Range("b52") = 1

-        .Range("b58") = 1

-        .Range("b64") = 1

-    End With

-End Sub

-<<<<<<
-======================
-AppEv_Hosting
->>>>>>
-Attribute VB_Name = "AppEv_Hosting"

-Const PRICES_HOSTING As String = "Prices.Hosting"

-

-Sub Set_Default_Hosting()

-Attribute Set_Default_Hosting.VB_ProcData.VB_Invoke_Func = " \n14"

-    With ThisWorkbook.Worksheets(PRICES_HOSTING)

-        .Range("C5") = 1

-        .Range("c18") = 1

-        .Range("c23") = 1

-    End With

-End Sub

-<<<<<<
-======================
-AppEv_ISP2150G
->>>>>>
-Attribute VB_Name = "AppEv_ISP2150G"

-Sub Set_Default_Intel_2150()

-Attribute Set_Default_Intel_2150.VB_ProcData.VB_Invoke_Func = " \n14"

-    With ThisWorkbook.Worksheets(PRICES_INTEL)

-        If .Range("B3") = 1 Then ' ISP 1100

-            .Range("b9") = 1

-            .Range("f15") = 1

-            .Range("b21") = 1

-            .Range("b30") = 1

-            .Range("b37") = 1

-            .Range("b45") = 1

-            .Range("b51") = 1

-            .Range("b57") = 1

-            .Range("j15") = 1

-        Else

-            .Range("f9") = 1

-            .Range("f15") = 1

-            .Range("f21") = 1

-            .Range("f30") = 1

-            .Range("f37") = 1

-            .Range("f45") = 1

-            .Range("f51") = 1

-            .Range("f57") = 1

-            .Range("j15") = 1

-        End If

-    End With

-

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag lengthProject Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Private Sub Workbook_Open()

-'    MsgBox "Для заверщения работы демонстрационной модели используйте желый баннер 'CLOSE Demo' в правом верхнем углу любой страницы."

-'    Application.WindowState = xlMaximized

-'    SetEnvironment ThisWorkbook

-    GotoHome

-End Sub

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-AppEvents
->>>>>>
-Attribute VB_Name = "AppEvents"

-Sub dummy()

-

-End Sub

-

-Sub evRaQModelChange()

-    Dim GroupIdx, LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewCbxIndex As String

-    With ThisWorkbook.Worksheets("Data")

-        If .Range("B18") = 1 Then ' RaQ 2

-            NewCbxRange = .Name & "!" & .Range("E19:E21").Address

-            NewCbxIndex = .Name & "!" & .Range("E18").Address

-        Else

-            NewCbxRange = .Name & "!" & .Range("H19:H23").Address

-            NewCbxIndex = .Name & "!" & .Range("H18").Address

-        End If

-    End With

-    With ThisWorkbook.Worksheets("Dedication-RAQ").Shapes("RaQ-RAM")

-        .ControlFormat.ListFillRange = NewCbxRange

-        .ControlFormat.LinkedCell = NewCbxIndex

-    End With

-End Sub

-

-

-Sub SetDefColo()

-    With ThisWorkbook.Worksheets("Colocation")

-        .Shapes("ColoSize").ControlFormat.ListIndex = 3

-        .Shapes("ColoIP").ControlFormat.ListIndex = 1

-        .Shapes("ColoBandwith").ControlFormat.ListIndex = 1

-        .Shapes("ColoEthType").ControlFormat.ListIndex = 1

-        .Shapes("Colo-PriDNS").ControlFormat.ListIndex = 1

-        .Shapes("Colo-SecDNS").ControlFormat.ListIndex = 1

-        .Shapes("ColoReset").ControlFormat.ListIndex = 1

-    End With

-End Sub

-

-Sub SetDefRaQ()

-    With ThisWorkbook.Worksheets("Dedication-RaQ")

-        .Shapes("RaQ-CPU").ControlFormat.ListIndex = 2

-        .Shapes("RaQ-RAM").ControlFormat.ListIndex = 1

-        .Shapes("RaQ-HDD").ControlFormat.ListIndex = 1

-        .Shapes("RaQ-IP").ControlFormat.ListIndex = 1

-        .Shapes("RaQ-Bandwith").ControlFormat.ListIndex = 1

-        .Shapes("RaQ-PriDNS").ControlFormat.ListIndex = 1

-        .Shapes("RaQ-SecDNS").ControlFormat.ListIndex = 1

-        .Shapes("RaQReset").ControlFormat.ListIndex = 1

-    End With

-End Sub

-

-Sub SetDefSUN()

-    With ThisWorkbook.Worksheets("Dedication-SUN")

-        .Shapes("Sun-CPU").ControlFormat.ListIndex = 2

-        .Shapes("Sun-RAM").ControlFormat.ListIndex = 1

-        .Shapes("Sun-HDD").ControlFormat.ListIndex = 1

-        .Shapes("Sun-IP").ControlFormat.ListIndex = 1

-        .Shapes("Sun-Bandwith").ControlFormat.ListIndex = 1

-        .Shapes("Sun-PriDNS").ControlFormat.ListIndex = 1

-        .Shapes("Sun-SecDNS").ControlFormat.ListIndex = 1

-        .Shapes("SunReset").ControlFormat.ListIndex = 1

-    End With

-End Sub

-

-Sub SetDefHosting()

-    With ThisWorkbook.Worksheets("Hosting")

-        .Shapes("HostingPlane").ControlFormat.ListIndex = 3

-        .Shapes("HostingHDD").ControlFormat.ListIndex = 1

-    End With

-End Sub

-

-Sub SetDefMail()

-    With ThisWorkbook.Worksheets("CorpMail")

-        .Shapes("MailPlane").ControlFormat.ListIndex = 3

-        .Shapes("MailSize").ControlFormat.ListIndex = 2

-        .Shapes("MailDesign").ControlFormat.ListIndex = 1

-        .Shapes("Mail-PriDNS").ControlFormat.ListIndex = 1

-        .Shapes("Mail-SecDNS").ControlFormat.ListIndex = 1

-    End With

-End Sub

-

-Sub GoToOrderColo()

-    ThisWorkbook.Sheets("Order-Colo").Select

-    LocalUp

-End Sub

-

-Sub GoToCalcColo()

-    ThisWorkbook.Sheets("Colocation").Select

-    LocalUp

-End Sub

-

-Sub GoToOrderRaQ()

-    ThisWorkbook.Sheets("Order-RaQ").Select

-    LocalUp

-End Sub

-

-Sub GoToCalcRaQ()

-    ThisWorkbook.Sheets("Dedication-RAQ").Select

-    LocalUp

-End Sub

-

-Sub GoToOrderSun()

-    ThisWorkbook.Sheets("Order-SUN").Select

-    LocalUp

-End Sub

-

-Sub GoToCalcSun()

-    ThisWorkbook.Sheets("Dedication-SUN").Select

-    LocalUp

-End Sub

-

-Sub GoToOrderHosting()

-    ThisWorkbook.Sheets("Order-Hosting").Select

-    LocalUp

-End Sub

-

-Sub GoToCalcHosting()

-    ThisWorkbook.Sheets("Hosting").Select

-    LocalUp

-End Sub

-

-Sub GoToOrderMail()

-    ThisWorkbook.Sheets("Order-Mail").Select

-    LocalUp

-End Sub

-

-Sub GoToCalcMail()

-    ThisWorkbook.Sheets("CorpMail").Select

-    LocalUp

-End Sub

-

-Sub GoToOrderDomain()

-    ThisWorkbook.Sheets("Order-Mail").Select

-    LocalUp

-End Sub

-

-Sub GoToCalcDomain()

-    ThisWorkbook.Sheets("CorpMail").Select

-    LocalUp

-End Sub

-

-Sub GoToThanks()

-    ThisWorkbook.Sheets("Ok").Select

-    LocalUp

-End Sub

-

-Sub GotoHome()

-    ThisWorkbook.Sheets("LocalHome").Select

-    LocalUp

-End Sub

-

-Sub LocalUp()

-    Range("A1").Select

-End Sub

-

-Sub CloseDemo()

-'    RestoreEnvironment wb:=ThisWorkbook

-'    ThisWorkbook.Close SaveChanges:=False

-End Sub

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet61
->>>>>>
-Attribute VB_Name = "Sheet61"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet611
->>>>>>
-Attribute VB_Name = "Sheet611"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6111
->>>>>>
-Attribute VB_Name = "Sheet6111"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet61111
->>>>>>
-Attribute VB_Name = "Sheet61111"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-AppState
->>>>>>
-Attribute VB_Name = "AppState"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const PROGRAM_NAME = "E-Commerce ready Web Interface"

-Public Const common_pwd As Long = 31415926

-

-

-Sub SetEnvironment(wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    With Application

-        .Caption = PROGRAM_NAME

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .GetState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-    End With

-    With wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets("LocalHome").Select

-    End With

-'    CreateCommandBar theApp:=wb.Application

-End Sub

-

-Sub RestoreEnvironment(wb As Workbook)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Application.ScreenUpdating = False

-    With wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                     cWindow.DisplayHeadings = True

-                Next

-            End If

-        Next

-        .Worksheets("LocalHome").Select

-        With mobjAppState

-            .RestoreState

-        End With

-    End With

-'    DeleteCommandBar theApp:=Application

-End Sub

-

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub GetState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.Count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.Name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars("Worksheet Menu Bar").Visible = False

-End Sub

-

-

-Public Sub RestoreState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars("Worksheet Menu Bar").Visible = True

-End Sub

-

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Function ChkIncrease(aRange As Range) As Integer

-    Dim res As Integer

-    Dim areaCount As Long

-    areaCount = aRange.Count

-    res = 0

-    If areaCount > 1 Then

-        For i = 1 To areaCount - 1

-            If aRange(i).Value <= aRange(i + 1).Value Then

-                res = res + 1

-            End If

-        Next i

-    Else

-        res = -1

-    End If

-    

-    If (res = areaCount - 1) Then

-        ChkIncrease = 1

-    Else

-        ChkIncrease = 0

-    End If

-End Function

-

-Function ChkDecrease(aRange As Range) As Integer

-    Dim res As Integer

-    Dim areaCount As Long

-    areaCount = aRange.Count

-    res = 0

-    If areaCount > 1 Then

-        For i = 1 To areaCount - 1

-            If aRange(i).Value >= aRange(i + 1).Value Then

-                res = res + 1

-            End If

-        Next i

-    Else

-        res = -1

-    End If

-    

-    If (res = areaCount - 1) Then

-        ChkDecrease = 1

-    Else

-        ChkDecrease = 0

-    End If

-End Function

-

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Private Sub Workbook_Open()

-'    MsgBox "Для заверщения работы демонстрационной модели используйте желый баннер 'CLOSE Demo' в правом верхнем углу любой страницы."

-'    Application.WindowState = xlMaximized

-'    SetEnvironment ThisWorkbook

-    GotoHome

-End Sub

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-AppEvents
->>>>>>
-Attribute VB_Name = "AppEvents"

-Sub dummy()

-

-End Sub

-

-Sub evRaQModelChange()

-    Dim GroupIdx, LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewCbxIndex As String

-    With ThisWorkbook.Worksheets("Data")

-        If .Range("B18") = 1 Then ' RaQ 2

-            NewCbxRange = .Name & "!" & .Range("E19:E21").Address

-            NewCbxIndex = .Name & "!" & .Range("E18").Address

-        Else

-            NewCbxRange = .Name & "!" & .Range("H19:H23").Address

-            NewCbxIndex = .Name & "!" & .Range("H18").Address

-        End If

-    End With

-    With ThisWorkbook.Worksheets("Dedication-RAQ").Shapes("RaQ-RAM")

-        .ControlFormat.ListFillRange = NewCbxRange

-        .ControlFormat.LinkedCell = NewCbxIndex

-    End With

-End Sub

-

-

-Sub SetDefColo()

-    With ThisWorkbook.Worksheets("Colocation")

-        .Shapes("ColoSize").ControlFormat.ListIndex = 3

-        .Shapes("ColoIP").ControlFormat.ListIndex = 1

-        .Shapes("ColoBandwith").ControlFormat.ListIndex = 1

-        .Shapes("ColoEthType").ControlFormat.ListIndex = 1

-        .Shapes("Colo-PriDNS").ControlFormat.ListIndex = 1

-        .Shapes("Colo-SecDNS").ControlFormat.ListIndex = 1

-        .Shapes("ColoReset").ControlFormat.ListIndex = 1

-    End With

-End Sub

-

-Sub SetDefRaQ()

-    With ThisWorkbook.Worksheets("Dedication-RaQ")

-        .Shapes("RaQ-CPU").ControlFormat.ListIndex = 2

-        .Shapes("RaQ-RAM").ControlFormat.ListIndex = 1

-        .Shapes("RaQ-HDD").ControlFormat.ListIndex = 1

-        .Shapes("RaQ-IP").ControlFormat.ListIndex = 1

-        .Shapes("RaQ-Bandwith").ControlFormat.ListIndex = 1

-        .Shapes("RaQ-PriDNS").ControlFormat.ListIndex = 1

-        .Shapes("RaQ-SecDNS").ControlFormat.ListIndex = 1

-        .Shapes("RaQReset").ControlFormat.ListIndex = 1

-    End With

-End Sub

-

-Sub SetDefSUN()

-    With ThisWorkbook.Worksheets("Dedication-SUN")

-        .Shapes("Sun-CPU").ControlFormat.ListIndex = 2

-        .Shapes("Sun-RAM").ControlFormat.ListIndex = 1

-        .Shapes("Sun-HDD").ControlFormat.ListIndex = 1

-        .Shapes("Sun-IP").ControlFormat.ListIndex = 1

-        .Shapes("Sun-Bandwith").ControlFormat.ListIndex = 1

-        .Shapes("Sun-PriDNS").ControlFormat.ListIndex = 1

-        .Shapes("Sun-SecDNS").ControlFormat.ListIndex = 1

-        .Shapes("SunReset").ControlFormat.ListIndex = 1

-    End With

-End Sub

-

-Sub SetDefHosting()

-    With ThisWorkbook.Worksheets("Hosting")

-        .Shapes("HostingPlane").ControlFormat.ListIndex = 3

-        .Shapes("HostingHDD").ControlFormat.ListIndex = 1

-    End With

-End Sub

-

-Sub SetDefMail()

-    With ThisWorkbook.Worksheets("CorpMail")

-        .Shapes("MailPlane").ControlFormat.ListIndex = 3

-        .Shapes("MailSize").ControlFormat.ListIndex = 2

-        .Shapes("MailDesign").ControlFormat.ListIndex = 1

-        .Shapes("Mail-PriDNS").ControlFormat.ListIndex = 1

-        .Shapes("Mail-SecDNS").ControlFormat.ListIndex = 1

-    End With

-End Sub

-

-Sub GoToOrderColo()

-    ThisWorkbook.Sheets("Order-Colo").Select

-    LocalUp

-End Sub

-

-Sub GoToCalcColo()

-    ThisWorkbook.Sheets("Colocation").Select

-    LocalUp

-End Sub

-

-Sub GoToOrderRaQ()

-    ThisWorkbook.Sheets("Order-RaQ").Select

-    LocalUp

-End Sub

-

-Sub GoToCalcRaQ()

-    ThisWorkbook.Sheets("Dedication-RAQ").Select

-    LocalUp

-End Sub

-

-Sub GoToOrderSun()

-    ThisWorkbook.Sheets("Order-SUN").Select

-    LocalUp

-End Sub

-

-Sub GoToCalcSun()

-    ThisWorkbook.Sheets("Dedication-SUN").Select

-    LocalUp

-End Sub

-

-Sub GoToOrderHosting()

-    ThisWorkbook.Sheets("Order-Hosting").Select

-    LocalUp

-End Sub

-

-Sub GoToCalcHosting()

-    ThisWorkbook.Sheets("Hosting").Select

-    LocalUp

-End Sub

-

-Sub GoToOrderMail()

-    ThisWorkbook.Sheets("Order-Mail").Select

-    LocalUp

-End Sub

-

-Sub GoToCalcMail()

-    ThisWorkbook.Sheets("CorpMail").Select

-    LocalUp

-End Sub

-

-Sub GoToOrderDomain()

-    ThisWorkbook.Sheets("Order-Mail").Select

-    LocalUp

-End Sub

-

-Sub GoToCalcDomain()

-    ThisWorkbook.Sheets("CorpMail").Select

-    LocalUp

-End Sub

-

-Sub GoToThanks()

-    ThisWorkbook.Sheets("Ok").Select

-    LocalUp

-End Sub

-

-Sub GotoHome()

-    ThisWorkbook.Sheets("LocalHome").Select

-    LocalUp

-End Sub

-

-Sub LocalUp()

-    Range("A1").Select

-End Sub

-

-Sub CloseDemo()

-'    RestoreEnvironment wb:=ThisWorkbook

-'    ThisWorkbook.Close SaveChanges:=False

-End Sub

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet61
->>>>>>
-Attribute VB_Name = "Sheet61"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet611
->>>>>>
-Attribute VB_Name = "Sheet611"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6111
->>>>>>
-Attribute VB_Name = "Sheet6111"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet61111
->>>>>>
-Attribute VB_Name = "Sheet61111"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-AppState
->>>>>>
-Attribute VB_Name = "AppState"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const PROGRAM_NAME = "E-Commerce ready Web Interface"

-Public Const common_pwd As Long = 31415926

-

-

-Sub SetEnvironment(wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    With Application

-        .Caption = PROGRAM_NAME

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .GetState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-    End With

-    With wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets("LocalHome").Select

-    End With

-'    CreateCommandBar theApp:=wb.Application

-End Sub

-

-Sub RestoreEnvironment(wb As Workbook)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Application.ScreenUpdating = False

-    With wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                     cWindow.DisplayHeadings = True

-                Next

-            End If

-        Next

-        .Worksheets("LocalHome").Select

-        With mobjAppState

-            .RestoreState

-        End With

-    End With

-'    DeleteCommandBar theApp:=Application

-End Sub

-

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub GetState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.Count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.Name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars("Worksheet Menu Bar").Visible = False

-End Sub

-

-

-Public Sub RestoreState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars("Worksheet Menu Bar").Visible = True

-End Sub

-

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Option Explicit

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Option Explicit

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag lengthProject Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag lengthProject Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-<<<<<<
-Project Name : 'Denmark_method'
-Quirk - duff tag length======================
-MGetWebData
->>>>>>
-Attribute VB_Name = "MGetWebData"

-Option Explicit

-

-Const DATE_STAMP_OFFSET = PROJECT_IDX + 1

-Const TIME_STAMP_OFFSET = PROJECT_IDX + 4

-Const DATE_TIME_STAMP_SIZE = 5

-

-Dim mobjAppRunEnable As New cEnableRun

-

-Const QueryDataName As String = "ExternalDenmarkData"

-

-Function UpdateHistory(wb As Workbook) As Boolean

-    Dim DestRangeName As String

-    Dim ResultLength As Integer

-    Dim QryPathStr As String

-    Dim Location As Range

-    Dim denWindow As Integer

-    Dim IsIntraday As Boolean

-    Dim CalcNextTime As Boolean

-        

-    UpdateHistory = False

-    QryPathStr = GetQryPath(wb)

-    With wb

-        .Application.ScreenUpdating = False

-        With .Worksheets(VAR_SHEET)

-            DestRangeName = .Range("DEN_SYMBOL")

-            CalcNextTime = .Range("BOOL_NEXT_TIME")

-            denWindow = .Range("DEN_WINDOW") + 1

-            If CalcNextTime Then

-                denWindow = denWindow + 1

-            End If

-            IsIntraday = IsNumeric(.Range("DEN_TIME"))

-        End With

-        With .Worksheets(RAW_DATA_SHEET)

-            .Range(PRICE_TABLE) = DestRangeName

-            'Clear table include temp area

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW - 1, RAW_DATA_RANGE_COL - 1), _

-                .Cells(65535, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-            ).ClearContents

-            Set Location = .Range(RAW_DATA_RANGE).Offset(-1, 0)

-            If Not QryExist(Location, QueryDataName) Then

-                QryCreate Location, QueryDataName, QryPathStr

-            Else

-                QryRefresh Location, QueryDataName, QryPathStr

-            End If

-            With Location.Worksheet.QueryTables(QueryDataName)

-                DestRangeName = .ResultRange.name.RefersTo

-                ResultLength = .ResultRange.count

-            End With

-    

-    '        .Parent.Application.DisplayAlerts = False

-            

-            .Range(DestRangeName).TextToColumns _

-                Destination:=.Range(DestRangeName), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=True, _

-                Semicolon:=True, _

-                Comma:=True, _

-                Space:=False, _

-                Other:=False, _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 1), _

-                                Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1))

-            

-    '        .Parent.Application.DisplayAlerts = True

-            Dim i, j, row_idx As Integer

-            Dim CurrentDate As String

-            Dim RawData As Range

-            

-            Set RawData = .Range(RAW_DATA_RANGE)

-            row_idx = 0

-            With RawData

-                CurrentDate = .Value

-                For i = 1 To ResultLength

-                    If Not IsIntraday And CurrentDate = .Offset(i, DATE_IDX).Value Then

-                        ' skip virtual prices

-                        If (.Offset(i, VOLUME_IDX) > MIN_PRICE_VALUE) Then

-                            If .Offset(row_idx, HIGH_IDX).Value < .Offset(i, HIGH_IDX).Value Then

-                                .Offset(row_idx, HIGH_IDX).Value = .Offset(i, HIGH_IDX).Value

-                            End If

-                            If .Offset(row_idx, LOW_IDX).Value > .Offset(i, LOW_IDX).Value Then

-                                .Offset(row_idx, LOW_IDX).Value = .Offset(i, LOW_IDX).Value

-                            End If

-                            .Offset(row_idx, VOLUME_IDX).Value = _

-                                .Offset(row_idx, VOLUME_IDX).Value + .Offset(i, VOLUME_IDX).Value

-                            .Offset(row_idx, TIME_IDX).Value = .Offset(i, TIME_IDX).Value

-                            .Offset(row_idx, CLOSE_IDX).Value = .Offset(i, CLOSE_IDX).Value

-                        End If

-                    Else

-                        ' skip virtual prices

-                        If (.Offset(row_idx, VOLUME_IDX) > MIN_PRICE_VALUE) Then

-                            row_idx = row_idx + 1

-                        End If

-                        For j = DATE_IDX To VOLUME_IDX

-                            .Offset(row_idx, j) = .Offset(i, j)

-                        Next j

-                        CurrentDate = .Offset(i, DATE_IDX)

-                    End If

-                Next i

-            End With ' RawData

-            ' Clear unused Cells

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(65536, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-            ).ClearContents

-            

-            If row_idx > denWindow Then

-                row_idx = row_idx - denWindow

-                .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-                ).delete xlShiftUp

-            Else

-                Exit Function

-            End If

-            

-            row_idx = denWindow + 1

-            

-            Set Location = .Range( _

-                .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_IDX) _

-            )

-            

-            Location.TextToColumns _

-                Destination:=Location.Offset(0, DATE_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:="/", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2))

-            

-            Location.Offset(0, TIME_IDX).TextToColumns _

-                Destination:=Location.Offset(0, TIME_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:=":", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2))

-            

-            ' Check estimation date

-            

-            Dim end_date, end_time As Date

-            Dim year, month, day As Integer

-            Dim hour, minute As Integer

-            Dim next_time_exist As Boolean

-            

-            year = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 3)

-            month = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 2)

-            day = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 1)

-            hour = Location.Cells(denWindow - 1, TIME_STAMP_OFFSET + 1)

-            minute = Location.Cells(denWindow - 1, TIME_STAMP_OFFSET + 2)

-            

-            next_time_exist = day + month + year <> 0

-            

-            If next_time_exist Then

-                end_date = DateSerial(year, month, day)

-                end_time = TimeSerial(hour, minute, 0)

-                mobjAppRunEnable.EnableRun ESTIMATION_DATE, end_date

-            End If

-             

-            row_idx = 0

-            Dim temp_str As String

-                    

-            If IsIntraday Then

-                Do While IsEmpty(Location.Cells(1 + row_idx, 1 + DATE_IDX)) = False

-                       temp_str = Location.Cells(1 + row_idx, 1 + PROJECT_IDX + 1)

-                       temp_str = temp_str & "/"

-                       temp_str = temp_str & Location.Cells(1 + row_idx, 1 + PROJECT_IDX + 2)

-                       temp_str = temp_str & "-"

-                       temp_str = temp_str & Location.Cells(1 + row_idx, 1 + TIME_IDX)

-                       Location.Cells(1 + row_idx, DATE_IDX) = temp_str

-                       row_idx = row_idx + 1

-                Loop

-                row_idx = row_idx - 1

-                Dim condition As Boolean

-                condition = Not CalcNextTime And next_time_exist And end_date = DateValue(Now) And end_time > TimeValue(Now)

-                If condition Then

-                    .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL - 1), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-                    ).delete xlShiftUp

-                End If

-            Else

-                Do While IsEmpty(Location.Cells(1 + row_idx, 1 + DATE_IDX)) = False

-                       temp_str = "'" & Location.Cells(1 + row_idx, 1)

-                       Location.Cells(1 + row_idx, DATE_IDX) = temp_str

-                       row_idx = row_idx + 1

-                Loop

-                row_idx = row_idx - 1

-                condition = Not CalcNextTime And next_time_exist And end_date = DateValue(Now) And TimeValue(Now) < TimeSerial(18, 0, 0)

-                If condition Then

-                    .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL - 1), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-                    ).delete xlShiftUp

-                End If

-            End If

-        End With ' .Worksheets(RAW_DATA_SHEET)

-    End With ' wb

-    UpdateHistory = True

-End Function

-

-Private Function GetQryPath(wb As Workbook) As String

-    Dim QryPathStr As String

-    Dim IsIntradai As Boolean

-    Dim DayCount As Integer

-    With wb.Worksheets(VAR_SHEET)

-        QryPathStr = "URL;http://online.rbc.ru/cgi-bin/online/nph-single-old.cgi?"

-        QryPathStr = QryPathStr & "ticker=" & .Range("DEN_SYMBOL")

-        QryPathStr = QryPathStr & "&source=" & .Range("DEN_SOURCE")

-        QryPathStr = QryPathStr & "&board=" & .Range("DEN_BOARD")

-        IsIntradai = IsNumeric(.Range("DEN_TIME"))

-        If IsIntradai Then

-            QryPathStr = QryPathStr & "&period=" & .Range("DEN_TIME")

-        Else

-            QryPathStr = QryPathStr & "&period=60"

-        End If

-        QryPathStr = QryPathStr & "&oh=11&ch=18"

-        QryPathStr = QryPathStr & "&separator=%2C"

-        QryPathStr = QryPathStr & "&vmode=Ignore&vtype=BA2"

-        QryPathStr = QryPathStr & "&format=Excel"

-        

-        If IsIntradai Then

-            DayCount = .Range("DEN_HISTORY") * .Range("DEN_TIME") \ 420 + 1 + .Range("DEN_HISTORY")

-        Else

-            DayCount = .Range("DEN_HISTORY")

-        End If

-        QryPathStr = QryPathStr & "&daysback=" & DayCount

-'        .Range("LAST_HIST_QRY") = QryPathStr

-    End With

-    GetQryPath = QryPathStr

-    

-End Function

-

-Sub UpdateTickerList(wb As Workbook)

-    Dim Idx, n As Integer

-    Dim ResultLength As Integer

-    Dim Location As Range

-    Dim QryPathStr As String

-    Dim QueryDataName As String

-    Dim DestRangeArea As String

-    

-    QryPathStr = GetListPath(wb)

-    With wb

-        With .Worksheets(VAR_SHEET)

-            Idx = .Range("IDX_DEN_LIST")

-            Set Location = .Range("TICKER_TABLES").Offset(0, (Idx - 1) * 2)

-             .Range("IDX_DEN_SYMBOL") = 1

-            QueryDataName = Location.Offset(0, 0)

-            'Clear table

-            .Range(Location.Offset(1, 0), Location.Offset(65535 - Location.Row, 1)).ClearContents

-            

-            If Not QryExist(Location.Offset(1, 0), QueryDataName) Then

-                QryCreate Location.Offset(1, 0), QueryDataName, QryPathStr

-            Else

-                QryRefresh Location.Offset(1, 0), QueryDataName, QryPathStr

-            End If

-            ' Remove header

-            ' Find [DATA]

-            n = 0

-            Do While Location.Offset(n, 0) <> "[DATA]"

-                n = n + 1

-            Loop

-            .Range(Location.Offset(1, 0), Location.Offset(n, 1)).delete Shift:=xlUp

-            With .QueryTables(QueryDataName)

-                DestRangeArea = .ResultRange.name.RefersTo

-                ResultLength = .ResultRange.count

-            End With

-        

-        '        .Parent.Application.DisplayAlerts = False

-                

-            .Range(DestRangeArea).TextToColumns _

-                Destination:=.Range(DestRangeArea), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=True, _

-                Semicolon:=True, _

-                Comma:=True, _

-                Space:=False, _

-                Other:=False, _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 9))

-        ' Sort Data

-            Set Location = .Range(.Range(DestRangeArea).Offset(0, 0), .Range(DestRangeArea).Offset(ResultLength - 1, 1))

-            Location.Sort _

-                Key1:=.Range(DestRangeArea).Offset(0, 0), _

-                Order1:=xlAscending, _

-                Header:=xlNo, _

-                OrderCustom:=1, _

-                MatchCase:=False, _

-                Orientation:=xlTopToBottom

-        End With

-        ' Setup Ticker List

-         With .Worksheets(VAR_SHEET)

-            DestRangeArea = .name & "!" & .Range(.Range(DestRangeArea).Cells(1, 1), .Range(DestRangeArea).Cells(ResultLength - 1, 1)).Address

-         End With

-        With .Worksheets(FORM_SHEET).Shapes("cbxTikers").ControlFormat

-            .ListFillRange = DestRangeArea

-            .ListIndex = 1

-        End With

-        ' Setup Name List

-         With .Worksheets(VAR_SHEET)

-            DestRangeArea = .name & "!" & .Range(.Range(DestRangeArea).Cells(1, 1), .Range(DestRangeArea).Cells(ResultLength - 1, 1)).Offset(0, 1).Address

-         End With

-        With .Worksheets(FORM_SHEET).Shapes("cbxSecName").ControlFormat

-            .ListFillRange = DestRangeArea

-            .ListIndex = 1

-        End With

-    End With

-End Sub

-

-Private Function GetListPath(wb As Workbook) As String

-    Dim QryPathStr As String

-    With wb.Worksheets(VAR_SHEET)

-        QryPathStr = "URL;http://online.rbc.ru/cgi-bin/names.cgi?"

-        QryPathStr = QryPathStr & "&source=" & .Range("DEN_SOURCE")

-        QryPathStr = QryPathStr & "&board=" & .Range("DEN_BOARD")

-        QryPathStr = QryPathStr & "&category=STOCKS"

-        '.Range("LAST_DIR_QRY") = QryPathStr

-    End With

-    GetListPath = QryPathStr

-End Function

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    Set MyAppEvents.app = Application

-    Dim wbname As String

-    Application.ScreenUpdating = False

-    If Application.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        Shell "EXCEL " & wbname

-        ThisWorkbook.Close Savechanges:=False

-        Exit Sub

-    End If

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False

-    cmSetStandaloneMode

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment wb:=ThisWorkbook, DesignMode:=False

-        If ThisWorkbook.Saved = False Then

-            ThisWorkbook.Save

-        End If

-    End If

-    Application.Caption = Empty

-    Application.CommandBars("Worksheet Menu Bar").Reset

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-        Dim MaxX, MaxY As Integer

-        With ThisWorkbook.Worksheets(FORM_SHEET)

-            MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-            MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-        End With

-

-        With ThisWorkbook.Application

-            .ScreenUpdating = False

-            .WindowState = xlNormal

-            .Height = MaxY

-            .Width = MaxX

-        End With

-End Sub

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mReadWrite
->>>>>>
-Attribute VB_Name = "mReadWrite"

-Option Explicit

-

-Public Const GOOD_LINE_STATUS As String = "Ok"

-Public Const BAD_LINE_STATUS As String = "N/A"

-

-Function ReadWebData(Location As Range, Hist As Integer, dt As Integer, _

-              pPriceData As TPriceData) As Integer

-    'Инициализация типа TPriceData из таблицы типа - 1

-    'kопируются не более чем hist последних строк

-    'aPoint - начало таблицы

-    'первые две строки таблицы идентифицирует данные (строки)

-    Dim n, i As Integer

-    

-    'Определение числа строк таблицы - n

-    n = GetLinesCount(Location)

-    ReadWebData = n

-    If n < 9 Then             'обработать ошибку !!!

-        GoTo done

-    End If

-    ' число строк определено ()

-    If Hist > (n - 3) \ dt + 1 Then ' коррекция истории

-        Hist = (n - 3) \ dt + 1 '

-    End If

-    Dim t, s As Integer

-    For t = 0 To Hist - 1

-        s = n - t * dt - 1

-        pPriceData.D(Hist - t) = Location.Offset(s, DATE_IDX).Value

-        pPriceData.Tm(Hist - t) = Location.Offset(s, TIME_IDX).Value

-        pPriceData.Opn(Hist - t) = Location.Offset(s, OPEN_IDX).Value

-        pPriceData.Hgh(Hist - t) = Location.Offset(s, HIGH_IDX).Value

-        pPriceData.Lw(Hist - t) = Location.Offset(s, LOW_IDX).Value

-        pPriceData.Cls(Hist - t) = Location.Offset(s, CLOSE_IDX).Value

-        pPriceData.Vl(Hist - t) = Location.Offset(s, VOLUME_IDX).Value

-    Next t

-    ReadWebData = t + 1

-done:

-End Function

-

-Sub ResultLinesOut(Location As Range, pPD As TPriceData, pDen As TDenmark)

-    Dim n As Integer

-    

-    n = GetLinesCount(Location)

-    With Location

-        .Offset(-1, RESIST_IDX) = "Resistance"

-        .Offset(-1, SUPPORT_IDX) = "Support"

-        .Offset(-1, PROJECT_IDX) = "Project"

-    End With

-    Dim t, count, Idx, loc_idx As Integer

-    count = pPD.tC

-    For t = 0 To count - 1

-        Idx = count - t

-        loc_idx = n - t - 1

-        If pDen.ResistanceLine(Idx) > MIN_PRICE_VALUE Then

-            Location.Offset(loc_idx, RESIST_IDX).Value = pDen.ResistanceLine(Idx)

-        End If

-        If pDen.SupportLine(Idx) > MIN_PRICE_VALUE Then

-            Location.Offset(loc_idx, SUPPORT_IDX).Value = pDen.SupportLine(Idx)

-        End If

-        If Abs(pDen.SignalValue) > 1 Then

-            Location.Offset(loc_idx, PROJECT_IDX).Value = pDen.ProjectPrice

-        End If

-    Next t

-End Sub

-

-Sub Out_Table_1(TheRange As Range, pDen As TDenmark, LastIdx As Integer)

-    

-    

-    ' Col = 2 - не определен !!!

-    ' Status - Col = 0

-    If pDen.ResistancePointCount >= 2 Then

-        TheRange.Offset(0, 0).Value = GOOD_LINE_STATUS

-    Else

-        TheRange.Offset(0, 0).Value = BAD_LINE_STATUS

-    End If

-    If pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(1, 0).Value = GOOD_LINE_STATUS

-    Else

-        TheRange.Offset(1, 0).Value = BAD_LINE_STATUS

-    End If

-    ' -----------------------------------------

-    ' углы наклонов линии сопротивления и поддержки - Col = 1

-    If pDen.ResistancePointCount >= 2 Then

-        TheRange.Offset(0, 1).Value = pDen.ResistanceAngle

-    End If

-    If pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(1, 1).Value = pDen.SupportAngle

-    End If

-    If pDen.ResistancePointCount >= 2 And pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(2, 1).Value = (pDen.ResistanceAngle + pDen.SupportAngle) / 2

-    End If

-    ' -----------------------------------------

-    ' Опорные цены линий денмарка на текущий момент

-    If pDen.ResistancePointCount >= 2 Then

-        TheRange.Offset(0, 2).Value = pDen.ResistanceLine(LastIdx)

-    End If

-    If pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(1, 2).Value = pDen.SupportLine(LastIdx)

-    End If

-    If pDen.ResistancePointCount >= 2 And pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(2, 2).Value = _

-            (pDen.ResistanceLine(LastIdx) + pDen.SupportLine(LastIdx)) / 2

-    End If

-    

-End Sub

-

-Sub Out_Table_2(TheRange As Range, TheComment As Range, pPD As TPriceData, pDen As TDenmark)

-    Const ColorIndexBUY = 5

-    Const ColorIndexSELL = 3

-    Const ColorIndexNOTHINK = 14

-    

-    Dim SignalValue_defined, allert_enable  As Boolean

-    Dim Message As String

-    SignalValue_defined = False

-    allert_enable = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_ALLERT_DLG")

-    Message = "Сигнал об изменении тренда не идентифицирован."

-    If pDen.SignalValue >= 2 Then

-        SignalValue_defined = True

-        With TheRange.Offset(0, 0)

-            .Value = "BUY"

-            .Font.Bold = True

-            .Font.ColorIndex = ColorIndexBUY

-        End With

-        TheRange.Offset(0, 1).Value2 = pPD.D(pPD.tC)

-        TheRange.Offset(0, 2).Value2 = pPD.Tm(pPD.tC)

-        TheRange.Offset(0, 3).Value = pDen.SignalValue - 1

-        TheRange.Offset(0, 4).Value = pDen.ProjectPrice

-        Message = "BUY Signal: возможен прорыв вверх нисходящего тренда с уровнем значимости = " & pDen.SignalValue - 1 & " ! "

-    End If

-    If pDen.SignalValue <= -2 Then

-        SignalValue_defined = True

-        With TheRange.Offset(0, 0)

-            .Value = "SELL"

-            .Font.Bold = True

-            .Font.ColorIndex = ColorIndexSELL

-        End With

-        TheRange.Offset(0, 1).Value2 = pPD.D(pPD.tC)

-        TheRange.Offset(0, 2).Value2 = pPD.Tm(pPD.tC)

-        TheRange.Offset(0, 3).Value = pDen.SignalValue + 1

-        TheRange.Offset(0, 4).Value = pDen.ProjectPrice

-        Message = "SELL Signal: возможен прорыв вниз восходящего тренда с уровнем значимости = " & -(pDen.SignalValue + 1) & "!"

-    End If

-    With TheComment

-        .Value = Message

-        .Font.Bold = True

-        Dim color_idx As Integer

-        If SignalValue_defined Then

-            If pDen.SignalValue > 0 Then

-                .Font.ColorIndex = ColorIndexBUY

-            Else

-                .Font.ColorIndex = ColorIndexSELL

-            End If

-        Else

-            .Font.ColorIndex = ColorIndexNOTHINK

-        End If

-    End With

-    If allert_enable And SignalValue_defined Then

-        MsgBox _

-            Prompt:=Message, _

-            Title:=PROGRAM_NAME, _

-            Buttons:=vbOKOnly + vbInformation

-    End If

-End Sub

-

-Sub Out_Table_3(TheRange As Range, pDen As TDenmark)

-    Dim i As Integer

-    For i = 1 To 3

-        TheRange.Offset(i - 1, 0).Value = pDen.Qualificator(i)

-    Next i

-End Sub

-

-Sub Out_Table_4(TheRange As Range, pPD As TPriceData)

-    Dim LastIdx As Integer

-    LastIdx = pPD.tC

-    With TheRange

-        .Offset(0, 0).Value2 = "'" & pPD.D(LastIdx)

-        .Offset(0, 1).Value2 = "'" & pPD.Tm(LastIdx)

-        .Offset(0, 2) = pPD.Opn(LastIdx)

-        .Offset(0, 3) = pPD.Hgh(LastIdx)

-        .Offset(0, 4) = pPD.Lw(LastIdx)

-        .Offset(0, 5) = pPD.Cls(LastIdx)

-        .Offset(0, 6) = pPD.Cls(LastIdx) - pPD.Cls(LastIdx - 1)

-    End With

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Denmark method bar"

-Public Const common_pwd As Long = 31415926

-

-

-Sub SetEnvironment(wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    With Application

-        .Caption = PROGRAM_NAME

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .GetState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-    End With

-    With wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(FORM_SHEET).Select

-    End With

-    CreateCommandBar theApp:=wb.Application

-End Sub

-

-Sub RestoreEnvironment(wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Application.ScreenUpdating = False

-    With wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                     cWindow.DisplayHeadings = True

-                Next

-            End If

-        Next

-        .Worksheets(FORM_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu (True)

-        End If

-        With mobjAppState

-            .RestoreState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(wb As Workbook)

-    With wb

-        .Application.ScreenUpdating = False

-        

-        With .Worksheets(RAW_DATA_SHEET)

-            .Visible = xlVeryHidden

-            .Protect Password:=common_pwd, userInterfaceOnly:=True, Contents:=False

-        End With

-        With .Worksheets(VAR_SHEET)

-            .Visible = xlVeryHidden

-            .Protect Password:=common_pwd, userInterfaceOnly:=True, Contents:=False

-        End With

-        With .Worksheets(FORM_SHEET)

-            .EnableSelection = xlNoSelection

-            .Protect userInterfaceOnly:=True

-            .Select

-        End With

-        With .Worksheets(CHART_SHEET)

-            .EnableSelection = xlNoSelection

-            .Protect userInterfaceOnly:=True

-        End With

-        .Protect Windows:=True

-        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(wb As Workbook)

-    With wb

-        .Unprotect

-        .Application.ScreenUpdating = False

-        With .Worksheets(RAW_DATA_SHEET)

-            .Visible = xlVeryHidden

-            .Unprotect Password:=common_pwd

-        End With

-        With .Worksheets(VAR_SHEET)

-            .Visible = xlVeryHidden

-            .Unprotect Password:=common_pwd

-        End With

-        With .Worksheets(CHART_SHEET)

-            .Select

-            .Unprotect

-        End With

-        With .Worksheets(FORM_SHEET)

-            .Select

-            .Unprotect

-        End With

-        .Application.ScreenUpdating = True

-        

-    End With

-End Sub

-

-<<<<<<
-======================
-mTypes
->>>>>>
-Attribute VB_Name = "mTypes"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Метод г-на Демарка"

-Public Const PROGRAM_VERSION As String = "version 1.5 Professional"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-

-'Public Const ESTIMATION_DATE As Long = 19980915

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "J27"

-

-Public Const RAW_DATA_SHEET As String = "Raw_data"

-Public Const PRICE_TABLE As String = "B1"

-Public Const RAW_DATA_RANGE As String = "B3"

-Public Const RAW_DATA_RANGE_COL As Integer = 2

-Public Const RAW_DATA_RANGE_ROW As Integer = 3

-

-Public Const VAR_SHEET As String = "Var_s"

-

-Public Const CHART_SHEET As String = "Chart"

-

-Public Const MIN_PRICE_VALUE As Double = 0.000001

-Public Const MAX_PRICE_VALUE As Double = 1000000000

-

-' Fields indexes in RAW_DATA_RANGE

-Public Const DATE_IDX As Integer = 0

-Public Const TIME_IDX As Integer = 1

-Public Const OPEN_IDX As Integer = 2

-Public Const CLOSE_IDX As Integer = 3

-Public Const LOW_IDX As Integer = 4

-Public Const HIGH_IDX As Integer = 5

-Public Const VOLUME_IDX As Integer = 6

-Public Const RESIST_IDX As Integer = 7

-Public Const SUPPORT_IDX As Integer = 8

-Public Const PROJECT_IDX As Integer = 9

-

-Type TPriceData

-    D() As String      ' календарная дата

-    Tm() As String     ' время

-    Opn() As Double    ' Open

-    Hgh() As Double    ' High

-    Lw() As Double     ' Low

-    Cls() As Double    ' Close

-    Vl() As Double     ' Volume

-    tC As Integer      ' Current time

-End Type

-

-Type TDenmark

-   ResistanceLine() As Double           'Resistance line

-   ResistancePoints() As Integer        'Resistance pivot points

-   ResistancePointCount As Integer      'The number of resistance pivot points

-   ResistanceAngle As Double            'Angle of Declination of ResistanceLine

-   

-   SupportLine() As Double              'Support line

-   SupportPoints() As Integer           'Support pivot points

-   SupportPointsCount As Integer        'The number of support pivot points

-   SupportAngle As Double               ' Angle of Declination of SupportLine

-   

-   SignalParameter     As Integer       ' parameter for SignalValue

-   SignalValue      As Integer          'SignalValue

-   

-   

-   Qualificator(1 To 3) As String       ' qualificators

- 

-   ProjectNumber As Integer             ' номер проекции

-   ProjectPrice  As Double              ' проекция цены

-   

-End Type

-

-

-<<<<<<
-======================
-mCommands
->>>>>>
-Attribute VB_Name = "mCommands"

-Option Explicit

-Dim AppRunEnable As New cEnableRun

-

-Sub evParamChange()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DENMARK_READY") = False

-End Sub

-

-Sub cmViewChart(Optional SwapPage As Boolean = True)

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("BOOL_CHART_READY") = False

-        If .Range("BOOL_DENMARK_READY") <> True Then

-            If .Range("BOOL_AUTORECALC") = True Then

-                evSubmit_Click

-                If .Range("BOOL_DENMARK_READY") <> True Then

-                    Exit Sub

-                End If

-            Else

-                MsgBox _

-                    "График не может быть построен." & vbCrLf & "Исходные данные не обработаны.", _

-                    vbOKOnly + vbExclamation, _

-                    PROGRAM_NAME

-                Exit Sub

-            End If

-        End If

-    End With

-    With ThisWorkbook.Worksheets(FORM_SHEET)

-        With .Range("TABLE_1")

-            Dim test_lines As Boolean

-            test_lines = StrComp(.Cells(1, 1).Value, GOOD_LINE_STATUS)

-            test_lines = test_lines + StrComp(.Cells(2, 1).Value, GOOD_LINE_STATUS)

-            If test_lines <> 0 Then

-                MsgBox _

-                    Prompt:="График не может быть построен." & vbCrLf & "Опорные точки не определены .", _

-                    Title:=PROGRAM_NAME, _

-                    Buttons:=vbOKOnly + vbExclamation

-                Exit Sub

-            End If

-        End With

-        Draw_Chart Not IsEmpty(.Range("TABLE_2").Cells(1, 1))

-    End With

-    With ThisWorkbook

-        .Worksheets(VAR_SHEET).Range("BOOL_CHART_READY") = True

-        If SwapPage Then

-            .Worksheets(CHART_SHEET).Select

-        End If

-    End With

-End Sub

-

-Sub cmViewForm()

-    With ThisWorkbook

-        .Worksheets(FORM_SHEET).Select

-    End With

-End Sub

-

-Sub cmCloseProgram()

-    Dim ResistanceLine

-    ResistanceLine = MsgBox( _

-        Prompt:="Вы желаете завершить программу?", _

-        Buttons:=vbQuestion + vbYesNo, _

-        Title:=PROGRAM_NAME _

-    )

-    If ResistanceLine = vbYes Then

-       Application.Quit

-    End If

-End Sub

-

-Sub cmAbout()

-    dlgAbout.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlgAbout.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlgAbout.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlgAbout.Show

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-        helppath = "hh.exe " & .Path & "\Demark.chm"

-        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub cmSetStandaloneMode()

-    Application.ScreenUpdating = False

-    ProtectionDisable wb:=ThisWorkbook

-    SetEnvironment wb:=ThisWorkbook

-    ProtectionEnable wb:=ThisWorkbook

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    rp = common_pwd

-    dlgGetPwd.edPwd = ""

-    dlgGetPwd.Show

-    If dlgGetPwd.edPwd = rp Then

-        ProtectionDisable wb:=ThisWorkbook

-        RestoreEnvironment wb:=ThisWorkbook, DesignMode:=True

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmPrint()

-    If MsgBox( _

-            Prompt:="Вы желаете распечатать результат?", _

-            Buttons:=vbYesNo + vbQuestion, _

-            Title:=PROGRAM_NAME) = vbNo _

-    Then

-        Exit Sub

-    End If

-    Dim s_ticker, s_name, s_time As String

-    s_ticker = ThisWorkbook.Worksheets(FORM_SHEET).Range("CALC_TICKER_NAME")

-    s_name = ThisWorkbook.Worksheets(FORM_SHEET).Range("CALC_NAME")

-    s_time = Now

-    Application.ScreenUpdating = False

-    cmViewChart SwapPage:=False

-    Application.ScreenUpdating = False

-    With ThisWorkbook.Worksheets(FORM_SHEET).PageSetup

-        .LeftHeader = s_ticker

-        .CenterHeader = PROGRAM_NAME

-        .RightHeader = s_time

-        .LeftFooter = s_name

-        .CenterFooter = "Page &P of &N"

-        .RightFooter = ""

-        .LeftMargin = Application.InchesToPoints(0.75)

-        .RightMargin = Application.InchesToPoints(0.75)

-        .TopMargin = Application.InchesToPoints(0.78)

-        .BottomMargin = Application.InchesToPoints(0.92)

-        .HeaderMargin = Application.InchesToPoints(0.5)

-        .FooterMargin = Application.InchesToPoints(0.5)

-        .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 = 2

-    End With

-    With ThisWorkbook.Worksheets(CHART_SHEET).PageSetup

-        .LeftHeader = s_ticker

-        .CenterHeader = PROGRAM_NAME

-        .RightHeader = s_time

-        .LeftFooter = s_name

-        .CenterFooter = "Page &P of &N"

-        .RightFooter = ""

-        .LeftMargin = Application.InchesToPoints(0.75)

-        .RightMargin = Application.InchesToPoints(0.75)

-        .TopMargin = Application.InchesToPoints(0.78)

-        .BottomMargin = Application.InchesToPoints(0.92)

-        .HeaderMargin = Application.InchesToPoints(0.5)

-        .FooterMargin = Application.InchesToPoints(0.5)

-        .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 = 2

-    End With

-    Application.ScreenUpdating = False

-    ThisWorkbook.Worksheets(Array("MainForm", "Chart")).PrintOut Copies:=1, Collate:=True

-    cmViewForm

-End Sub

-<<<<<<
-======================
-mDemark
->>>>>>
-Attribute VB_Name = "mDemark"

-Option Explicit

-

-Public Const FORM_SHEET As String = "MainForm"

-

-'Form Ranges

-Public Const TABLE_1 As String = "TABLE_1"

-Public Const TABLE_2 As String = "TABLE_2"

-Public Const TABLE_3 As String = "TABLE_3"

-Public Const TABLE_4 As String = "TABLE_4"

-Public Const TABLE_COMMENT As String = "TABLE_COMMENT"

-

-'Основной тип данных - стандарт 1

-

-'*********************

-Dim PriceDataArray As TPriceData

-Dim DenmarkDataArray As TDenmark

-

-Dim mobjAppRunEnable As New cEnableRun

-

-Function TDenmark_Calc() As Boolean

-    

-    Dim nWindow As Integer

-    Dim bPrevCloseFilter, bSuccCloseFilter As Boolean

-    

-    TDenmark_Calc = False

-    

-    mobjAppRunEnable.EnableRun ESTIMATION_DATE, Now

-    

-    With ThisWorkbook

-        .Application.ScreenUpdating = False

-'1)    Read User data

-        With .Worksheets(VAR_SHEET)

-            DenmarkDataArray.ProjectNumber = .Range("DEN_PROECT").Value

-            DenmarkDataArray.SignalParameter = .Range("DEN_PARAM").Value

-            nWindow = .Range("DEN_WINDOW").Value

-            bPrevCloseFilter = .Range("BOOL_PREV_CLOSE").Value

-            bSuccCloseFilter = .Range("BOOL_SUCC_CLOSE").Value

-        End With

-

-'2)   Memory allocation

-        allocate_memory PriceDataArray, DenmarkDataArray, nWindow

-

-'3)   Read data

-        Dim TheRange As Range

-        Set TheRange = .Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE)

-        Dim LinesCount As Integer

-        LinesCount = ReadWebData(Location:=TheRange, Hist:=PriceDataArray.tC, dt:=1, pPriceData:=PriceDataArray)

-        

-        'Init function result

-        TDenmark_Calc = LinesCount >= nWindow

-        

-        If LinesCount >= nWindow Then

-        

-'4)   Calculate metod TDenmarkDataArray

-            DetDenmark PriceDataArray, DenmarkDataArray, bPrevCloseFilter, bSuccCloseFilter

-            If Abs(DenmarkDataArray.SignalValue) > 1 Then  'ценовые ориентиры, если есть сигнал

-                DetProj PriceDataArray, DenmarkDataArray

-            End If

-'5)   Write result

-            Application.ScreenUpdating = False

-    

-'6)    Clear interface tables

-            With .Worksheets(FORM_SHEET)

-                .Range(TABLE_1).ClearContents ' таблица-1

-                .Range(TABLE_2).ClearContents ' таблица-2

-                .Range(TABLE_3).ClearContents ' таблица-3

-                .Range(TABLE_COMMENT).Value = "" ' коментарий-3

-                .Range(TABLE_4).ClearContents ' таблица-4

-            End With

-    

-            ResultLinesOut Location:=TheRange.Offset(2, 0), pPD:=PriceDataArray, pDen:=DenmarkDataArray

-            

-            With .Worksheets(FORM_SHEET)

-                Out_Table_1 TheRange:=.Range(TABLE_1).Cells(1, 1), pDen:=DenmarkDataArray, LastIdx:=PriceDataArray.tC

-                Out_Table_2 _

-                        TheRange:=.Range(TABLE_2).Cells(1, 1), _

-                        TheComment:=.Range("TABLE_COMMENT"), _

-                        pPD:=PriceDataArray, _

-                        pDen:=DenmarkDataArray

-                Out_Table_3 TheRange:=.Range(TABLE_3).Cells(1, 1), pDen:=DenmarkDataArray

-                Out_Table_4 TheRange:=.Range(TABLE_4).Cells(1, 1), pPD:=PriceDataArray

-                With .Range(TABLE_1)

-                    .Font.name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-                With .Range(TABLE_2)

-                    .Font.name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-                With .Range(TABLE_3)

-                    .Font.name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-                With .Range(TABLE_4)

-                    .Font.name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-            End With

-            .Worksheets(VAR_SHEET).Range("BOOL_DENMARK_READY") = True

-        Else

-            MsgBox _

-                Prompt:="Недостаточна глубина выборки данных." _

-                    & vbCrLf & "Измените параметры запроса и пробуйте снова.", _

-                Buttons:=vbOKOnly + vbExclamation, _

-                Title:=PROGRAM_NAME

-            .Worksheets(VAR_SHEET).Range("BOOL_DENMARK_READY") = False

-            .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False

-        End If

-'7)   Free unused memory

-        free_unused_memory PriceDataArray, DenmarkDataArray

-    End With

-End Function

-

-Sub allocate_memory(pPriceData As TPriceData, pDenmarkData As TDenmark, memsize As Integer)

-'  Память под TDenmark

-    ReDim pDenmarkData.ResistanceLine(1 To memsize)

-    ReDim pDenmarkData.ResistancePoints(1 To memsize)

-    ReDim pDenmarkData.SupportLine(1 To memsize)

-    ReDim pDenmarkData.SupportPoints(1 To memsize)

-   

-' Инициализация данных по ценам

-    pPriceData.tC = memsize

-    ReDim pPriceData.D(1 To memsize)

-    ReDim pPriceData.Tm(1 To memsize)

-    ReDim pPriceData.Opn(1 To memsize)

-    ReDim pPriceData.Hgh(1 To memsize)

-    ReDim pPriceData.Lw(1 To memsize)

-    ReDim pPriceData.Cls(1 To memsize)

-    ReDim pPriceData.Vl(1 To memsize)

-

-End Sub

-

-Sub free_unused_memory(pP As TPriceData, pD As TDenmark)

-'   Free Prices

-    pP.tC = 0

-    Erase pP.D

-    Erase pP.Tm

-    Erase pP.Opn

-    Erase pP.Hgh

-    Erase pP.Lw

-    Erase pP.Cls

-    Erase pP.Vl

-    

-'Free TDenmark

-    Erase pD.ResistanceLine

-    Erase pD.ResistancePoints

-    Erase pD.SupportLine

-    Erase pD.SupportPoints

-End Sub

-

-

-'*****************************************

-Sub DetDenmark(pPriceData As TPriceData, pDenmarkData As TDenmark, ByVal ClosePrev2 As Boolean, ByVal CloseSucc1 As Boolean)

-' определение элементов данных Денмарка (в цифровой форме)

-' на текущий момент времени времени tC

-' ИСХОДНЫЕ ДАННЫЕ:

-' pPriceData  - окно, стандартная форма данных по ценам (определена)

-' ClosePrev2 - H(t) > max{ H(t-1), H(t+1)} и  H(t) > Close(t-2)

-' CloseSucc1 - H(t) > max{ H(t-1), H(t+1)}  и  R(t+1) > Close(t+1)

-' РЕЗУЛЬТАТ:

-' pDenmarkData - элементы данных Денмарка (память выделена, SignalParameter - определен):

-' линии ResistanceLine,SupportLine их наклоны, опорные точки, сигналы к покупке или продаже

-' SignalValue = 0 сигнал отсутствует

-' SignalValue < 0 прорыв восходящего тренда (сигнал продажи)

-' SignalValue > 0 прорыв нисходящего тренда (сигнал покупки)

-' Если pDenmarkData.ResistancePointCount < 2, то элементы ResistanceLine не определяются

-' Если pDenmarkData.SupportPointsCount < 2, то элементы SupportLine не определяются

-

-' начальная установка

-    Const QUALIFICATOR_DISABLE As String = "-"

-    Const QUALIFICATOR_ENABLE As String = "Signal"

-    

-    Dim UpQual(1 To 3) As String

-    Dim DownQual(1 To 3) As String

-    Dim UpSignal, DownSignal As Integer

-    Dim i As Integer

-    

-    pDenmarkData.SignalValue = 0

-    UpSignal = 0

-    DownSignal = 0

-    

-    For i = 1 To 3

-        pDenmarkData.Qualificator(i) = QUALIFICATOR_DISABLE

-        UpQual(i) = QUALIFICATOR_DISABLE

-        DownQual(i) = QUALIFICATOR_DISABLE

-    Next i

-    

-' определение линии поддержки и сопротивления

-    ResLine _

-        pPriceData, _

-        pPriceData.tC, _

-        pDenmarkData.ResistancePointCount, _

-        pDenmarkData.ResistanceLine, _

-        pDenmarkData.ResistancePoints, _

-        ClosePrev2, _

-        CloseSucc1

-        

-    SuppLine _

-        pPriceData, _

-        pPriceData.tC, _

-        pDenmarkData.SupportPointsCount, _

-        pDenmarkData.SupportLine, _

-        pDenmarkData.SupportPoints, _

-        ClosePrev2, _

-        CloseSucc1

-

-        

-        

-    If pDenmarkData.ResistancePointCount >= 2 Then

-        pDenmarkData.ResistanceAngle = 57.29578 * _

-            Atn(pDenmarkData.ResistanceLine(pPriceData.tC) - _

-                pDenmarkData.ResistanceLine(pPriceData.tC - 1))

-    End If

-    If pDenmarkData.SupportPointsCount >= 2 Then

-        pDenmarkData.SupportAngle = 57.29578 * _

-            Atn(pDenmarkData.SupportLine(pPriceData.tC) - _

-                pDenmarkData.SupportLine(pPriceData.tC - 1))

-    End If

-

-' ФОРМИРОВАНИЕ СИГНАЛА ----------------------------------

-    Dim t As Integer

-' 1. случай нисходящего тренда: ResistanceLine определен и ResistanceLine падает *************

-    If pDenmarkData.ResistancePointCount >= 2 And pDenmarkData.ResistanceAngle < 0 Then

-'    необходимое условие прорыва вверх

-        If pDenmarkData.ResistanceLine(pPriceData.tC) < pPriceData.Cls(pPriceData.tC) Then

-            UpSignal = 1

-            For t = pPriceData.tC - pDenmarkData.SignalParameter To pPriceData.tC - 1

-                If pPriceData.Cls(t) > pDenmarkData.ResistanceLine(t) Then

-                    UpSignal = 0

-                    Exit For

-                End If

-            Next t

-        End If

-        If UpSignal = 1 Then

-'       Qualificator-1: close убывает накануне прорыва

-            If pPriceData.Cls(pPriceData.tC - 2) > pPriceData.Cls(pPriceData.tC - 1) Then

-                UpSignal = UpSignal + 1

-                UpQual(1) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-2: open > ResistanceLine в момент прорыва

-            If pPriceData.Opn(pPriceData.tC) > pDenmarkData.ResistanceLine(pPriceData.tC) Then

-                UpSignal = UpSignal + 1

-                UpQual(2) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-3 - demand value < ResistanceLine(tC)

-            If 2 * pPriceData.Cls(pPriceData.tC - 1) - pPriceData.Lw(pPriceData.tC - 1) < pDenmarkData.ResistanceLine(pPriceData.tC) Then

-                UpSignal = UpSignal + 1

-                UpQual(3) = QUALIFICATOR_ENABLE

-            End If

-        End If

-    End If  ' нисходящий тренд обработан ************************************

-

-' 2. случай восходящего тренда: SupportLine определен и SupportLine растет

-    If pDenmarkData.SupportPointsCount >= 2 And pDenmarkData.SupportAngle > 0 Then

-'    ---------------------------------------------

-'    необходимое условие прорыва вниз

-        If pPriceData.Cls(pPriceData.tC) < pDenmarkData.SupportLine(pPriceData.tC) Then

-            DownSignal = -1

-            For t = pPriceData.tC - pDenmarkData.SignalParameter To pPriceData.tC - 1

-                If pPriceData.Cls(t) < pDenmarkData.SupportLine(t) Then

-                    DownSignal = 0

-                    Exit For

-                End If

-            Next t

-        End If

-        If DownSignal = -1 Then

-'       Qualificator-1: Close растет накануне прорыва

-            If pPriceData.Cls(pPriceData.tC - 2) < pPriceData.Cls(pPriceData.tC - 1) Then

-                DownSignal = DownSignal - 1

-                DownQual(1) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-2: Open ниже ResistanceLine в момент прорыва

-            If pPriceData.Opn(pPriceData.tC) < pDenmarkData.SupportLine(pPriceData.tC) Then

-                DownSignal = DownSignal - 1

-                DownQual(2) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-3 - supply value(t-1) > SupportLine(tC)

-            If 2 * pPriceData.Cls(pPriceData.tC - 1) - pPriceData.Hgh(pPriceData.tC - 1) > pDenmarkData.SupportLine(pPriceData.tC) Then

-                DownSignal = DownSignal - 1

-                DownQual(3) = QUALIFICATOR_ENABLE

-            End If

-        End If

-'    ---------------------------------------------

-    End If

-'      Существует преобладание тенденции

-    If Abs(DownSignal) <> UpSignal Then

-        If Abs(DownSignal) > UpSignal Then

-            pDenmarkData.SignalValue = DownSignal

-            For i = 1 To 3

-                pDenmarkData.Qualificator(i) = DownQual(i)

-            Next i

-        Else

-            pDenmarkData.SignalValue = UpSignal

-            For i = 1 To 3

-                pDenmarkData.Qualificator(i) = UpQual(i)

-            Next i

-        End If

-    End If

-End Sub

-

-Sub DetProj(pPriceData As TPriceData, pDenmarkData As TDenmark)

-'Определение проекции при наличии сигнала: |Signal| > 1

-'Услловие применимости |Signal| > 1 !!!

-    Dim pM As Double, t As Integer, Tm As Integer, tL As Integer

-

-    If pDenmarkData.SignalValue >= 2 Then  ' СИГНАЛ ПОКУПКИ

-

-        tL = pDenmarkData.ResistancePoints(pDenmarkData.ResistancePointCount)     ' tR determination

-        If tL = pPriceData.tC Then

-            tL = pDenmarkData.ResistancePoints(pDenmarkData.ResistancePointCount - 1)

-        End If

-

-'  Projections 1,2 --------------------------------------------

-        If pDenmarkData.ProjectNumber >= 1 And pDenmarkData.ProjectNumber <= 2 Then

-'           t* = Arg min {L(t) : t R <= t  <= tb ,  L(t) < ResistanceLine(t)},

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Lw(Tm) ' L(t-1) < ResistanceLine(t-1) for t - break point !

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Lw(t) < pM And pPriceData.Lw(t) < pDenmarkData.ResistanceLine(t) Then

-                    pM = pPriceData.Lw(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            If pDenmarkData.ProjectNumber = 1 Then

-'               P1( tb) = ResistanceLine(tb) + ResistanceLine(t*) - L(t*)

-                pDenmarkData.ProjectPrice = pDenmarkData.ResistanceLine(pPriceData.tC) + pDenmarkData.ResistanceLine(Tm) - pPriceData.Lw(Tm)

-            Else

-                pDenmarkData.ProjectPrice = pDenmarkData.ResistanceLine(pPriceData.tC) + pDenmarkData.ResistanceLine(Tm) - pPriceData.Cls(Tm)

-            End If

-        End If ' pDenmarkData.ProjectNumber >= 1 And pDenmarkData.ProjectNumber <= 2

-   

-'  ----------------------------------------------------------------

-'  Projections 3

-        If pDenmarkData.ProjectNumber = 3 Then

-'           t*  = Arg min { С(t) : t R <= t  <= tb ,  C(t) < ResistanceLine(t)}

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Cls(Tm)

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Cls(t) < pM And pPriceData.Cls(t) < pDenmarkData.ResistanceLine(t) Then

-                    pM = pPriceData.Cls(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            pDenmarkData.ProjectPrice = pDenmarkData.ResistanceLine(pPriceData.tC) + pDenmarkData.ResistanceLine(Tm) - pPriceData.Cls(Tm)

-        End If

-    End If ' pDenmarkData.SignalValue >= 2

-

-'-------------------------------------------------------------------

-'*******************************************************************

-' ПРОЕКЦИЯ ДЛЯ СИГНАЛА ПРОДАЖИ

-    If pDenmarkData.SignalValue <= -2 Then

-        tL = pDenmarkData.SupportPoints(pDenmarkData.SupportPointsCount)  ' tR determination

-        If tL = pPriceData.tC Then

-            tL = pDenmarkData.ResistancePoints(pDenmarkData.SupportPointsCount - 1)

-        End If

-

-'  Projections 1,2 --------------------------------------------

-        If pDenmarkData.ProjectNumber = 1 Or pDenmarkData.ProjectNumber = 2 Then

-'           t* = Arg max {H(t) : t R <= t  <= tb ,  H(t) > SupportLine(t)},

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Hgh(Tm) ' H(t-1) > SupportLine(t-1) for t - break point !

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Hgh(t) > pM And pPriceData.Hgh(t) > pDenmarkData.SupportLine(t) Then

-                    pM = pPriceData.Hgh(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            If pDenmarkData.ProjectNumber = 1 Then

- '              P1( tb) = SupportLine(tb) + SupportLine(t*) - H(t*)

-                pDenmarkData.ProjectPrice = pDenmarkData.SupportLine(pPriceData.tC) + pDenmarkData.SupportLine(Tm) - pPriceData.Hgh(Tm)

-            Else

-'               P2( tb) = SupportLine(tb) + SupportLine(t*) - C(t*)

-                pDenmarkData.ProjectPrice = pDenmarkData.SupportLine(pPriceData.tC) + pDenmarkData.SupportLine(Tm) - pPriceData.Cls(Tm)

-            End If

-        End If

-   

-'  ----------------------------------------------------------------

-'  Projections 3

-        If pDenmarkData.ProjectNumber = 3 Then

-'           t*  = Arg max { С(t) : t R <= t  <= tb ,  C(t) >  SupportLine(t)}

-'           P3( tb) = SupportLine(tb) + SupportLine(t*) - C(t*)

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Cls(Tm)

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pM < pPriceData.Cls(t) And pPriceData.Cls(t) > pDenmarkData.SupportLine(t) Then

-                    pM = pPriceData.Cls(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            pDenmarkData.ProjectPrice = pDenmarkData.SupportLine(pPriceData.tC) + pDenmarkData.SupportLine(Tm) - pPriceData.Cls(Tm)

-        End If

-    End If ' pDenmarkData.SignalValue <= -2

-End Sub

-

-Sub ResLine(pP As TPriceData, tE As Integer, ResistancePointCount As Integer, _

-            ResistanceLine() As Double, s() As Integer, ClosePrev2 As Boolean, CloseSucc1 As Boolean)

-' Определение линии сопротивления по Демарку [1]

-' Основной вариант

-' ИСХОДНЫЕ ДАННЫЕ:

-' High, dom(High) = [1, tE]

-' ClosePrev2 - H(t) > max{ H(t-1), H(t+1)} и  H(t) > Close(t-2)

-' CloseSucc1 - H(t) > max{ H(t-1), H(t+1)}  и  R(t+1) > Close(t+1)

-' РЕЗУЛЬТАТ:

-' 1) линия сопротивления ResistanceLine, dom(ResistanceLine)=[s(1), tE], и

-' 2) s = {s(1), s(2), ..., s(ResistancePointCount)}, s(1) < s(2) < ...< s(ResistancePointCount)

-'   ( s(ResistancePointCount)<= tE )- опорные точки

-' 3) число опорных точек ResistancePointCount.

-' 4) s(1) -  первый момент времени с которого определена SupportLine

-'    то есть dom{Supp} = [s(1), tC]

-' Прим. Если число опорных точек окажется < 2, то линия

-' сопротивления не определяется. В этом случае следует

-' увеличить историю tE !!!

-    Dim t As Integer, i As Integer

-    Dim v As Double

-    Dim IsGoodPoint As Boolean

-  

-'1 определение опорных моментов времени

-    ResistancePointCount = 0

-    For t = 3 To tE - 1

- '      v = max{high(t-1), high(t+1)} < high(t)}

-        v = pP.Hgh(t - 1)

-        If v < pP.Hgh(t + 1) Then

-            v = pP.Hgh(t + 1)

-        End If

-        IsGoodPoint = pP.Hgh(t) > v

-        If IsGoodPoint And ClosePrev2 Then

-            IsGoodPoint = IsGoodPoint And (pP.Cls(t - 2) < pP.Hgh(t))

-        End If

-        

-        If IsGoodPoint Then       'alt.: v >= High(t + 1)

-            s(ResistancePointCount + 1) = t: ResistancePointCount = ResistancePointCount + 1

-        End If

-    Next t

-    

-loop_:

-    

-    If ResistancePointCount < 2 Then

-        GoTo done

-    End If

-

-' 2 определение линии сопротивления

-    ResistanceLine(s(1)) = pP.Hgh(s(1))

-    For i = 2 To ResistancePointCount

-        ResistanceLine(s(i)) = pP.Hgh(s(i))

-        v = (pP.Hgh(s(i)) - pP.Hgh(s(i - 1))) / (s(i) - s(i - 1))

-        For t = s(i - 1) + 1 To s(i) - 1

-            ResistanceLine(t) = pP.Hgh(s(i - 1)) + v * (t - s(i - 1))

-        Next t

-    Next i

-    If s(ResistancePointCount) < tE Then

-        v = (pP.Hgh(s(ResistancePointCount)) - pP.Hgh(s(ResistancePointCount - 1))) / (s(ResistancePointCount) - s(ResistancePointCount - 1))

-        For t = s(ResistancePointCount) + 1 To tE

-            ResistanceLine(t) = pP.Hgh(s(ResistancePointCount - 1)) + v * (t - s(ResistancePointCount - 1))

-        Next t

-    End If

-    If CloseSucc1 Then

-        For t = 1 To ResistancePointCount

-            If ResistanceLine(s(t) + 1) < pP.Cls(s(t) + 1) Then

-                ResistancePointCount = ResistancePointCount - 1

-                ' удалить точку

-                For i = t To ResistancePointCount

-                    s(i) = s(i + 1)

-                Next i

-                s(ResistancePointCount + 1) = 0

-                ' очистить массив линии

-                Dim Lb, Rb As Integer

-                Lb = LBound(ResistanceLine)

-                Rb = UBound(ResistanceLine)

-                Erase ResistanceLine

-                ReDim ResistanceLine(Lb To Rb)

-                GoTo loop_

-            End If

-        Next t

-    End If

-    

-done:

-End Sub

-

-Sub SuppLine(pP As TPriceData, tE As Integer, SupportPointsCount As Integer, _

-               SupportLine() As Double, s() As Integer, ClosePrev2 As Boolean, CloseSucc1 As Boolean)

-' Определение линии поддержки по Демарку [1] (от конца)

-' Исходные данные:

-' Low, dom(Low) = [1, tE]

-' ClosePrev2 - H(t) > max{ H(t-1), H(t+1)} и  H(t) > Close(t-2)

-' CloseSucc1 - H(t) > max{ H(t-1), H(t+1)}  и  R(t+1) > Close(t+1)

-' Результат:

-' 1) линия сопротивления SupportLine, dom(SupportLine)=[s(1), tE],

-' 2) s = {s(1), s(2), ..., s(SupportPointsCount)}, s(1) < s(2) < ...< s(SupportPointsCount) -

-'    опорные точки

-' 3) число опорных точек SupportPointsCount.

-' Прим. Если фактическое число опорных точек окажется < 2, то линия

-' поддержки не определяется.

-    Dim t As Integer, i As Integer

-    Dim v As Double

-    Dim IsGoodPoint As Boolean

-    

-'1 определение опорных моментов времени

-     SupportPointsCount = 0

-    For t = 3 To tE - 1

-'       v = min{Low(t-1), Low(t+1)} > Low(t)

-        v = pP.Lw(t - 1)

-        If v > pP.Lw(t + 1) Then

-            v = pP.Lw(t + 1)

-        End If

-        

-        IsGoodPoint = pP.Lw(t) < v

-        

-        If IsGoodPoint And ClosePrev2 Then

-            IsGoodPoint = IsGoodPoint And (pP.Cls(t - 2) > pP.Lw(t))

-        End If

-        

-        If IsGoodPoint Then     'alt.: v >= High(t + 1)

-            s(SupportPointsCount + 1) = t: SupportPointsCount = SupportPointsCount + 1

-        End If

-    Next t

-

-loop_:

-    If SupportPointsCount < 2 Then

-        GoTo done

-    End If

-' 2 определение линии поддержки

-    

-    SupportLine(s(1)) = pP.Lw(s(1))

-    For i = 2 To SupportPointsCount

-        SupportLine(s(i)) = pP.Lw(s(i))

-        v = (pP.Lw(s(i)) - pP.Lw(s(i - 1))) / (s(i) - s(i - 1))

-        For t = s(i - 1) + 1 To s(i) - 1

-            SupportLine(t) = pP.Lw(s(i - 1)) + v * (t - s(i - 1))

-        Next t

-    Next i

-    If s(1) < tE Then

-        v = (pP.Lw(s(SupportPointsCount)) - pP.Lw(s(SupportPointsCount - 1))) / (s(SupportPointsCount) - s(SupportPointsCount - 1))

-        For t = s(SupportPointsCount) + 1 To tE

-            SupportLine(t) = pP.Lw(s(SupportPointsCount - 1)) + v * (t - s(SupportPointsCount - 1))

-        Next t

-    End If

-    If CloseSucc1 Then

-        For t = 1 To SupportPointsCount

-            If SupportLine(s(t) + 1) > pP.Cls(s(t) + 1) Then

-                SupportPointsCount = SupportPointsCount - 1

-                ' удалить точку

-                For i = t To SupportPointsCount

-                    s(i) = s(i + 1)

-                Next i

-                s(SupportPointsCount + 1) = 0

-                ' очистить массив линии

-                Dim Lb, Rb As Integer

-                Lb = LBound(SupportLine)

-                Rb = UBound(SupportLine)

-                Erase SupportLine

-                ReDim SupportLine(Lb To Rb)

-                GoTo loop_

-            End If

-        Next t

-    End If

-done:

-End Sub

-

-<<<<<<
-======================
-mChart
->>>>>>
-Attribute VB_Name = "mChart"

-Option Explicit

-

-Const CHART_NAME As String = "PriceChart"

-

-Sub Draw_Chart(SignalDefined As Boolean)

-

-    Dim n As Integer

-    Dim theChart As Chart

-    Dim ChartDataAria, szLastNumber As String

-    Dim MinYScale As Double

-    

-    

-    With ThisWorkbook

-' Checking data

-' Disable screen out

-        .Application.Cursor = xlWait

-        .Application.ScreenUpdating = False

-' Create series range

-        n = GetLinesCount(Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE))

-        szLastNumber = n + 1

-        If SignalDefined Then

-            ChartDataAria = "A2:A" + szLastNumber + ",D2:E" + szLastNumber + ",I2:K" + szLastNumber

-        Else

-            ChartDataAria = "A2:A" + szLastNumber + ",D2:E" + szLastNumber + ",I2:J" + szLastNumber

-        End If

-        MinYScale = GetMinValue(.Worksheets(RAW_DATA_SHEET).Range(ChartDataAria))

-' Find and delete old chart

-        .Worksheets(CHART_SHEET).Unprotect

-        Dim WindowWidth, WindowHeight As Integer

-        With .Worksheets(CHART_SHEET)

-            WindowWidth = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-            WindowHeight = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-        End With

-        

-        

-        With .Worksheets(CHART_SHEET).ChartObjects

-            .delete

-            With .Add(5, 5, WindowWidth - 10, WindowHeight - 10)

-                .SendToBack

-                Set theChart = .Chart

-            End With

-' Create a chart

-        End With

-        With theChart

-            .ChartType = xlLine

-            .SetSourceData Source:=Sheets(RAW_DATA_SHEET).Range( _

-                    ChartDataAria), PlotBy:=xlColumns

-            .Location Where:=xlLocationAsObject, name:=CHART_SHEET

-            .HasTitle = True

-            With .ChartTitle

-                .Text = ThisWorkbook.Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE).Value

-                With .Font

-                    .Size = 8

-                    .Bold = True

-                End With

-            End With

-            .HasLegend = True

-            With .Legend

-                .Position = xlTop

-                With .Font

-                    .name = "Arial"

-                    .Size = 8

-                End With

-            End With

-            .HasDataTable = False

-            With .Axes(xlCategory)

-                .HasMajorGridlines = True

-                .HasMinorGridlines = False

-                .TickLabels.Orientation = xlUpward

-                With .MajorGridlines.Border

-                    .ColorIndex = 48

-                    .Weight = xlHairline

-                    .LineStyle = xlDot

-                End With

-                .CrossesAt = 1

-                .TickLabelSpacing = 1

-                .TickMarkSpacing = 1

-                .AxisBetweenCategories = False

-                .ReversePlotOrder = False

-                .TickLabels.AutoScaleFont = True

-                With .TickLabels.Font

-                    .name = "Arial"

-                    .Size = 8

-                End With

-            End With

-            With .Axes(xlValue)

-                .HasMajorGridlines = True

-                .HasMinorGridlines = False

-                With .MajorGridlines.Border

-                    .ColorIndex = 48

-                    .Weight = xlHairline

-                    .LineStyle = xlDot

-                End With

-                .MinimumScale = MinYScale

-                .MaximumScaleIsAuto = True

-                .MinorUnitIsAuto = True

-                .MajorUnitIsAuto = True

-                .Crosses = xlCustom

-                .CrossesAt = MinYScale

-                .ReversePlotOrder = False

-                .ScaleType = xlLinear

-                .TickLabels.AutoScaleFont = True

-                With .TickLabels.Font

-                    .name = "Arial"

-                    .Size = 9

-                End With

-            End With

-            .ChartTitle.Top = 5

-            .ChartTitle.Left = 5

-            With .Legend

-                .Top = 5

-                .Fill.OneColorGradient _

-                    Style:=msoGradientHorizontal, _

-                    Variant:=3, _

-                    Degree:=0.303913939116503

-                .Fill.Visible = True

-                .Fill.ForeColor.SchemeColor = 71

-            End With

-            .PlotArea.Left = 10

-            .PlotArea.Top = .Legend.Top + .Legend.Height + 5

-            .PlotArea.Width = .ChartArea.Width - 20

-            .PlotArea.Height = .ChartArea.Height - .PlotArea.Top

-            

-' Tune OPEN line

-            With .SeriesCollection(1)

-                .Border.LineStyle = xlNone

-                .MarkerBackgroundColorIndex = xlNone

-                .MarkerForegroundColorIndex = 1

-                .MarkerStyle = xlPlus

-                .Smooth = False

-                .MarkerSize = 9

-                .Shadow = False

-            End With

-' Tune CLOSE line

-            With .SeriesCollection(2)

-                .Border.ColorIndex = 10

-                .Border.Weight = xlMedium

-                .Border.LineStyle = xlContinuous

-            End With

-' Tune RESISTANCE line

-            With .SeriesCollection(3)

-                .Border.ColorIndex = 3

-                .Border.Weight = xlThin

-                .Border.LineStyle = xlContinuous

-            End With

-' Tune SUUPORT line

-            With .SeriesCollection(4)

-                .Border.ColorIndex = 25

-                .Border.Weight = xlThin

-                .Border.LineStyle = xlContinuous

-            End With

-            If SignalDefined Then

-                With .SeriesCollection(5)

-                    .Border.ColorIndex = 6

-                    .Border.Weight = xlThin

-                    .Border.LineStyle = xlDot

-                End With

-            End If

-        End With

-        .Application.Cursor = xlDefault

-        With .Worksheets(CHART_SHEET)

-            .Range("A1").Select

-            .Protect userInterfaceOnly:=True

-        End With

-    End With

-End Sub

-

-Function GetMinValue(DataRange As Range) As Double

-    Dim Cell As Range

-    Dim MinValue, MaxValue, RangeValue, CorrectValue, Mult As Double

-    MinValue = MAX_PRICE_VALUE

-    MaxValue = MIN_PRICE_VALUE

-    For Each Cell In DataRange

-        If Not IsEmpty(Cell) And IsNumeric(Cell) Then

-            If Cell > MIN_PRICE_VALUE Then

-                If Cell < MinValue Then

-                    MinValue = Cell

-                End If

-                If Cell > MaxValue Then

-                    MaxValue = Cell

-                End If

-            End If

-        End If

-    Next

-    RangeValue = MaxValue - MinValue

-    If RangeValue < 0 Then

-        MinValue = 0

-    Else

-        CorrectValue = RangeValue / 4

-        Mult = MIN_PRICE_VALUE

-        While MinValue - Int(MinValue * Mult) / Mult > CorrectValue

-            Mult = Mult * 10

-        Wend

-        MinValue = Int(MinValue * Mult) / Mult

-    End If

-    GetMinValue = MinValue

-End Function

-

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub GetState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars("Worksheet Menu Bar").Visible = False

-End Sub

-

-

-Public Sub RestoreState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars("Worksheet Menu Bar").Visible = True

-End Sub

-

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{00A1CC6B-8DDA-11D2-B34E-525400DB02FE}{00A1CC5A-8DDA-11D2-B34E-525400DB02FE}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub CommandButton1_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mWebQeury
->>>>>>
-Attribute VB_Name = "mWebQeury"

-Option Explicit

-

-Public Const Qry_DELETE_ALL As String = "Qry_DELETE_ALL"

-Public Const Qry_PATH_NO_CHANGE As String = "Qry_PATH_NO_CHANGE"

-

-

-Sub QryCreate(QryRange As Range, QryName As String, QryPath As String, Optional RefreshBkgnd = False)

-    Dim WebQuery As QueryTable

-    QryDelete QryRange:=QryRange, QryName:=QryName

-    

-    Set WebQuery = QryRange.Worksheet.QueryTables.Add( _

-            Connection:=QryPath, _

-            Destination:=QryRange)

-    

-    With WebQuery

-        .FieldNames = False

-        .name = QryName

-        .RefreshStyle = xlOverwriteCells

-        .RowNumbers = False

-        .FillAdjacentFormulas = False

-        .RefreshOnFileOpen = False

-        .HasAutoFormat = False

-        .BackgroundQuery = False

-        .TablesOnlyFromHTML = False

-        .Refresh BackgroundQuery:=RefreshBkgnd

-        .SavePassword = False

-        .SaveData = True

-    End With

-End Sub

-

-Function QryRefresh(QryRange As Range, QryName As String, Optional QryPath As String = Qry_PATH_NO_CHANGE, Optional Background As Boolean = False) As Boolean

-    Dim qry_result As Boolean

-    qry_result = False

-    If QryExist(QryRange, QryName) Then

-        With QryRange.Worksheet.QueryTables(QryName)

-            If QryPath <> Qry_PATH_NO_CHANGE Then

-                .Connection = QryPath

-            End If

-            .Refresh BackgroundQuery:=Background

-            qry_result = True

-        End With

-    End If

-    QryRefresh = qry_result

-End Function

-

-Sub QryDelete(QryRange As Range, Optional QryName As String = Qry_DELETE_ALL)

-    Dim WebQuery As QueryTable

-    For Each WebQuery In QryRange.Worksheet.QueryTables

-        If QryName = Qry_DELETE_ALL Or WebQuery.name = QryName Then

-            WebQuery.delete

-        End If

-    Next

-End Sub

-

-Function QryExist(QryRange As Range, QryName As String) As Boolean

-    Dim WebQuery As QueryTable

-    For Each WebQuery In QryRange.Worksheet.QueryTables

-        If WebQuery.name = QryName Then

-            QryExist = True

-            Exit For

-        End If

-    Next

-End Function

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Sub CreateCommandBar(theApp As Application)

-Attribute CreateCommandBar.VB_ProcData.VB_Invoke_Func = "R\n14"

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible + msoBarNoCustomize + msoBarNoMove + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Print"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 4

-                        .OnAction = "cmPrint"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Contents"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 49

-                        .OnAction = "cmHelpContents"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible + msoBarNoCustomize + msoBarNoMove + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(Flag As Boolean)

-    If Flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars("Worksheet Menu Bar")

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim curdate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    curdate = year * 10000

-    curdate = curdate + month * 100

-    curdate = curdate + day

-    If curdate > end_date Then

-        cmAbout

-        cmHelpContents

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mTool
->>>>>>
-Attribute VB_Name = "mTool"

-Option Explicit

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub tool_delete_all_tables()

-    QryDelete ThisWorkbook.Worksheets(RAW_DATA_SHEET).Range("A1")

-End Sub

-

-Sub tool_delete_all_charts(theSheet As Worksheet)

-    Dim theChart As Chart

-    For Each theChart In theSheet

-        theChart.Unprotect

-        theChart.delete

-    Next

-End Sub

-

-Sub DateTimeTest()

-    Dim the_date

-    Dim the_time

-    the_date = DateValue(Now)

-    the_time = TimeValue(Now)

-End Sub

-

-

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{00A1CC67-8DDA-11D2-B34E-525400DB02FE}{00A1CC62-8DDA-11D2-B34E-525400DB02FE}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-

-

-Private Sub App_WorkbookOpen(ByVal wb As Workbook)

-    Dim wbname As String

-    If Application.Workbooks.count > 1 Then

-        wbname = wb.FullName

-        wb.Close Savechanges:=False

-        Shell "EXCEL " & wbname

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-mDataCommands
->>>>>>
-Attribute VB_Name = "mDataCommands"

-Option Explicit

-

-Sub evTicker_Change()

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("IDX_DEN_SECNAME") = .Range("IDX_DEN_SYMBOL")

-    End With

-    evHistory_Change

-End Sub

-

-Sub evSecName_Change()

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("IDX_DEN_SYMBOL") = .Range("IDX_DEN_SECNAME")

-    End With

-    evHistory_Change

-End Sub

-

-Sub evHistory_Change()

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("BOOL_DATA_READY") = False

-    End With

-End Sub

-

-Sub evSubmit_Click()

-    Dim ticker As String

-

-    Application.Cursor = xlWait

-    Dim wb As Workbook

-    Set wb = ThisWorkbook

-    With wb

-        With .Worksheets(VAR_SHEET)

-            ticker = .Range("DEN_SYMBOL")

-            If .Range("BOOL_DATA_DOWNLOAD") = True Or .Range("BOOL_DATA_READY") = False Then

-                .Range("BOOL_DATA_READY") = UpdateHistory(wb)

-                .Range("BOOL_DENMARK_READY") = False

-            End If

-        End With

-        If TDenmark_Calc Then

-            With .Worksheets(FORM_SHEET)

-                .Range("CALC_TICKER_NAME") = ticker

-            End With

-        End If

-    End With

-    Application.Cursor = xlDefault

-    

-End Sub

-

-Sub evGroupChange()

-    Dim GroupIdx, LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange As String

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        GroupIdx = .Range("IDX_DEN_LIST")

-        .Range("IDX_DEN_SYMBOL") = 1

-        NewRangeOffsetCol = (GroupIdx - 1) * 2

-        LinesCount = GetLinesCount(.Range("TICKER_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .name & "!" & .Range(.Range("TICKER_TABLES").Offset(1, NewRangeOffsetCol), .Range("TICKER_TABLES").Offset(LinesCount, NewRangeOffsetCol)).Address

-        ThisWorkbook.Worksheets(FORM_SHEET).Shapes("cbxTikers").ControlFormat.ListFillRange = NewCbxRange

-        NewRangeOffsetCol = NewRangeOffsetCol + 1

-        NewCbxRange = .name & "!" & .Range(.Range("TICKER_TABLES").Offset(1, NewRangeOffsetCol), .Range("TICKER_TABLES").Offset(LinesCount, NewRangeOffsetCol)).Address

-        ThisWorkbook.Worksheets(FORM_SHEET).Shapes("cbxSecName").ControlFormat.ListFillRange = NewCbxRange

-    End With

-    evTicker_Change

-End Sub

-

-Sub evUpdateTickerList()

-    UpdateTickerList ThisWorkbook

-    evHistory_Change

-End Sub

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Vars
->>>>>>
-Attribute VB_Name = "Vars"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-RawData
->>>>>>
-Attribute VB_Name = "RawData"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mWebGetData
->>>>>>
-Attribute VB_Name = "mWebGetData"

-Option Explicit

-

-Const QueryDataName As String = "ExternalRBCData"

-

-Dim mobjAppRunEnable As New cEnableRun

-

-Function UpdateHistory(wb As Workbook) As Boolean

-    Dim DestRangeName As String

-    Dim ResultLength As Integer

-    Dim QryPathStr As String

-    Dim Location As Range

-    Dim HistoryWindow As Integer

-    Dim IsIntraday As Boolean

-    Dim CalcNextTime As Boolean

-        

-    UpdateHistory = False

-    QryPathStr = GetQryPath(wb)

-    With wb

-        .Application.ScreenUpdating = False

-        With .Worksheets(VAR_SHEET)

-            DestRangeName = .Range("DEN_SYMBOL")

-            CalcNextTime = .Range("BOOL_NEXT_TIME")

-            HistoryWindow = .Range("DEN_WINDOW") + 1

-            If CalcNextTime Then

-                HistoryWindow = HistoryWindow + 1

-            End If

-            IsIntraday = IsNumeric(.Range("DEN_TIME"))

-        End With

-        With .Worksheets(RAW_DATA_SHEET)

-            .Range(PRICE_TABLE) = DestRangeName

-            'Clear table include temp area

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW - 1, RAW_DATA_RANGE_COL - 1), _

-                .Cells(65535, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-            ).ClearContents

-            Set Location = .Range(RAW_DATA_RANGE).Offset(-1, 0)

-            If Not QryExist(Location, QueryDataName) Then

-                QryCreate Location, QueryDataName, QryPathStr

-            Else

-                QryRefresh Location, QueryDataName, QryPathStr

-            End If

-            With Location.Worksheet.QueryTables(QueryDataName)

-                DestRangeName = .ResultRange.Name.RefersTo

-                ResultLength = .ResultRange.Count

-            End With

-    

-    '        .Parent.Application.DisplayAlerts = False

-            

-            .Range(DestRangeName).TextToColumns _

-                Destination:=.Range(DestRangeName), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=True, _

-                Semicolon:=True, _

-                Comma:=True, _

-                Space:=False, _

-                Other:=False, _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 1), _

-                                Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1))

-            

-    '        .Parent.Application.DisplayAlerts = True

-            Dim i, j, row_idx As Integer

-            Dim CurrentDate As String

-            Dim RawData As Range

-            

-            Set RawData = .Range(RAW_DATA_RANGE)

-            row_idx = 0

-            With RawData

-                CurrentDate = .Value

-                For i = 1 To ResultLength

-                    If Not IsIntraday And CurrentDate = .Offset(i, DATE_IDX).Value Then

-                        ' skip virtual prices

-                        If (.Offset(i, VOLUME_IDX) > MIN_PRICE_VALUE) Then

-                            If .Offset(row_idx, HIGH_IDX).Value < .Offset(i, HIGH_IDX).Value Then

-                                .Offset(row_idx, HIGH_IDX).Value = .Offset(i, HIGH_IDX).Value

-                            End If

-                            If .Offset(row_idx, LOW_IDX).Value > .Offset(i, LOW_IDX).Value Then

-                                .Offset(row_idx, LOW_IDX).Value = .Offset(i, LOW_IDX).Value

-                            End If

-                            .Offset(row_idx, VOLUME_IDX).Value = _

-                                .Offset(row_idx, VOLUME_IDX).Value + .Offset(i, VOLUME_IDX).Value

-                            .Offset(row_idx, TIME_IDX).Value = .Offset(i, TIME_IDX).Value

-                            .Offset(row_idx, CLOSE_IDX).Value = .Offset(i, CLOSE_IDX).Value

-                        End If

-                    Else

-                        ' skip virtual prices

-                        If (.Offset(row_idx, VOLUME_IDX) > MIN_PRICE_VALUE) Then

-                            row_idx = row_idx + 1

-                        End If

-                        For j = DATE_IDX To VOLUME_IDX

-                            .Offset(row_idx, j) = .Offset(i, j)

-                        Next j

-                        CurrentDate = .Offset(i, DATE_IDX)

-                    End If

-                Next i

-            End With ' RawData

-            ' Clear unused Cells

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(65536, RAW_DATA_RANGE_COL + VOLUME_IDX) _

-            ).ClearContents

-            

-            If row_idx > HistoryWindow Then

-                row_idx = row_idx - HistoryWindow

-                .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + VOLUME_IDX) _

-                ).Delete xlShiftUp

-            Else

-                Exit Function

-            End If

-            

-            row_idx = HistoryWindow + 1

-            

-            Set Location = .Range( _

-                .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_IDX) _

-            )

-            

-            Location.TextToColumns _

-                Destination:=Location.Offset(0, DATE_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:="/", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2))

-            

-            Location.Offset(0, TIME_IDX).TextToColumns _

-                Destination:=Location.Offset(0, TIME_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:=":", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2))

-            

-            ' Check estimation date

-            

-            Dim end_date, end_time As Date

-            Dim year, month, day As Integer

-            Dim hour, minute As Integer

-            Dim next_time_exist As Boolean

-            

-            year = Location.Cells(HistoryWindow - 1, DATE_STAMP_OFFSET + 3)

-            month = Location.Cells(HistoryWindow - 1, DATE_STAMP_OFFSET + 2)

-            day = Location.Cells(HistoryWindow - 1, DATE_STAMP_OFFSET + 1)

-            hour = Location.Cells(HistoryWindow - 1, TIME_STAMP_OFFSET + 1)

-            minute = Location.Cells(HistoryWindow - 1, TIME_STAMP_OFFSET + 2)

-            

-            next_time_exist = day + month + year <> 0

-            

-            If next_time_exist Then

-                end_date = DateSerial(year, month, day)

-                end_time = TimeSerial(hour, minute, 0)

-                mobjAppRunEnable.EnableRun ESTIMATION_DATE, end_date

-            End If

-             

-            row_idx = 0

-            Dim temp_str As String

-                    

-            If IsIntraday Then

-                Do While IsEmpty(Location.Cells(1 + row_idx, 1 + DATE_IDX)) = False

-                       temp_str = Location.Cells(1 + row_idx, 1 + VOLUME_IDX + 1)

-                       temp_str = temp_str & "/"

-                       temp_str = temp_str & Location.Cells(1 + row_idx, 1 + VOLUME_IDX + 2)

-                       temp_str = temp_str & "-"

-                       temp_str = temp_str & Location.Cells(1 + row_idx, 1 + TIME_IDX)

-                       Location.Cells(1 + row_idx, DATE_IDX) = temp_str

-                       row_idx = row_idx + 1

-                Loop

-                row_idx = row_idx - 1

-                Dim condition As Boolean

-                condition = Not CalcNextTime And next_time_exist And end_date = DateValue(Now) And end_time > TimeValue(Now)

-                If condition Then

-                    .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL - 1), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-                    ).Delete xlShiftUp

-                End If

-            Else

-                Do While IsEmpty(Location.Cells(1 + row_idx, 1 + DATE_IDX)) = False

-                       temp_str = "'" & Location.Cells(1 + row_idx, 1)

-                       Location.Cells(1 + row_idx, DATE_IDX) = temp_str

-                       row_idx = row_idx + 1

-                Loop

-                row_idx = row_idx - 1

-                condition = Not CalcNextTime And next_time_exist And end_date = DateValue(Now) And TimeValue(Now) < TimeSerial(18, 0, 0)

-                If condition Then

-                    .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL - 1), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-                    ).Delete xlShiftUp

-                End If

-            End If

-        End With ' .Worksheets(RAW_DATA_SHEET)

-    End With ' wb

-    UpdateHistory = True

-End Function

-

-Private Function GetQryPath(wb As Workbook) As String

-    Dim QryPathStr As String

-    Dim IsIntradai As Boolean

-    Dim DayCount As Integer

-    With wb.Worksheets(VAR_SHEET)

-        QryPathStr = "URL;http://online.rbc.ru/cgi-bin/online/nph-single-old.cgi?"

-        QryPathStr = QryPathStr & "ticker=" & .Range("DEN_SYMBOL")

-        QryPathStr = QryPathStr & "&source=" & .Range("DEN_SOURCE")

-        QryPathStr = QryPathStr & "&board=" & .Range("DEN_BOARD")

-        IsIntradai = IsNumeric(.Range("DEN_TIME"))

-        If IsIntradai Then

-            QryPathStr = QryPathStr & "&period=" & .Range("DEN_TIME")

-        Else

-            QryPathStr = QryPathStr & "&period=60"

-        End If

-        QryPathStr = QryPathStr & "&oh=11&ch=18"

-        QryPathStr = QryPathStr & "&separator=%2C"

-        QryPathStr = QryPathStr & "&vmode=Ignore&vtype=BA2"

-        QryPathStr = QryPathStr & "&format=Excel"

-        

-        If IsIntradai Then

-            DayCount = .Range("DEN_HISTORY") * .Range("DEN_TIME") \ 420 + 1 + .Range("DEN_HISTORY")

-        Else

-            DayCount = .Range("DEN_HISTORY")

-        End If

-        QryPathStr = QryPathStr & "&daysback=" & DayCount

-'        .Range("LAST_HIST_QRY") = QryPathStr

-    End With

-    GetQryPath = QryPathStr

-    

-End Function

-

-Sub UpdateTickerList(wb As Workbook)

-    Dim idx, n As Integer

-    Dim ResultLength As Integer

-    Dim Location As Range

-    Dim QryPathStr As String

-    Dim QueryDataName As String

-    Dim DestRangeArea As String

-    

-    QryPathStr = GetListPath(wb)

-    With wb

-        With .Worksheets(VAR_SHEET)

-            idx = .Range(IDX_SRC_NAME)

-            Set Location = .Range(TICKER_TABLES).Offset(0, (idx - 1) * 2)

-             .Range(IDX_SEC_SYMBOL) = 1

-            QueryDataName = Location.Offset(0, 0)

-            'Clear table

-            .Range(Location.Offset(1, 0), Location.Offset(65535 - Location.Row, 1)).ClearContents

-            

-            If Not QryExist(Location.Offset(1, 0), QueryDataName) Then

-                QryCreate Location.Offset(1, 0), QueryDataName, QryPathStr

-            Else

-                QryRefresh Location.Offset(1, 0), QueryDataName, QryPathStr

-            End If

-            ' Remove header

-            ' Find [DATA]

-            n = 0

-            Do While Location.Offset(n, 0) <> "[DATA]"

-                n = n + 1

-            Loop

-            .Range(Location.Offset(1, 0), Location.Offset(n, 1)).Delete Shift:=xlUp

-            With .QueryTables(QueryDataName)

-                DestRangeArea = .ResultRange.Name.RefersTo

-                ResultLength = .ResultRange.Count

-            End With

-        

-        '        .Parent.Application.DisplayAlerts = False

-                

-            .Range(DestRangeArea).TextToColumns _

-                Destination:=.Range(DestRangeArea), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=True, _

-                Semicolon:=True, _

-                Comma:=True, _

-                Space:=False, _

-                Other:=False, _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 9))

-        ' Sort Data

-            Set Location = .Range(.Range(DestRangeArea).Offset(0, 0), .Range(DestRangeArea).Offset(ResultLength - 1, 1))

-            Location.Sort _

-                Key1:=.Range(DestRangeArea).Offset(0, 0), _

-                Order1:=xlAscending, _

-                Header:=xlNo, _

-                OrderCustom:=1, _

-                MatchCase:=False, _

-                Orientation:=xlTopToBottom

-        End With

-    End With

-End Sub

-

-Private Function GetListPath(wb As Workbook) As String

-    Dim QryPathStr As String

-    With wb.Worksheets(VAR_SHEET)

-        QryPathStr = "URL;http://online.rbc.ru/cgi-bin/names.cgi?"

-        QryPathStr = QryPathStr & "&source=" & .Range(SEL_SOURCE)

-        QryPathStr = QryPathStr & "&board=" & .Range(SEL_BOARD)

-        QryPathStr = QryPathStr & "&category=STOCKS"

-        '.Range("LAST_DIR_QRY") = QryPathStr

-    End With

-    GetListPath = QryPathStr

-End Function

-

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "RBC online connection kit"

-Public Const PROGRAM_VERSION As String = "version 1.0"

-

-' Estimation dates

-'-----------------------------------

-Public Const NO_ESTIMATION_DATE As Long = -1

-

-' Public Const ESTIMATION_DATE As Long = 19980915

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-' Private Sheet Vars

-'-----------------------------------

-Public Const VAR_SHEET = "Vars"

-

-Public Const LIST_SRC_NAME = "LIST_SRC_NAME"

-Public Const LIST_SRC_TICKER = "LIST_SRC_TICKER"

-Public Const LIST_SRC_BRD = "LIST_SRC_BRD"

-Public Const LIST_PERIODICITY = "LIST_PERIODICITY"

-

-Public Const IDX_SRC_NAME = "IDX_SRC_NAME"

-Public Const IDX_SEC_SYMBOL = "IDX_SEC_SYMBOL"

-Public Const IDX_SEC_NAME = "IDX_SEC_NAME"

-Public Const IDX_PERIODICITY = "IDX_PERIODICITY"

-Public Const IDX_WINDOW = "IDX_WINDOW"

-Public Const IDX_MARGIN = "IDX_MARGIN"

-

-Public Const SEL_SOURCE = "SEL_SOURCE"

-Public Const SEL_BOARD = "SEL_BOARD"

-Public Const SEL_SEC_SYMBOL = "SEL_SEC_SYMBOL"

-Public Const SEL_SEC_NAME = "SEL_SEC_NAME"

-Public Const SEL_PERIODICITY = "SEL_PERIODICITY"

-Public Const SEL_WINDOW = "SEL_WINDOW"

-Public Const SEL_MARGIN = "SEL_MARGIN"

-Public Const SEL_HISTORY = "SEL_HISTORY"

-Public Const SEL_NEXT_INTERVAL = "SEL_NEXT_INTERVAL"

-

-Public Const TICKER_TABLES = "TICKER_TABLES"

-

-' Private Sheet RawData

-'-----------------------------------

-Public Const RAW_DATA_SHEET As String = "RawData"

-Public Const PRICE_TABLE As String = "B1"

-Public Const RAW_DATA_RANGE As String = "B3"

-Public Const RAW_DATA_RANGE_COL As Integer = 2

-Public Const RAW_DATA_RANGE_ROW As Integer = 3

-

-

-' Fields indexes in RAW_DATA_RANGE

-Public Const DATE_IDX As Integer = 0

-Public Const TIME_IDX As Integer = 1

-Public Const OPEN_IDX As Integer = 2

-Public Const CLOSE_IDX As Integer = 3

-Public Const LOW_IDX As Integer = 4

-Public Const HIGH_IDX As Integer = 5

-Public Const VOLUME_IDX As Integer = 6

-Public Const DATE_STAMP_OFFSET = VOLUME_IDX + 1

-Public Const TIME_STAMP_OFFSET = VOLUME_IDX + 4

-Public Const DATE_TIME_STAMP_SIZE = 5

-

-' Prices table constants

-'-----------------------------------

-Public Const MIN_PRICE_VALUE = 1

-<<<<<<
-======================
-mWebQuery
->>>>>>
-Attribute VB_Name = "mWebQuery"

-Option Explicit

-

-Public Const Qry_DELETE_ALL As String = "Qry_DELETE_ALL"

-Public Const Qry_PATH_NO_CHANGE As String = "Qry_PATH_NO_CHANGE"

-

-

-Sub QryCreate(QryRange As Range, QryName As String, QryPath As String, Optional RefreshBkgnd = False)

-    Dim WebQuery As QueryTable

-    QryDelete QryRange:=QryRange, QryName:=QryName

-    

-    Set WebQuery = QryRange.Worksheet.QueryTables.Add( _

-            Connection:=QryPath, _

-            Destination:=QryRange)

-    

-    With WebQuery

-        .FieldNames = False

-        .Name = QryName

-        .RefreshStyle = xlOverwriteCells

-        .RowNumbers = False

-        .FillAdjacentFormulas = False

-        .RefreshOnFileOpen = False

-        .HasAutoFormat = False

-        .BackgroundQuery = False

-        .TablesOnlyFromHTML = False

-        .Refresh BackgroundQuery:=RefreshBkgnd

-        .SavePassword = False

-        .SaveData = True

-    End With

-End Sub

-

-Function QryRefresh(QryRange As Range, QryName As String, Optional QryPath As String = Qry_PATH_NO_CHANGE, Optional Background As Boolean = False) As Boolean

-    Dim qry_result As Boolean

-    qry_result = False

-    If QryExist(QryRange, QryName) Then

-        With QryRange.Worksheet.QueryTables(QryName)

-            If QryPath <> Qry_PATH_NO_CHANGE Then

-                .Connection = QryPath

-            End If

-            .Refresh BackgroundQuery:=Background

-            qry_result = True

-        End With

-    End If

-    QryRefresh = qry_result

-End Function

-

-Sub QryDelete(QryRange As Range, Optional QryName As String = Qry_DELETE_ALL)

-    Dim WebQuery As QueryTable

-    For Each WebQuery In QryRange.Worksheet.QueryTables

-        If QryName = Qry_DELETE_ALL Or WebQuery.Name = QryName Then

-            WebQuery.Delete

-        End If

-    Next

-End Sub

-

-Function QryExist(QryRange As Range, QryName As String) As Boolean

-    Dim WebQuery As QueryTable

-    For Each WebQuery In QryRange.Worksheet.QueryTables

-        If WebQuery.Name = QryName Then

-            QryExist = True

-            Exit For

-        End If

-    Next

-End Function

-

-

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim curdate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    curdate = year * 10000

-    curdate = curdate + month * 100

-    curdate = curdate + day

-    If curdate > end_date Then

-        subAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-

-<<<<<<
-======================
-mInterface
->>>>>>
-Attribute VB_Name = "mInterface"

-Option Explicit

-

-Public Function fnSourceGetCount() As Integer

-    fnSourceGetCount = ThisWorkbook.Sheets(VAR_SHEET).Range(LIST_SRC_NAME).Rows.Count

-End Function

-

-Public Function fnSourceGetListItem(ByVal ItemIdx As Integer) As String

-    If ItemIdx >= 1 And ItemIdx <= fnSourceGetCount Then

-        fnSourceGetListItem = ThisWorkbook.Sheets(VAR_SHEET).Range(LIST_SRC_NAME).Cells(ItemIdx, 1)

-    Else

-        fnSourceGetListItem = ""

-    End If

-End Function

-

-Public Function fnSourceGetListItemIndex(ByRef ItemName As String) As Integer

-    Dim i, Res As Integer

-    Res = -1

-    For i = 1 To fnSourceGetCount

-        If ThisWorkbook.Sheets(VAR_SHEET).Range(LIST_SRC_NAME).Cells(i, 1) = ItemName Then

-            Res = i

-            Exit For

-        End If

-    Next i

-    fnSourceGetListItemIndex = Res

-End Function

-

-Public Sub subSourceListItemSelect(ByVal ItemIdx As Integer)

-    If ItemIdx >= 1 And ItemIdx <= fnSourceGetCount Then

-        ThisWorkbook.Sheets(VAR_SHEET).Range(IDX_SRC_NAME) = ItemIdx

-    End If

-End Sub

-

-Public Function fnSourceListItemGetSelected() As Integer

-    fnSourceListItemGetSelected = ThisWorkbook.Sheets(VAR_SHEET).Range(IDX_SRC_NAME)

-End Function

-

-Public Sub subSourceUpdateTickerList()

-    UpdateTickerList ThisWorkbook

-End Sub

-

-Public Function fnTickerGetCount(SrcIdx As Integer) As Integer

-

-End Function

-

-'fnTickerGetListItem(SrcIdx as Integer, idx as Integer) as String

-'fnTickerSetCombo(ComboBox as Shape) as Integer;

-'fnTickerGetListItemIndex(SrcIdx as Integer, ItemName as String) as Integer

-

-'fnNameGetCount(SrcIdx as Integer) as Integer

-'fnNameGetListItem(SrcIdx as Integer, idx as Integer) as String;

-'fnNameSetCombo(ComboBox as Shape) as Integer;

-'fnNameGetListItemIndex(SrcIdx as Integer, ItemName as String) as Integer;

-

-'fnIntervalGetCount(SrcIdx as Integer) as Integer

-'fnIntervalGetListItem(SrcIdx as Integer, idx as Integer) as String;

-'fnIntervalSetCombo(ComboBox as Shape) as Integer;

-'fnIntervalGetListItemIndex(SrcIdx as Integer, ItemName as String) as Integer;

-

-'fnEnableNextInterval(Enable as Boolean) as Boolean;

-

-'fnUpdateHistory(Src as Integer, Ticker as Integer, Periodicity as Integer, Window as Integer, Margin as Integer, OutRange as Range) as Integer;

-'fnUpdateHistoryDialog(OutRange as Range) as Integer;

-

-Sub subAbout()

-    dlgAbout.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlgAbout.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlgAbout.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlgAbout.Show

-End Sub

-

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{17BC5A78-8DD4-11D2-B34E-525400DB02FE}{17BC5A6E-8DD4-11D2-B34E-525400DB02FE}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Private Sub CommandButton1_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub DataProvider_Click()

-    ActiveWorkbook.FollowHyperlink Address:="http://www.rbc.ru/", _

-    NewWindow:=True

-End Sub

-<<<<<<
-======================
-aTest
->>>>>>
-Attribute VB_Name = "aTest"

-Option Explicit

-

-Sub Test()

-    subSourceListItemSelect 1

-End Sub

-

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Sub Macro1()

-Attribute Macro1.VB_Description = "Macro recorded 07.12.98 by Nickolai Garbuz"

-Attribute Macro1.VB_ProcData.VB_Invoke_Func = " \n14"

-'

-' Macro1 Macro

-' Macro recorded 07.12.98 by Nickolai Garbuz

-'

-

-'

-    ActiveSheet.Shapes("Drop Down 1").Select

-    With Selection

-        .ListFillRange = "LIST_SRC_NAME"

-        .LinkedCell = "IDX_SRC_NAME"

-        .DropDownLines = 8

-        .Display3DShading = False

-    End With

-End Sub

-<<<<<<
-Project Name : '000.xls'
-Quirk - duff tag length======================
-Sum in Words
->>>>>>
-Attribute VB_Name = "Sum in Words"

-

-Dim DAN_NAMES

-Dim DAN_100S

-Dim Dan_20S

-Dim DAN_10S

-Dim DAN_1S

-

-Dim Limit  As Double

-Dim TempStr As String

-Dim A As Double

-Dim B As Double

-Dim OffsetM As Integer

-Dim OffsetOne As Integer

-Dim OffsetDec As Integer

-Dim Kop As Integer

-Dim REnd As Integer

-Dim M As Integer

-

-

-

-Function СумПроп(Val) As String

-Attribute СумПроп.VB_ProcData.VB_Invoke_Func = " \n14"

- 

-    DAN_NAMES = Array("МИЛЛИАРД ", "МИЛЛИАРДA ", "МИЛЛИАРДОВ", "МИЛЛИОН ", "МИЛЛИОНА ", "МИЛЛИОНОВ ", "ТЫСЯЧА ", "ТЫСЯЧИ ", "ТЫСЯЧ ")

-    DAN_100S = Array("СТО", "ДВЕСТИ ", "ТРИСТА ", "ЧЕТЫРЕСТА ", "ПЯТЬСОТ ", "ШЕСТЬСОТ ", "СЕМЬСОТ ", "ВОСЕМЬСОТ ", "ДЕВЯТЬСОТ ")

-    Dan_20S = Array("ДВАДЦАТЬ", "ТРИДЦАТЬ ", "СОРОК ", "ПЯТЬДЕСЯТ ", "ШЕСТЬДЕСЯТ ", "СЕМЬДЕСЯТ ", "ВОСЕМЬДЕСЯТ ", "ДЕВЯНОСТО ")

-    DAN_10S = Array("ДЕСЯТЬ", "ОДИННАДЦАТЬ", "ДВЕНАДЦАТЬ", "ТРИНАДЦАТЬ", "ЧЕТЫРНАДЦАТЬ", "ПЯТНАДЦАТЬ", "ШЕСТНАДЦАТЬ", "СЕМНАДЦАТЬ", "ВОСЕМНАДЦАТЬ", "ДЕВЯТНАДЦАТЬ")

-    DAN_1S = Array("ОДИН", "ДВА", "ТРИ", "ЧЕТЫРЕ", "ПЯТЬ", "ШЕСТЬ", "СЕМЬ", "ВОСЕМЬ", "ДЕВЯТЬ", "ОДНА", "ДВE", "ТРИ", "ЧЕТЫРЕ", "ПЯТЬ", "ШЕСТЬ", "СЕМЬ", "ВОСЕМЬ", "ДЕВЯТЬ")

-    Limit = 10 ^ 12

-    TempStr = ""

-    B = 0

-    OffsetM = 0

-    OffsetOne = 0

-    OffsetDec = 0

-    Kop = 0

-    REnd = 0

-    M = 0

-    

-    ' Val = Left(Val, Len(Val) - 3) & "." & Right(Val, 2)

-    Kop = (Val - Int(Val)) * 100   'Копейки

-    

-    If Val > Limit Then

-         Beep

-         СумПроп = "Переполнение !!!"

-         Exit Function

-   End If

-   

-   Val = Int(Val)

-    If Val = 0 Then

-        TempStr = "НОЛЬ"

-    End If

-    Do Until Int(Limit) <= 0

-        Limit = Limit / 1000

-        B = Int(Val / Limit)

-   

-        If Limit = 1000 Then OffsetOne = 9

-        If B > 0 Then MakeStr

-        Val = Val - B * Limit

-        OffsetOne = 0

-        OffsetM = OffsetM + 3

-    Loop

-Kopeyki:

-     

-    If Kop > 9 Then

-        СумПроп = TempStr & "  рублей " '& Str$(Kop) & "коп."

-    Else

-          СумПроп = TempStr & "  pублей" ' 00 коп."

-    End If

-   

- End Function

-

-Sub MakeStr()

-Attribute MakeStr.VB_ProcData.VB_Invoke_Func = " \n14"

-

-    If B = 0 Then GoTo Ex

-    REnd = B

-    OffsetDec = Int(REnd / 100)

-    If OffsetDec > 0 Then Make100

-    REnd = REnd - OffsetDec * 100

-    If REnd >= 20 Then

-        OffsetDec = Int(REnd / 10)

-        If OffsetDec > 0 Then Make20

-        REnd = REnd - OffsetDec * 10

-        If REnd > 0 Then Make1

-    Else

-        If REnd > 9 Then

-            Make10

-        Else

-            If REnd > 0 Then Make1

-        End If

-    End If

-    If REnd >= 5 Or REnd = 0 Then

-       M = 2

-    Else

-        If REnd >= 2 Then M = 1 Else M = 0

-   End If

-    If Limit <> 1 Then MakeName

-Ex:

-    End Sub

-    

-Sub Make100()

-Attribute Make100.VB_ProcData.VB_Invoke_Func = " \n14"

-    TempStr = Trim$(TempStr) + " " + DAN_100S(OffsetDec - 1)

-End Sub

-           

-Sub Make20()

-Attribute Make20.VB_ProcData.VB_Invoke_Func = " \n14"

-    TempStr = Trim$(TempStr) + " " + Trim$(Dan_20S(OffsetDec - 2))

-End Sub

-

-Sub Make10()

-Attribute Make10.VB_ProcData.VB_Invoke_Func = " \n14"

-    TempStr = Trim$(TempStr) + " " + DAN_10S(REnd - 10)

-End Sub

-      

-Sub Make1()

-Attribute Make1.VB_ProcData.VB_Invoke_Func = " \n14"

-     TempStr = Trim$(TempStr) + " " + Trim$(DAN_1S(REnd + OffsetOne - 1))

-End Sub

-     

-Sub MakeName()

-Attribute MakeName.VB_ProcData.VB_Invoke_Func = " \n14"

-    TempStr = Trim$(TempStr) + " " + Trim$(DAN_NAMES(OffsetM + M)) '10

-'    TempStr = Trim$(TempStr) + " " + Trim$(DAN_NAMES(2))

-End Sub

- 

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mRead
->>>>>>
-Attribute VB_Name = "mRead"

-Option Explicit

-' Mодули для чтения данных с листа

-

-

-

-Sub ReadData1(aPoint As String, dt As Integer, _

-              p As PriceData)

-'Инициализация типа PriceData из таблицы типа - 1

-'kопируются не более чем hist последних строк

-'aPoint - начало таблицы

-'Hist - заданная история - модифицируется,

-'       если  заказанная история больше фактической

-' dt -  шаг по времени - определяет базовый интервал

-' Результат: история цен - p As PriceData

-'прим. первые две строки таблицы идентифицирует данные (строки)

- Dim n As Integer, i As Integer

-'Определение числа строк таблицы - n

- Dim theRange As Range

- Set theRange = ActiveSheet.Range(aPoint)

- n = 0

- Do While IsEmpty(theRange.Offset(n, 0).Value) = False

-     n = n + 1

- Loop

- If n = 0 Then             'обработать ошибку

-    p.nWin = 0

-    GoTo done

- End If

-' число строк определено ()

- If p.nWin > (n - 3) \ dt + 1 Then ' коррекция истории

-    p.nWin = (n - 3) \ dt + 1 '

- End If

- Dim t As Integer, s As Integer

- For t = 0 To p.nWin - 1

-      s = n - t * dt - 1

-      p.D(p.nWin - t) = theRange.Offset(s, 0).Value

-      p.O(p.nWin - t) = theRange.Offset(s, 1).Value

-      p.H(p.nWin - t) = theRange.Offset(s, 2).Value

-      p.L(p.nWin - t) = theRange.Offset(s, 3).Value

-      p.C(p.nWin - t) = theRange.Offset(s, 4).Value

-      p.V(p.nWin - t) = theRange.Offset(s, 5).Value

- Next t

-done:

-End Sub

-

-

-Function StrNum(aPoint As String)

-' возвращает число строк таблицы

- Dim theRange As Range

- Set theRange = ActiveSheet.Range(aPoint)

- StrNum = 0

- Do While IsEmpty(theRange.Offset(StrNum, 0).Value) = False

-     StrNum = StrNum + 1

- Loop

-End Function

-

-

-<<<<<<
-======================
-mModel1
->>>>>>
-Attribute VB_Name = "mModel1"

-Option Explicit

-

-'Type Model_1                 ' параметры модели -1

-'     tE As Integer           ' размер окна данных

-'     nAuto  As Integer       ' порядок авторегрессии

-'     nDiff As Integer        ' порядок порядок разности

-'     nFac  As Integer        ' число факторов

-'     a() As Double           'веса авторегрессии

-'     b() As Double           'веса факторов

-'     Var As Double           'вариация ошибки

-'

-'     alfa  As Double         ' порядок скользящего среднего

-'     x() As Double           ' исходный ряд

-'     y() As Double           ' ряд разностей

-'     u As Variant            ' факторы

-

-Sub InitModel1(Point As String, tEnd As Integer, p As Model_1)

-' Инициализация основных параметров и выделение памяти

-' tE - определен

-Dim theRange As Range

-Set theRange = ActiveSheet.Range(Point) 'Точка ввода осн. данных

-p.tE = tEnd

-p.alfa = 2 / (theRange.Offset(0, 0).Value + 1)

-p.nAuto = theRange.Offset(1, 0).Value

-p.nDiff = theRange.Offset(2, 0).Value

-p.nFac = theRange.Offset(3, 0).Value

-p.Omega = theRange.Offset(4, 0).Value

-p.Acc = theRange.Offset(5, 0).Value

-

-ReDim p.a(1 To AUTO_MAX) As Double

-ReDim p.b(1 To FAC_MAX) As Double

-ReDim p.x(1 To tEnd) As Double, p.y(1 To tEnd) As Double

-ReDim p.u(1 To FAC_MAX, 1 To tEnd) As Double

-End Sub

-Sub InitMemory(p As Model_1)

-' выделение памяти для Model_1

-' tE - определен

-ReDim p.a(1 To AUTO_MAX) As Double

-ReDim p.b(1 To FAC_MAX) As Double

-ReDim p.x(1 To tEnd) As Double, p.y(1 To tEnd) As Double

-ReDim p.u(1 To FAC_MAX, 1 To tEnd) As Double

-End Sub

-

-Sub EraseModel_1(p As Model_1)

-'

- Erase p.a

- Erase p.b

- Erase p.x

- Erase p.y

- Erase p.u

-End Sub

-

-Function tNoise1(p As Model_1)

-'Определение левой границы dom{Noise} в случае одного фактора

-' tu --> tNoise

-p.tNoise = p.p + p.nDiff + 1

-If p.tNoise < p.tu Then

-   p.tNoise = p.tu

-End If

-End Function

-

-' Estimation *************************************

-

-Function SSum(p As Model_1)  ' o'key

-'сумма квадратов остатков Model_1-процесса

-' < a,b;nDiff,nAuto,nFac,y,tNoise > ---> SSum(a,b)

-

-Dim noise As Double, val As Double

-Dim t As Integer, i As Integer

-SSum = 0

-For t = p.tNoise To p.tE

-' Noise = Noise(t) definition ----------------

-  noise = p.y(t)

-  For i = 1 To p.nAuto

-     noise = noise + p.a(i) * p.y(t - i)

-  Next i

-  For i = 1 To p.nFac

-     noise = noise - p.b(i) * p.u(i, t - 1)

-  Next i

-' Noise(t) is defined------------------------

-  val = noise * noise

-  If p.Omega < 1 Then

-     val = p.Omega ^ (p.tE - t) * val

-  End If

-  SSum = SSum + val

-Next t

-End Function

-

-Sub GradSSum(x() As Double, p As Model_1, grad() As Double)

-'градиент взвешенной суммы квадратов остатков Model_1

-' в точке x = {a,b}

-Dim t As Integer, i As Integer

-Dim noise As Double, V As Double

-For i = 1 To p.nAuto + p.nFac    'dim of the problem = p.nAuto + p.nFac

-  grad(i) = CDbl(0)

-Next i

-For t = p.tNoise To p.tE

-   

-'  Noise = Noise(t) definition ----------------

-   noise = p.y(t)

-   For i = 1 To p.nAuto

-     noise = noise + x(i) * p.y(t - i)

-   Next

-   For i = 1 To p.nFac

-     noise = noise - x(p.nAuto + i) * p.u(i, t - 1)

-   Next i

-'  Noise(t) is defined------------------------

-   If p.Omega < 1 Then

-      noise = noise * p.Omega ^ (p.tE - t)

-   End If

-   For i = 1 To p.nAuto

-      grad(i) = grad(i) + p.y(t - i) * noise

-   Next i

-   For i = 1 To p.nFac

-      grad(p.nAuto + i) = grad(p.nAuto + i) - p.u(i, t - 1) * noise

-   Next i

-Next t

-

-For i = 1 To p.nAuto + p.nFac

-       grad(i) = 2 * grad(i)

-Next i

-

-End Sub

-

-Sub DetNoise(p As Model_1, noise() As Double)  ' ??? ошибка, исправить

-' <p,d, a,b,y, tNoise > --> Noise

-'Определение шума в Model_1 - модели в стандартном случае

-'определение шума по рядy разностей y, dom(y) = [d+1,tx]

-'dom(noise) = [tNoise , tE]

-Dim t As Integer, i As Integer

-For t = p.tNoise To p.tE

-  noise(t) = p.y(t)

-  For i = 1 To p.nAuto

-     noise(t) = noise(t) + p.a(i) * p.y(t - i)

-  Next

-  For i = 1 To p.nFac

-     noise(t) = noise(t) - p.b(i) * p.u(i, t - 1)

-  Next i

-Next t

-End Sub

-Sub VarNoise(p As Model_1)

-' <p,d, a,b,y, tNoise > --> Noise

-'Определение вариации остаточного шума = вариация ошибки прогноза

-'dom(noise) = [tNoise, tE]

-Dim t As Integer, i As Integer, noise As Double

-p.var = 0

-For t = p.tNoise To p.tE

-  noise = p.y(t)

-  For i = 1 To p.nAuto

-     noise = noise + p.a(i) * p.y(t - i)

-  Next

-  For i = 1 To p.nFac

-    noise = noise - p.b(i) * p.u(i, t - 1)

-  Next i

-  p.var = p.var + noise * noise

-Next t

-p.var = p.var / (p.tE - p.tNoise + 1)

-End Sub

-

-

-'************************************************************************

-Sub EffFactor1(p As Model_1, Factor() As Double, tFactor As Integer, _

-               Status As Integer, Corr As Double) 'выходные параметры

-' Оценка эффективности однофакторной модели

-' Factor  фактор

-' Исходные данные: cм. InitModel1

-' tE          размер окна данных

-' nAuto       порядок авторегрессии

-' nDiff       порядок порядок разности

-' nFac = 1    число факторов

-' Omega       параметр оптимизации

-' x,y = Diff(x, nDiff) ряд разностей - определены

-' u(1,1:tE) фактор

-' Factor -  фактор

-' tFactor - левая граница области определения фактора

-' Результат:

-' Status - статус вычислений, уровень корреляции c изменением x,

-' стандартная ошибка прогноза - Var( ст. ошибка остаточного шума )

-  p.tu = tFactor

-' Корреляция ----------------------------------------------------

-  Dim tCorr As Integer

-  tCorr = p.nDiff + 1  '

-  If tCorr < p.tu Then

-     tCorr = p.tu

-  End If

-  Corr = CorrXY(p.y, Factor, tCorr, p.tE, s:=1, ind:=1)

-' Влияние Factor на y c задержкой 1

-' Все корреляция ------------------------------------------------

-

-'Оценка модели с этим фактором ----------------------------------

- p.tNoise = p.nAuto + p.nDiff + 1

- If p.tNoise < p.tu Then

-   p.tNoise = p.tu

- End If   '  tNoise is defined

- Dim t As Integer

- For t = 1 To p.tE    'u(1,.) <-- Indicator

-    p.u(1, t) = Factor(t)

- Next t

- 

-'eps = Acc * 0.00001

-'ConjGrad1 MODEL1, 0.000000001, Status

- nConjGrad1 p, p.Acc * 0.001, Status          ', Acc

- VarNoise p  ' вариация остаточного шума

-'Все - Оценка модели с этим фактором --------------------------

-End Sub

-

-

-Sub nConjGrad1(ptr As Model_1, eps As Double, _

-               Status As Integer)   ' , Accuracy As Double)

-'   Оценка параметров AR-модели по реализации y(t)

-'   исходные данные:

-'   y(1:ty), dom(y)= [ts,ty]

-'   pa - порядок авторегрессии

-'   eps - точность определения параметров a(1:p)

-'   результат:

-'   a(1:pa) - параметры авторегрессии

-'   var - вариация белого шума

-'   Status = 1 - точность достигнута

-    Dim r As Double, r1 As Double, alfa As Double, beta As Double

-    Dim nDim As Integer, m As Integer, i As Integer, k As Integer

-    nDim = ptr.nAuto + ptr.nFac

-    ReDim x(1 To nDim) As Double

-    ReDim grad(1 To nDim) As Double

-    ReDim grad0(1 To nDim) As Double

-    ReDim p(1 To nDim) As Double

-    

-'--------------------------------------------

-'--------------------------------------------

-'   x optimization point

-

-    For i = 1 To nDim     ' init data x <-- 0 x = {a,b}

-        x(i) = CDbl(0)

-    Next i

-'   DetGrad x, grad0, n 'grad <-- grad(0)

-    GradSSum x, ptr, grad0

-    Status = 0

-'------------------------------------------

-For m = 1 To 10 * nDim     '

-    For i = 0 To nDim - 1 ' ------------------------------

-'       1. grad and r - determination at x = x(i)

-'       DetGrad x, grad, n 'grad <-- grad(x)

-        GradSSum x, ptr, grad

-        r = 0        'r <-- |grad(x)|

-        For k = 1 To nDim

-            r = r + grad(k) * grad(k)

-        Next k

-

-'       2. .....

-'       Accuracy = Sqr(r)   ' точность по градиенту

-        If Sqr(r) <= eps Then

-           For k = 1 To ptr.nAuto

-               ptr.a(k) = x(k)

-           Next k

-           For k = 1 To ptr.nFac

-               ptr.b(k) = x(ptr.nAuto + k)

-           Next k

-           ptr.oVar = SSum(ptr)

-           Status = 1

-           GoTo done

-        End If

-'3      beta determination

-        If i > 0 Then

-           beta = r / r1

-        End If

-'4      p - мodification

-        For k = 1 To nDim

-            If i = 0 Then

-               p(k) = grad(k)

-            Else

-               p(k) = grad(k) + beta * p(k)

-            End If

-        Next k

-'5      alfa = -(p,grad(x))/(p,Cp) determination;  s = (p,Cp)

-        alfa = CDbl(0)

-        For k = 1 To nDim ' alfa = (p,grad(x))

-            alfa = alfa + p(k) * grad(k)

-        Next k

-        

-'       DetGrad p, grad, n

-        GradSSum p, ptr, grad

-        r1 = CDbl(0)

-        For k = 1 To nDim ' beta = (p,grad(p)-grad(0))

-            r1 = r1 + p(k) * (grad(k) - grad0(k)) ' !!! i = 0

-        Next k

-        alfa = -alfa / r1 '!? +

-'6      x() modification

-        r1 = CDbl(0)

-        For k = 1 To nDim  ' beta = (p,grad(x))

-            r1 = r1 + Abs(alfa * p(k))

-        Next k

-        For k = 1 To nDim   ' beta = (p,grad(x))

-           x(k) = x(k) + alfa * p(k)

-        Next k

-'*      модификация r1

-        r1 = r  '!

-    Next i

-Next m

-    

-Erase grad

-Erase grad0

-Erase p

-Erase x

-

-'For k = 1 To ptr.nAuto

-'   ptr.a(k) = x(k)

-'Next k

-'For k = 1 To ptr.nFac

-'    ptr.b(k) = x(ptr.nAuto + k)

-'Next k

-'ptr.oVar = SSum(ptr)

-

-done:

-End Sub

-

-Function xForecast(t As Integer, p As Model_1) As Double

-' Прогноз x(t+1) в момент t, tf <= t <= tE, tf = max{nAuto,tu}

-ReDim ad(1 To p.nAuto + p.nDiff + 1) As Double

-DetAD p, ad

-Dim i As Integer

-xForecast = 0

-For i = 1 To p.nAuto + p.nDiff

-    xForecast = xForecast - ad(i) * p.x(t + 1 - i)

-Next i

-For i = 1 To p.nFac

-    xForecast = xForecast + p.b(i) * p.u(i, t)

-Next i

-End Function

-

-Sub DetAD(ptr As Model_1, ad() As Double) ' ???

-' определение Ad(D) = A(D)*(1-D)^d = 1 + ad(1)D + .... +ad(p+d)D^(p+d)

-' Dx(t)= x(t-1)

-' dim(a) = p+d

-  Dim i As Integer, r As Integer

-  If ptr.nAuto = 0 And ptr.nDiff = 0 Then

-     GoTo done

-  End If

-' case r = 0

-  For i = 1 To ptr.nAuto

-      ad(i) = ptr.a(i)

-  Next i

-  

-  If ptr.nDiff = 0 Then

-     GoTo done

-  End If

-  For r = 1 To ptr.nDiff

-      

-      If ptr.nAuto + r >= 2 Then

-         ad(ptr.nAuto + r) = -ad(ptr.nAuto + r - 1)

-      Else

-         ad(ptr.nAuto + r) = 0

-      End If

-      For i = ptr.nAuto + r - 1 To 2 Step -1

-          ad(i) = ad(i) - ad(i - 1)

-      Next i

-       ad(1) = ad(1) - CDbl(1)

-  Next r

-done:

-End Sub

-

-<<<<<<
-======================
-mFactors
->>>>>>
-Attribute VB_Name = "mFactors"

-Option Explicit

-' Факторы

-' Группа - 1 ***************************************************

-' Соглашение - если не выводится левая граница, то она равна 1

-'  No - 2

-Sub Histogramm(p As PriceData, _

-               m0 As Integer, _

-               m1 As Integer, _

-               m2 As Integer, _

-               Hist() As Double)

-' Гистограмма = MACD - SIGNAL , m0=24 > m1=12 > m2=9

-' dom{Histogramm} = dom{p}

-ReDim MACD(1 To p.nWin) As Double

-ReDim Signal(1 To p.nWin) As Double

-

-Dim t As Integer

-' MACD = MA(CLOSE,m1) - MA(CLOSE,m0)

-ExpMA1 p.C, 1, p.nWin, 2 / (m1 + 1), MACD

-ExpMA1 p.C, 1, p.nWin, 2 / (m0 + 1), Signal

-For t = 1 To p.nWin

-    MACD(t) = MACD(t) - Signal(t)

-Next t

-ExpMA1 MACD, 1, p.nWin, 2 / (m2 + 1), Signal

-For t = 1 To p.nWin

-    Hist(t) = MACD(t) - Signal(t)

-Next t

-

-Erase MACD

-Erase Signal

-End Sub

-'****************************************************************

-Sub WilliamsInd1(p As PriceData, alfa As Double, Wlm() As Double)

-' Williams indicator - 1

-' dom(Wlm) = [1,tE]

-Dim t As Integer

-For t = 1 To p.nWin

-    Wlm(t) = (p.H(t) - p.C(t)) / (p.H(t) - p.L(t))

-Next t

-If alfa <> 1 Then

-  [mTimeSer].ExpMA1 Wlm, 1, p.nWin, alfa, Wlm

-End If

-End Sub

-

-' No-2

-Sub WilliamsInd(p As PriceData, m As Integer, Wlm() As Double)

-' Williams indicator - 1

-' dom(Wlm) = [m+2,tE]

-' m - ?

-Dim t As Integer, s As Integer

-Dim mxH As Double, mnL As Double

-For t = m + 2 To p.nWin

-  mxH = p.H(t - m + 1):  mnL = p.L(t - m + 1)

-  For s = t - m + 2 To t

-      If mxH < p.H(s) Then

-         mxH = p.H(s)

-      End If

-      If mnL > p.L(s) Then

-         mnL = p.L(s)

-      End If

-  Next s

-  Wlm(t) = (mxH - p.C(t)) / (mxH - mnL)

-'   Wlm(t) = (p.C(t) - p.L(t)) / (p.H(t) - p.L(t))

-Next t

-End Sub

-'Sub WlmSignal(p As PriceData, _

-'              m As Integer, _

-'              LMax As Double, _

-'              LMin As Double, _

-'              Signal() As Double _

-'              )  ' ???

-' Williams Signal - 1

-' dom(Signal) = dom(Wlm)

-'ReDim Wlm(1 To p.nWin) As Double

-'WilliamsInd p, m, Wlm

-'Dim t As Integer

-'For t = m + 2 To p.nWin

-'  Signal(t) = 0

-'  If Wlm(t - 1) < Wlm(t) And Wlm(t - 1) <= LMin Then

-'         Signal(t) = 1

-'  End If

-'  If Wlm(t - 1) > Wlm(t) And Wlm(t - 1) >= LMax Then

-'         Signal(t) = -1

-'  End If

-'

-'Next t

-'End Sub

-

-

-

-

-' No-3

-Sub dADind(p As PriceData, alfa As Double, dAD() As Double)

-' Accumulator/Distribution

-' dom(dAD)= [1,tE]

-Dim t As Integer

-For t = 1 To p.nWin

-    dAD(t) = ((p.C(t) - p.O(t)) / (p.H(t) - p.L(t))) * p.V(t)

-Next t

-If alfa <> 1 Then

-  [mTimeSer].ExpMA1 dAD, 1, p.nWin, alfa, dAD

-End If

-End Sub

-

-' No-4

-Sub dOBVind(p As PriceData, dOBV() As Double)

-' On Balance Volume

-' dom(dOBV)= [2,tE]

-Dim t As Integer

-For t = 2 To p.nWin

-    dOBV(t) = 1

-    If p.C(t) = p.C(t - 1) Then

-       dOBV(t) = 0

-    End If

-    If p.C(t) < p.C(t - 1) Then

-       dOBV(t) = -1

-    End If

-Next t

-End Sub

-' Индикаторы Элдера

-Sub IndBear(ptr As PriceData, m As Integer, iBear() As Double)

-' Индикатор силы медведей

-' Dom(iBear) = [1, tE]

-Dim t As Integer

-ReDim MA(1 To ptr.nWin) As Double

-ExpMA1 ptr.C, 1, ptr.nWin, 2 / (m + 1), MA

-For t = 1 To ptr.nWin

-    iBear(t) = ptr.L(t) - MA(t)

-Next t

-Erase MA

-End Sub

-Sub IndBull(ptr As PriceData, m As Integer, iBull() As Double)

-' Индикатор силы быков

-' Dom(iBull) = [1, tE]

-Dim t As Integer

-ReDim MA(1 To ptr.nWin) As Double

-ExpMA1 ptr.C, 1, ptr.nWin, 2 / (m + 1), MA

-For t = 1 To ptr.nWin

-    iBull(t) = ptr.H(t) - MA(t)

-Next t

-Erase MA

-End Sub

-Sub Force(ptr As PriceData, m As Integer, Force() As Double)

-' Индикатор силы = D(iBull+iBear)

-' Dom(Force) = [2, tE]

-Dim t As Integer

-ReDim MA(1 To ptr.nWin) As Double

-ExpMA1 ptr.C, 1, ptr.nWin, 2 / (m + 1), MA

-For t = 2 To ptr.nWin

-    Force(t) = ptr.H(t) + ptr.L(t) - MA(t) - (ptr.H(t - 1) + ptr.L(t - 1) - MA(t - 1))

-Next t

-Erase MA

-End Sub

-Sub ForceIndex(ptr As PriceData, m As Integer, iForce() As Double)

-' Индикатор силы = iBull+iBear

-' Dom(ForceIndex) = [2, tE]

-Dim t As Integer

-ReDim Ser(1 To ptr.nWin) As Double

-For t = 2 To ptr.nWin

-    Ser(t) = ptr.V(t) * (ptr.C(t) - ptr.C(t - 1))

-Next t

-ExpMA1 Ser, 1, ptr.nWin, 2 / (m + 1), iForce

-Erase Ser

-End Sub

-

-Sub GetIndicator(Num As Integer, ptr As PriceData, ptr1 As Model_1, _

-         NameInd As String, Indicator() As Double, tInd As Integer)

-' Номер индикатора --->  Индикатор, Левая граница области определения

-If Num = 1 Then            '   Number 1

-   NameInd = "Histogramm"

-   Histogramm ptr, 24, 12, 9, Indicator

-   tInd = 1

-ElseIf Num = 2 Then        '  Number 2

-   NameInd = "WiLLiams"

-   WilliamsInd ptr, 7, Indicator

-   tInd = 9 ' = m+2, m = 7

-ElseIf Num = 3 Then        '  Number 3

-   NameInd = "A/D changes"  '?

-   dADind ptr, ptr1.alfa, Indicator

-   tInd = 1

-ElseIf Num = 4 Then        '  Number 4

-   NameInd = "OBV changes"

-   dOBVind ptr, Indicator

-   tInd = 2

-ElseIf Num = 5 Then        '  Number 5

-   NameInd = " Force "

-   ForceIndex ptr, m:=7, iForce:=Indicator

-   tInd = 2

-ElseIf Num = 6 Then        '  Number 5

-   NameInd = " Force Index"

-   ForceIndex ptr, m:=7, iForce:=Indicator

-   tInd = 2

-End If

-

-End Sub

-

-

-

-<<<<<<
-======================
-mTimeSer
->>>>>>
-Attribute VB_Name = "mTimeSer"

-

-Option Explicit

-' Программы обработки временных рядов

-

-Sub MoveLeft(x() As Double, t2 As Integer, t1 As Integer)

-' dom x = [t1,t2] ---> dom(x) = [1,t2-t1+1]сдвиг влево на ms

-Dim t As Integer

-For t = 1 To t2 - t1 + 1

-    x(t) = x(t + t1 - 1)

-Next t

-End Sub

-

-Sub MoveRight(x() As Double, t2 As Integer, t1 As Integer)

-' dom x = [1,t2-t1+1] ---> dom(x) = [t1,t2] сдвиг вправо ms

-Dim t As Integer

-For t = t2 - t1 + 1 To 1 Step -1

-    x(t + t1 - 1) = x(t)

-Next t

-

-End Sub

-

-'1. Преобразования временных рядов

-'series differentiation

-Sub Diff1(x() As Double, tx As Integer, D As Integer, y() As Double)

-' x(1:tx), tx, d  ---> y(1:tx)= {Diff^d)x}

-'0 <= d <= tx-1

-'Dom(x)= [1,tx], Dom(y) = [d+1,tx]

-'difference of order D

- Dim t As Integer

- If D = 0 Then   ' Case d = 0

-    For t = tx To 1 Step -1

-        y(t) = x(t)

-    Next t

-    GoTo done

- End If

- 

- For t = tx To 2 Step -1

-     y(t) = x(t) - x(t - 1)

- Next t

- If D = 1 Then

-    GoTo done

- End If

- 'difference of order d

- Dim k As Integer

- For k = 2 To D

-     'define the deifference of order k

-     For t = tx To k + 1 Step -1

-         y(t) = y(t) - y(t - 1)

-     Next t

- Next k

-done:

-End Sub

-

-Sub Diff(x() As Double, tx As Integer, y() As Double)

-'x(1:tx), tx --->y(1:tx)= x(t)-x(t-1)

-'Dom(x)= [1,tx],Dom(y)= [d+1,tx], Dom - is the domain of definion of series

-'difference of order 1

- Dim t As Integer

- For t = tx To 2 Step -1

-     y(t) = x(t) - x(t - 1)

- Next t

-End Sub

-

-Sub RelDiff(x() As Double, tx As Integer, y() As Double)

-'x(1:tx), tx --->y(1:tx)= [x(t)-x(t-1)]/x(t-1)

-'Dom(x)= [1,tx],Dom(y)= [2,tx], Dom - is the domain of definion of series

-'relative difference of order 1

- Dim t As Integer

- For t = tx To 2 Step -1

-     y(t) = (x(t) - x(t - 1)) / x(t - 1)

- Next t

-End Sub

-

-Sub Logarithm(x() As Double, tx As Integer, y() As Double)

-'x(1:tx), tx --->y(1:tx)= Logarithmx(t)

-'Dom(x)= [1,tx],Dom(y)= [1,tx], Dom - is the domain of definion of series

-'difference of log(x(t)

- Dim t As Integer

- For t = 1 To tx

-     y(t) = Log(x(t))

- Next t

-End Sub

-

-Sub DiffLog(x() As Double, tx As Integer, y() As Double)

-'x(1:tx), tx --->y(1:tx)= Log(x(t)/x(t-1))

-'Dom(x)= [1,tx],Dom(y)= [2,tx], Dom - is the domain of definion of series

-'difference of log(x(t)

- Dim t As Integer

- For t = tx To 2 Step -1

-     y(t) = Log(x(t) / x(t - 1))

- Next t

-End Sub

-

-Sub Copy(x() As Double, tx As Integer, y() As Double)

-'x(1:tx), tx --->y(1:tx)= x(t)-x(t-1)

-'Dom(x)= [1,tx],Dom(y)= [2,tx], Dom - is the domain of definion of series

-'difference of log(x(t)

- Dim t As Integer

- For t = 1 To tx

-     y(t) = x(t)

- Next t

-End Sub

-

-

-'**************************************************************************

-'Выборочные характеристики

- 

- Function Meanf(x() As Double, t1 As Integer, t2 As Integer) As Double

-'x(1:t2), Dom(x) = [t1, t2], t1 <= t2

-'определяет среднее ряда x(t1), ..., x(t2)

-'mean = (x(t1), ..., x(t2))/t

-   Meanf = 0

-   Dim t As Integer

-   For t = t1 To t2

-     Meanf = Meanf + x(t)

-   Next t

-   Meanf = Meanf / CDbl(t2 - t1 + 1)

- End Function

-

-Function Varf(x() As Double, t1 As Integer, t2 As Integer) As Double

-'x(1:t2), Dom(x) = [t1,t2]

-'Выборочная дисперсия ряда x(t), t = t1,t1+1,...,t2

-'[(x(t1)-mx)**2 + ... (x(tx)-mx)**2]/(t2-t1+1), t = t1,...,t2.

-  Dim mx As Double

-  Dim t As Integer

-  mx = 0

-  For t = t1 To t2

-     mx = mx + x(t)

-  Next t

-  mx = mx / CDbl(t2 - t1 + 1)

-  Varf = 0

-  For t = t1 To t2

-    Varf = Varf + (x(t) - mx) * (x(t) - mx)

-  Next t

-  Varf = Varf / CDbl(t2 - t1 + 1)

-End Function

-

-

-Sub AutCov(x() As Double, t0 As Integer, t1 As Integer, m As Integer, _

-           ind As Integer, C() As Double)

-' Выборочная автоковариационная функция

-' Dom(x) = [t0,t1], m <= (t1-t0+1)/5 !!!

-' c(0:m) , k=0,1,..., m, ind = 0

-' r(0:m)                 ind = 1

-  Dim t As Integer, k As Integer

-  Dim delta As Double, mx As Double

-  

-  mx = 0  ' определение среднего

-  delta = CDbl(t1 - t0 + 1)

-  For t = t0 To t1

-     mx = mx + x(t)

-  Next t

-  mx = mx / delta

-  

-  For k = 0 To m

-     C(k) = 0

-     For t = t0 To t1 - k

-          C(k) = C(k) + (x(t + k) - mx) * (x(t) - mx)

-     Next t

-     C(k) = C(k) / delta

-  Next k

-  If ind = 1 Then

-     For k = 1 To m

-        C(k) = C(k) / C(0)

-     Next k

-     C(0) = 1

-  End If

-End Sub

-

-

-

-Function CorrXY(x() As Double, y() As Double, t0 As Integer, t1 As Integer, _

-              s As Integer, ind As Integer) As Double

-' Выборочная kовариация( ind = 0) или корреляция( ind = 1) c задержкой s >= 0

-' s > = 0, Cov{ x(t), y(t-s)} if ind = 0, Corr{x(t),y(t-s)} if ind = 1 ?

-  If s >= t1 - t0 Then

-     CorrXY = 0

-  Else  ' s <  t1 - t0

-     CorrXY = 0

-     Dim mx As Double, my As Double

-     mx = Meanf(x, t0, t1)

-     my = Meanf(y, t0, t1)

-     Dim t As Integer

-     For t = s + t0 To t1

-        CorrXY = CorrXY + (x(t) - mx) * (y(t - s) - my)

-     Next t

-     CorrXY = CorrXY / CDbl(t1 - t0 - s + 1)

-     If (ind = 1) Then

-        CorrXY = CorrXY / Sqr(Varf(x, t0, t1) * Varf(y, t0, t1))

-     End If

-  End If

-End Function

-' part II

-' Экспоненциальное скользящее среднее

-Sub ExpMA1(x() As Double, t1 As Integer, t2 As Integer, alfa As Double, _

-           s() As Double)

-' x , dom(x) = [t1,t2], - исходный ряд

-' 0 <= alfa <= 1 - порядок сглаживания

-' Результат: S , dom(S) = [t1,t2], - скользящее среднее

-' Можно ли использовать для модификации x  - можно!

-Dim S0 As Double, beta As Double

-Dim k As Integer, t As Integer

-' S0 determination

-If alfa <= 0 Then

-   For t = t1 To t2

-      s(t) = 0

-   Next t

-   GoTo done

-End If

-If alfa >= 1 Then

-   For t = t1 To t2

-      s(t) = x(t)

-   Next t

-   GoTo done

-End If

-S0 = 0

-k = 5    ' порядок усреднения, k < (t2-t1+1)/2  !!!

-For t = t1 To t1 + k - 1

-    S0 = S0 + x(t)

-Next t

-S0 = S0 / k

-'main cycle

-beta = 1 - alfa

-s(t1) = alfa * x(t1) + beta * S0

-For t = t1 + 1 To t2

-    s(t) = alfa * x(t) + beta * s(t - 1)

-Next t

-done:

-End Sub

-

-Sub ExpMA2(x() As Double, t1 As Integer, t2 As Integer, alfa As Double, _

-           s() As Double, err() As Double)

-' x , dom(x) = [t1,t2], - исходный ряд

-' 0 <= alfa <= 1 - порядок сглаживания

-' Результат: S , dom(S) = [t1,t2], - скользящее среднее

-'                err(t) = x(t) - S(t)

-Dim S0 As Double, beta As Double

-Dim k As Integer, t As Integer

-' S0 determination

-If alfa <= 0 Then

-   For t = t1 To t2

-      s(t) = 0: err(t) = x(t)

-   Next t

-   GoTo done

-End If

-If alfa >= 1 Then

-   For t = t1 To t2

-      s(t) = x(t): err(t) = 0

-   Next t

-   GoTo done

-End If

-S0 = 0

-k = 5    ' порядок усреднения, k < (t2-t1+1)/2  !!!

-For t = t1 To t1 + k - 1

-    S0 = S0 + x(t)

-Next t

-S0 = S0 / k

-'main cycle

-beta = 1 - alfa

-s(t1) = alfa * x(t1) + beta * S0

-err(t1) = x(t1) - s(t1)

-For t = t1 + 1 To t2

-    s(t) = alfa * x(t) + beta * s(t - 1)

-    err(t) = x(t) - s(t)

-Next t

-done:

-End Sub

-

-Sub ExpMA3(x() As Double, t1 As Integer, t2 As Integer, alfa As Double, _

-           s() As Double, err() As Double)

-' x , dom(x) = [t1,t2], - исходный ряд

-' 0 < alfa < 1 - порядок сглаживания

-' Результат: S , dom(S) = [t1,t2], - скользящее среднее

-'                err(t) = x(t) - S(t-1)

-Dim S0 As Double, beta As Double

-Dim k As Integer, t As Integer

-' S0 determination

-S0 = 0

-k = 5    ' порядок усреднения, k < (t2-t1+1)/2  !!!

-For t = t1 To t1 + k - 1

-    S0 = S0 + x(t)

-Next t

-S0 = S0 / k

-'main cycle

-beta = 1 - alfa

-s(t1) = alfa * x(t1) + beta * S0

-err(t1) = x(t1) - s(t1)

-For t = t1 + 1 To t2

-    s(t) = alfa * x(t) + beta * s(t - 1)

-    err(t) = x(t) - s(t - 1)

-Next t

-End Sub

-

-Sub Decimation(x() As Double, tx As Integer, dt As Integer, y() As Double, ty As Integer)

-' Децимация от конца: {x(), tx, dt }  --> { y(), ty} (y = x возможно !)

-' dom(x) = [1, tx],

-Dim k As Integer

-ty = ((tx - 1) \ dt) + 1

-For k = 1 To ty

-    y(k) = x(tx - (ty - k) * dt)

-Next k

-End Sub

-

-

-Function SignNum(x() As Double, _

-           y() As Double, _

-           s As Integer, _

-           tB As Integer, _

-           tE As Integer _

-           ) As Integer

-' относительное число совпадений знаков последовательностей x и y

-Dim t As Integer  ' ???

-SignNum = 0

-For t = tB + s To tE

-    If x(t) * y(t - s) > 0 Then

-       SignNum = SignNum + 1

-    End If

-Next t

-SignNum = SignNum / (tE - tB + 1)

-End Function

-

-<<<<<<
-Project Name : 'Indicator'
-Quirk - duff tag length======================
-MGetWebData
->>>>>>
-Attribute VB_Name = "MGetWebData"

-Option Explicit

-

-Dim mobjAppRunEnable As New cEnableRun

-

-Const QueryDataName As String = "ExternalDenmarkData"

-

-Function UpdateHistoryFromWeb(wb As Workbook) As Boolean

-    Dim DestRangeName As String

-    Dim ResultLength As Integer

-    Dim QryPathStr As String

-    Dim Location As Range

-    Dim denWindow As Integer

-    Dim IsIntraday As Boolean

-    Dim CalcNextTime As Boolean

-        

-    UpdateHistoryFromWeb = False

-    QryPathStr = GetQryPath(wb)

-    With wb

-        .Application.ScreenUpdating = False

-        With .Worksheets(VAR_SHEET)

-            DestRangeName = .Range("DEN_SYMBOL")

-            CalcNextTime = .Range("BOOL_NEXT_TIME")

-            denWindow = .Range("DEN_WINDOW")

-            If CalcNextTime Then

-                denWindow = denWindow + 1

-            End If

-            IsIntraday = IsNumeric(.Range("DEN_TIME"))

-        End With

-        With .Worksheets(RAW_DATA_SHEET)

-            .Range(PRICE_TABLE) = DestRangeName

-            'Clear table and temp area

-            With .Range( _

-                .Cells(RAW_DATA_RANGE_ROW - 1, RAW_DATA_RANGE_COL - 1), _

-                .Cells(65535, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE))

-                .ClearContents

-                .NumberFormat = "General"

-            End With

-            

-            Set Location = .Range(RAW_DATA_RANGE).Offset(-1, 0)

-            If Not QryExist(Location, QueryDataName) Then

-                QryCreate Location, QueryDataName, QryPathStr

-            Else

-                QryRefresh Location, QueryDataName, QryPathStr

-            End If

-            With Location.Worksheet.QueryTables(QueryDataName)

-                DestRangeName = .ResultRange.Name.RefersTo

-                ResultLength = .ResultRange.count

-            End With

-    

-'            .Parent.Application.DisplayAlerts = False

-    

-            If ResultLength < denWindow Then

-                Exit Function

-            End If

-            

-            .Range(DestRangeName).TextToColumns _

-                Destination:=Range(DestRangeName), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=True, _

-                Space:=False, _

-                Other:=False, _

-                OtherChar:="|", _

-                FieldInfo:=Array( _

-                                Array(1, xlSkipColumn), _

-                                Array(2, xlTextFormat), _

-                                Array(3, xlGeneralFormat), _

-                                Array(4, xlGeneralFormat), _

-                                Array(5, xlGeneralFormat), _

-                                Array(6, xlGeneralFormat), _

-                                Array(7, xlGeneralFormat), _

-                                Array(8, xlSkipColumn), _

-                                Array(9, xlSkipColumn), _

-                                Array(10, xlSkipColumn), _

-                                Array(11, xlSkipColumn), _

-                                Array(12, xlSkipColumn))

-            

-            .Range(DestRangeName).EntireColumn.AutoFit

-            

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(65536, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-            ).NumberFormat = "General"

-            

-            Dim RawData As Range

-            Dim row_idx As Integer

-            

-            Set RawData = .Range(DestRangeName).Offset(0, 1)

-            RawData.Insert Shift:=xlToRight

-            

-            If Not IsIntraday Then

-                Set RawData = RawData.Offset(0, -1)

-                RawData.Value = "18:00"

-                RawData.Cells(1, 1).FormulaR1C1 = "TIME"

-                Set RawData = RawData.Offset(0, -1)

-            Else

-                Set RawData = RawData.Offset(0, -2)

-                RawData.TextToColumns _

-                    Destination:=RawData, _

-                    DataType:=xlDelimited, _

-                    TextQualifier:=xlDoubleQuote, _

-                    ConsecutiveDelimiter:=False, _

-                    Tab:=False, _

-                    Semicolon:=False, _

-                    Comma:=False, _

-                    Space:=True, _

-                    Other:=False, _

-                    OtherChar:="/", _

-                    FieldInfo:=Array( _

-                                    Array(1, xlTextFormat), _

-                                    Array(2, xlTextFormat))

-                RawData.Cells(1, 2).FormulaR1C1 = "TIME"

-            End If

-            

-'            Dim end_date As Date

-'            end_date = RawData.Cells(ResultLength, 1).FormulaR1C1

-

-' Delete unused space

-            

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW + ResultLength, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(65536, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-            ).ClearContents

-            

-            Dim i As Integer

-' Delete blank intervals

-            

-            Set RawData = .Range(RAW_DATA_RANGE).Offset(0, 0)

-            row_idx = 0

-            For i = 1 To ResultLength

-                ' skip virtual prices

-                If RawData.Offset(row_idx, CLOSE_IDX).Value > MIN_PRICE_VALUE Then

-                    row_idx = row_idx + 1

-                Else

-                    Set Location = .Range( _

-                            .Cells(row_idx + RAW_DATA_RANGE_ROW, DATE_IDX + RAW_DATA_RANGE_COL), _

-                            .Cells(row_idx + RAW_DATA_RANGE_ROW, PROJECT_IDX + RAW_DATA_RANGE_COL) _

-                    )

-                    Location.Delete xlShiftUp

-                End If

-            Next i

-            

-            ResultLength = GetLinesCount(.Range(RAW_DATA_RANGE))

-            

-            row_idx = ResultLength - 1

-            If row_idx > denWindow Then

-                row_idx = row_idx - denWindow

-                .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-                ).Delete xlShiftUp

-            Else

-                Exit Function

-            End If

-            

-            Dim TmpStr As String

-                        

-            row_idx = GetLinesCount(.Range(RAW_DATA_RANGE))

-            

-            Set RawData = .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx - 1, RAW_DATA_RANGE_COL + DATE_IDX) _

-                )

-            RawData.TextToColumns _

-                Destination:=.Range(RAW_DATA_RANGE).Offset(0, DATE_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:="-", _

-                FieldInfo:=Array( _

-                                Array(1, xlTextFormat), _

-                                Array(2, xlTextFormat), _

-                                Array(3, xlTextFormat))

-            

-            Set Location = .Range(RAW_DATA_RANGE).Offset(0, -1)

-            

-            If IsIntraday Then

-                Set RawData = .Range( _

-                            .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + TIME_IDX), _

-                            .Cells(RAW_DATA_RANGE_ROW + row_idx - 1, RAW_DATA_RANGE_COL + TIME_IDX) _

-                    )

-                RawData.TextToColumns _

-                    Destination:=.Range(RAW_DATA_RANGE).Offset(0, TIME_STAMP_OFFSET), _

-                    DataType:=xlDelimited, _

-                    TextQualifier:=xlDoubleQuote, _

-                    ConsecutiveDelimiter:=False, _

-                    Tab:=False, _

-                    Semicolon:=False, _

-                    Comma:=False, _

-                    Space:=False, _

-                    Other:=True, _

-                    OtherChar:=":", _

-                    FieldInfo:=Array( _

-                                    Array(1, xlTextFormat), _

-                                    Array(2, xlTextFormat), _

-                                    Array(3, xlTextFormat))

-                                    

-                

-                For i = 0 To row_idx - 1

-                    Location.Offset(i, 0) = "'" & _

-                            .Range(RAW_DATA_RANGE).Offset(i, DATE_STAMP_OFFSET + 1).Value _

-                            & "/" & .Range(RAW_DATA_RANGE).Offset(i, DATE_STAMP_OFFSET + 2).Value _

-                            & "-" & .Range(RAW_DATA_RANGE).Offset(i, TIME_STAMP_OFFSET).Value _

-                            & ":" & .Range(RAW_DATA_RANGE).Offset(i, TIME_STAMP_OFFSET + 1).Value

-                Next

-            Else

-                For i = 0 To row_idx - 1

-                    Location.Offset(i, 0) = "'" & _

-                            .Range(RAW_DATA_RANGE).Offset(i, DATE_STAMP_OFFSET + 2).Value _

-                            & "/" & .Range(RAW_DATA_RANGE).Offset(i, DATE_STAMP_OFFSET + 1).Value _

-                            & "/" & .Range(RAW_DATA_RANGE).Offset(i, DATE_STAMP_OFFSET).Value

-                Next

-            End If

-            .Parent.Application.DisplayAlerts = True

-        End With ' .Worksheets(RAW_DATA_SHEET)

-    End With ' wb

-    UpdateHistoryFromWeb = True

-End Function

-

-Private Function GetQryPath(wb As Workbook) As String

-    Dim QryPathStr As String

-    Dim IsIntradai As Boolean

-    Dim DayCount As Integer

-    Const DataFormat As String = "&data_format=BROWSER"

-    With wb.Worksheets(VAR_SHEET)

-        IsIntradai = IsNumeric(.Range("DEN_TIME"))

-        

-        If IsIntradai Then

-        

-            QryPathStr = "URL;http://export.rbc.ru/export/"

-            QryPathStr = QryPathStr & .Range("DEN_SOURCE")

-            QryPathStr = QryPathStr & "." & .Range("DEN_BOARD")

-            QryPathStr = QryPathStr & "/?"

-            

-            QryPathStr = QryPathStr & "tickers=" & .Range("DEN_SYMBOL")

-            QryPathStr = QryPathStr & "&period=" & .Range("DEN_TIME")

-            QryPathStr = QryPathStr & "&virtual=PASS"

-            DayCount = .Range("DEN_HISTORY") * .Range("DEN_TIME") \ 420 + 1

-            QryPathStr = QryPathStr & "&lastdays=" & DayCount

-            QryPathStr = QryPathStr & "&separator=,"

-            QryPathStr = QryPathStr & DataFormat

-            QryPathStr = QryPathStr & "&header=1"

-        Else

-            QryPathStr = "URL;http://export.rbc.ru/cgi-bin/export/query_version/export.cgi?"

-            QryPathStr = QryPathStr & "&sourcename=" & .Range("DEN_SOURCE")

-            QryPathStr = QryPathStr & "." & .Range("DEN_BOARD")

-            QryPathStr = QryPathStr & "&tickers=" & .Range("DEN_SYMBOL")

-            QryPathStr = QryPathStr & "&period=DAILY"

-            QryPathStr = QryPathStr & "&virtual=PASS"

-            QryPathStr = QryPathStr & "&lastdays=" & .Range("DEN_HISTORY") + 1

-            QryPathStr = QryPathStr & "&separator=,"

-            QryPathStr = QryPathStr & DataFormat

-            QryPathStr = QryPathStr & "&header=1"

-        End If

-    .Range("LAST_HIST_QRY") = QryPathStr

-    End With

-    GetQryPath = QryPathStr

-End Function

-

-Sub UpdateTickerList(wb As Workbook)

-    Dim Idx, n As Integer

-    Dim ResultLength As Integer

-    Dim Location As Range

-    Dim QryPathStr As String

-    Dim QueryDataName As String

-    Dim DestRangeArea As String

-    

-    QryPathStr = GetListPath(wb)

-    With wb

-        With .Worksheets(VAR_SHEET)

-            Idx = .Range("IDX_DEN_LIST")

-            Set Location = .Range("TICKER_TABLES").Offset(0, (Idx - 1) * 2)

-             .Range("IDX_DEN_SYMBOL") = 1

-            QueryDataName = Location.Offset(0, 0)

-            'Clear table

-            .Range(Location.Offset(1, 0), Location.Offset(65535 - Location.Row, 1)).ClearContents

-            

-            If Not QryExist(Location.Offset(1, 0), QueryDataName) Then

-                QryCreate Location.Offset(1, 0), QueryDataName, QryPathStr

-            Else

-                QryRefresh Location.Offset(1, 0), QueryDataName, QryPathStr

-            End If

-            

-            With .QueryTables(QueryDataName)

-                DestRangeArea = .ResultRange.Name.RefersTo

-                ResultLength = .ResultRange.count

-            End With

-        

-            .Parent.Application.DisplayAlerts = False

-                

-            .Range(DestRangeArea).TextToColumns _

-                Destination:=.Range(DestRangeArea), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:=":", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 9))

-        ' Sort Data

-            Set Location = .Range(.Range(DestRangeArea).Offset(0, 0), .Range(DestRangeArea).Offset(ResultLength - 1, 1))

-            Location.Sort _

-                Key1:=.Range(DestRangeArea).Offset(0, 1), _

-                Order1:=xlAscending, _

-                Header:=xlNo, _

-                OrderCustom:=1, _

-                MatchCase:=False, _

-                Orientation:=xlTopToBottom

-        End With

-        ' Setup Ticker List

-         With .Worksheets(VAR_SHEET)

-            DestRangeArea = .Name & "!" & .Range(.Range(DestRangeArea).Cells(1, 1), .Range(DestRangeArea).Cells(ResultLength - 1, 1)).Address

-         End With

-        With .Worksheets(FORM_SHEET).Shapes("cbxTikers").ControlFormat

-            .ListFillRange = DestRangeArea

-            .ListIndex = 1

-        End With

-        ' Setup Name List

-         With .Worksheets(VAR_SHEET)

-            DestRangeArea = .Name & "!" & .Range(.Range(DestRangeArea).Cells(1, 1), .Range(DestRangeArea).Cells(ResultLength - 1, 1)).Offset(0, 1).Address

-         End With

-        With .Worksheets(FORM_SHEET).Shapes("cbxSecName").ControlFormat

-            .ListFillRange = DestRangeArea

-            .ListIndex = 1

-        End With

-        .Parent.Application.DisplayAlerts = True

-    End With

-End Sub

-

-Private Function GetListPath(wb As Workbook) As String

-    Dim QryPathStr As String

-    With wb.Worksheets(VAR_SHEET)

-        QryPathStr = "URL;http://export.rbc.ru/cgi-bin/export/tickers.cgi?"

-        QryPathStr = QryPathStr & "&source=" & .Range("DEN_SOURCE")

-        QryPathStr = QryPathStr & "." & .Range("DEN_BOARD")

-        .Range("LAST_DIR_QRY") = QryPathStr

-    End With

-    GetListPath = QryPathStr

-End Function

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    Set MyAppEvents.app = Application

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    If Application.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEL сейчас будут закрыты!", vbOKCancel, "$" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close Savechanges:=False

-            Exit Sub

-        End If

-    End If

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False

-    cmSetStandaloneMode

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment wb:=ThisWorkbook, DesignMode:=False

-        If ThisWorkbook.Saved = False Then

-            ThisWorkbook.Save

-        End If

-    End If

-    Application.Caption = Empty

-    Application.CommandBars("Worksheet Menu Bar").Reset

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-        Dim MaxX, MaxY As Integer

-        With ThisWorkbook.Worksheets(FORM_SHEET)

-            MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-            MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-        End With

-

-        With ThisWorkbook.Application

-            .ScreenUpdating = False

-            .WindowState = xlNormal

-            .Height = MaxY

-            .Width = MaxX

-        End With

-End Sub

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mReadWrite
->>>>>>
-Attribute VB_Name = "mReadWrite"

-Option Explicit

-

-Public Const GOOD_LINE_STATUS As String = "Ok"

-Public Const BAD_LINE_STATUS As String = "N/A"

-

-Function ReadPricesData(Location As Range, Hist As Integer, dt As Integer, _

-              pPriceData As TPriceData) As Integer

-    'Инициализация типа TPriceData из таблицы типа - 1

-    'kопируются не более чем hist последних строк

-    'aPoint - начало таблицы

-    'первые две строки таблицы идентифицирует данные (строки)

-    Dim n, i As Integer

-    

-    'Определение числа строк таблицы - n

-    n = GetLinesCount(Location)

-    ReadPricesData = n

-    If n < 9 Then             'обработать ошибку !!!

-        GoTo done

-    End If

-    ' число строк определено ()

-    If Hist > (n - 3) \ dt + 1 Then ' коррекция истории

-        Hist = (n - 3) \ dt + 1 '

-    End If

-    Dim t, s As Integer

-    For t = 0 To Hist - 1

-        s = n - t * dt - 1

-        pPriceData.D(Hist - t) = Location.Offset(s, DATE_IDX).Value

-        pPriceData.Tm(Hist - t) = Location.Offset(s, TIME_IDX).Value

-        pPriceData.Opn(Hist - t) = Location.Offset(s, OPEN_IDX).Value

-        pPriceData.Hgh(Hist - t) = Location.Offset(s, HIGH_IDX).Value

-        pPriceData.Lw(Hist - t) = Location.Offset(s, LOW_IDX).Value

-        pPriceData.Cls(Hist - t) = Location.Offset(s, CLOSE_IDX).Value

-        pPriceData.Vl(Hist - t) = Location.Offset(s, VOLUME_IDX).Value

-    Next t

-    ReadPricesData = t + 1

-done:

-End Function

-

-Sub ResultLinesOut(Location As Range, pPD As TPriceData, pDen As TDenmark)

-    Dim n As Integer

-    

-    n = GetLinesCount(Location)

-    With Location

-        .Offset(-1, RESIST_IDX) = "Resistance"

-        .Offset(-1, SUPPORT_IDX) = "Support"

-        .Offset(-1, PROJECT_IDX) = "Project"

-    End With

-    Dim t, count, Idx, loc_idx As Integer

-    count = pPD.tC

-    For t = 0 To count - 1

-        Idx = count - t

-        loc_idx = n - t - 1

-        If pDen.ResistanceLine(Idx) > MIN_PRICE_VALUE Then

-            Location.Offset(loc_idx, RESIST_IDX).Value = pDen.ResistanceLine(Idx)

-        End If

-        If pDen.SupportLine(Idx) > MIN_PRICE_VALUE Then

-            Location.Offset(loc_idx, SUPPORT_IDX).Value = pDen.SupportLine(Idx)

-        End If

-        If Abs(pDen.SignalValue) > 1 Then

-            Location.Offset(loc_idx, PROJECT_IDX).Value = pDen.ProjectPrice

-        End If

-    Next t

-End Sub

-

-Sub Out_Table_1(TheRange As Range, pDen As TDenmark, LastIdx As Integer)

-    

-    

-    ' Col = 2 - не определен !!!

-    ' Status - Col = 0

-    If pDen.ResistancePointCount >= 2 Then

-        TheRange.Offset(0, 0).Value = GOOD_LINE_STATUS

-    Else

-        TheRange.Offset(0, 0).Value = BAD_LINE_STATUS

-    End If

-    If pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(1, 0).Value = GOOD_LINE_STATUS

-    Else

-        TheRange.Offset(1, 0).Value = BAD_LINE_STATUS

-    End If

-    ' -----------------------------------------

-    ' углы наклонов линии сопротивления и поддержки - Col = 1

-    If pDen.ResistancePointCount >= 2 Then

-        TheRange.Offset(0, 1).Value = pDen.ResistanceAngle

-    End If

-    If pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(1, 1).Value = pDen.SupportAngle

-    End If

-    If pDen.ResistancePointCount >= 2 And pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(2, 1).Value = (pDen.ResistanceAngle + pDen.SupportAngle) / 2

-    End If

-    ' -----------------------------------------

-    ' Опорные цены линий денмарка на текущий момент

-    If pDen.ResistancePointCount >= 2 Then

-        TheRange.Offset(0, 2).Value = pDen.ResistanceLine(LastIdx)

-    End If

-    If pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(1, 2).Value = pDen.SupportLine(LastIdx)

-    End If

-    If pDen.ResistancePointCount >= 2 And pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(2, 2).Value = _

-            (pDen.ResistanceLine(LastIdx) + pDen.SupportLine(LastIdx)) / 2

-    End If

-    

-End Sub

-

-Sub Out_Table_2(TheRange As Range, TheComment As Range, pPD As TPriceData, pDen As TDenmark)

-    Const ColorIndexBUY = 5

-    Const ColorIndexSELL = 3

-    Const ColorIndexNOTHINK = 14

-    

-    Dim SignalValue_defined, allert_enable  As Boolean

-    Dim Message As String

-    SignalValue_defined = False

-    allert_enable = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_ALLERT_DLG")

-    Message = "Сигнал об изменении тренда не идентифицирован."

-    If pDen.SignalValue >= 2 Then

-        SignalValue_defined = True

-        With TheRange.Offset(0, 0)

-            .Value = "BUY"

-            .Font.Bold = True

-            .Font.ColorIndex = ColorIndexBUY

-        End With

-        TheRange.Offset(0, 1).Value2 = pPD.D(pPD.tC)

-        TheRange.Offset(0, 2).Value2 = pPD.Tm(pPD.tC)

-        TheRange.Offset(0, 3).Value = pDen.SignalValue - 1

-        TheRange.Offset(0, 4).Value = pDen.ProjectPrice

-        Message = "BUY Signal: возможен прорыв вверх нисходящего тренда с уровнем значимости = " & pDen.SignalValue - 1 & " ! "

-    End If

-    If pDen.SignalValue <= -2 Then

-        SignalValue_defined = True

-        With TheRange.Offset(0, 0)

-            .Value = "SELL"

-            .Font.Bold = True

-            .Font.ColorIndex = ColorIndexSELL

-        End With

-        TheRange.Offset(0, 1).Value2 = pPD.D(pPD.tC)

-        TheRange.Offset(0, 2).Value2 = pPD.Tm(pPD.tC)

-        TheRange.Offset(0, 3).Value = pDen.SignalValue + 1

-        TheRange.Offset(0, 4).Value = pDen.ProjectPrice

-        Message = "SELL Signal: возможен прорыв вниз восходящего тренда с уровнем значимости = " & -(pDen.SignalValue + 1) & "!"

-    End If

-    With TheComment

-        .Value = Message

-        .Font.Bold = True

-        Dim color_idx As Integer

-        If SignalValue_defined Then

-            If pDen.SignalValue > 0 Then

-                .Font.ColorIndex = ColorIndexBUY

-            Else

-                .Font.ColorIndex = ColorIndexSELL

-            End If

-        Else

-            .Font.ColorIndex = ColorIndexNOTHINK

-        End If

-    End With

-    If allert_enable And SignalValue_defined Then

-        MsgBox _

-            Prompt:=Message, _

-            Title:=PROGRAM_NAME, _

-            Buttons:=vbOKOnly + vbInformation

-    End If

-End Sub

-

-Sub Out_Table_3(TheRange As Range, pDen As TDenmark)

-    Dim i As Integer

-    For i = 1 To 3

-        TheRange.Offset(i - 1, 0).Value = pDen.Qualificator(i)

-    Next i

-End Sub

-

-Sub Out_Table_4(TheRange As Range, pPD As TPriceData)

-    Dim LastIdx As Integer

-    LastIdx = pPD.tC

-    With TheRange

-        .Offset(0, 0).Value2 = "'" & pPD.D(LastIdx)

-        .Offset(0, 1).Value2 = "'" & pPD.Tm(LastIdx)

-        .Offset(0, 2) = pPD.Opn(LastIdx)

-        .Offset(0, 3) = pPD.Hgh(LastIdx)

-        .Offset(0, 4) = pPD.Lw(LastIdx)

-        .Offset(0, 5) = pPD.Cls(LastIdx)

-        .Offset(0, 6) = pPD.Cls(LastIdx) - pPD.Cls(LastIdx - 1)

-    End With

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Denmark method bar"

-Public Const common_pwd As Long = 31415926

-

-

-Sub SetEnvironment(wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    With Application

-        .Caption = PROGRAM_NAME

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .GetState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-    End With

-    With wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(FORM_SHEET).Select

-    End With

-    CreateCommandBar theApp:=wb.Application

-End Sub

-

-Sub RestoreEnvironment(wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Application.ScreenUpdating = False

-    With wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                     cWindow.DisplayHeadings = True

-                Next

-            End If

-        Next

-        .Worksheets(FORM_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu (True)

-        End If

-        With mobjAppState

-            .RestoreState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(wb As Workbook)

-    With wb

-        .Application.ScreenUpdating = False

-        

-        With .Worksheets(RAW_DATA_SHEET)

-            .Visible = xlVeryHidden

-            .Protect Password:=common_pwd, userInterfaceOnly:=True, Contents:=False

-        End With

-        With .Worksheets(VAR_SHEET)

-            .Visible = xlVeryHidden

-            .Protect Password:=common_pwd, userInterfaceOnly:=True, Contents:=False

-        End With

-        With .Worksheets(FORM_SHEET)

-            .EnableSelection = xlNoSelection

-            .Protect userInterfaceOnly:=True

-            .Select

-        End With

-        With .Worksheets(CHART_SHEET)

-            .EnableSelection = xlNoSelection

-            .Protect userInterfaceOnly:=True

-        End With

-        .Protect Windows:=True

-        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(wb As Workbook)

-    With wb

-        .Unprotect

-        .Application.ScreenUpdating = False

-        With .Worksheets(RAW_DATA_SHEET)

-            .Visible = xlVeryHidden

-            .Unprotect Password:=common_pwd

-        End With

-        With .Worksheets(VAR_SHEET)

-            .Visible = xlVeryHidden

-            .Unprotect Password:=common_pwd

-        End With

-        With .Worksheets(CHART_SHEET)

-            .Select

-            .Unprotect

-        End With

-        With .Worksheets(FORM_SHEET)

-            .Select

-            .Unprotect

-        End With

-        .Application.ScreenUpdating = True

-        

-    End With

-End Sub

-

-<<<<<<
-======================
-mTypes
->>>>>>
-Attribute VB_Name = "mTypes"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Расчет оптимальной стратегии"

-Public Const PROGRAM_VERSION As String = "version 1.0"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-

-Public Const ESTIMATION_DATE As Long = 20010615

-'Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "J27"

-

-Public Const RAW_DATA_SHEET As String = "Raw_data"

-Public Const PRICE_TABLE As String = "B1"

-Public Const RAW_DATA_RANGE As String = "B3"

-Public Const RAW_DATA_RANGE_COL As Integer = 2

-Public Const RAW_DATA_RANGE_ROW As Integer = 3

-

-Public Const VAR_SHEET As String = "Var_s"

-

-Public Const CHART_SHEET As String = "Chart"

-

-Public Const MIN_PRICE_VALUE As Double = 0.000001

-Public Const MAX_PRICE_VALUE As Double = 1000000000

-

-' Fields indexes in RAW_DATA_RANGE

-Public Const DATE_IDX As Integer = 0

-Public Const TIME_IDX As Integer = 1

-Public Const OPEN_IDX As Integer = 2

-Public Const HIGH_IDX As Integer = 3

-Public Const LOW_IDX As Integer = 4

-Public Const CLOSE_IDX As Integer = 5

-Public Const VOLUME_IDX As Integer = 6

-Public Const RESIST_IDX As Integer = 7

-Public Const SUPPORT_IDX As Integer = 8

-Public Const PROJECT_IDX As Integer = 9

-

-Public Const DATE_STAMP_OFFSET = PROJECT_IDX + 1

-Public Const TIME_STAMP_OFFSET = PROJECT_IDX + 4

-Public Const DATE_TIME_STAMP_SIZE = 5

-

-Type TPriceData

-    D() As String      ' календарная дата

-    Tm() As String     ' время

-    Opn() As Double    ' Open

-    Hgh() As Double    ' High

-    Lw() As Double     ' Low

-    Cls() As Double    ' Close

-    Vl() As Double     ' Volume

-    tC As Integer      ' Current time

-End Type

-

-Type TDenmark

-   ResistanceLine() As Double           'Resistance line

-   ResistancePoints() As Integer        'Resistance pivot points

-   ResistancePointCount As Integer      'The number of resistance pivot points

-   ResistanceAngle As Double            'Angle of Declination of ResistanceLine

-   

-   SupportLine() As Double              'Support line

-   SupportPoints() As Integer           'Support pivot points

-   SupportPointsCount As Integer        'The number of support pivot points

-   SupportAngle As Double               ' Angle of Declination of SupportLine

-   

-   SignalParameter     As Integer       ' parameter for SignalValue

-   SignalValue      As Integer          'SignalValue

-   

-   

-   Qualificator(1 To 3) As String       ' qualificators

- 

-   ProjectNumber As Integer             ' номер проекции

-   ProjectPrice  As Double              ' проекция цены

-   

-End Type

-

-

-<<<<<<
-======================
-mCommands
->>>>>>
-Attribute VB_Name = "mCommands"

-Option Explicit

-Dim AppRunEnable As New cEnableRun

-

-Sub evParamChange()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DEMARK_READY") = False

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_AUTORECALC") = True Then

-        evSubmit_Click

-    End If

-End Sub

-

-Sub cmViewChart(Optional SwapPage As Boolean = True)

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("BOOL_CHART_READY") = False

-        If .Range("BOOL_DEMARK_READY") <> True Then

-            If .Range("BOOL_AUTORECALC") = True Then

-                evSubmit_Click

-                If .Range("BOOL_DEMARK_READY") <> True Then

-                    Exit Sub

-                End If

-            Else

-                MsgBox _

-                    "График не может быть построен." & vbCrLf & "Исходные данные не обработаны.", _

-                    vbOKOnly + vbExclamation, _

-                    PROGRAM_NAME

-                Exit Sub

-            End If

-        End If

-    End With

-    With ThisWorkbook.Worksheets(FORM_SHEET)

-        With .Range("TABLE_1")

-            Dim test_lines As Boolean

-            test_lines = StrComp(.Cells(1, 1).Value, GOOD_LINE_STATUS)

-            test_lines = test_lines + StrComp(.Cells(2, 1).Value, GOOD_LINE_STATUS)

-            If test_lines <> 0 Then

-                MsgBox _

-                    Prompt:="График не может быть построен." & vbCrLf & "Опорные точки не определены .", _

-                    Title:=PROGRAM_NAME, _

-                    Buttons:=vbOKOnly + vbExclamation

-                Exit Sub

-            End If

-        End With

-        Draw_Chart Not IsEmpty(.Range("TABLE_2").Cells(1, 1))

-    End With

-    With ThisWorkbook

-        .Worksheets(VAR_SHEET).Range("BOOL_CHART_READY") = True

-        If SwapPage Then

-            .Worksheets(CHART_SHEET).Select

-        End If

-    End With

-End Sub

-

-Sub cmViewForm()

-    With ThisWorkbook

-        .Worksheets(FORM_SHEET).Select

-    End With

-End Sub

-

-Sub cmCloseProgram()

-    Dim ResistanceLine

-    ResistanceLine = MsgBox( _

-        Prompt:="Вы желаете завершить программу?", _

-        Buttons:=vbQuestion + vbYesNo, _

-        Title:=PROGRAM_NAME _

-    )

-    If ResistanceLine = vbYes Then

-       Application.Quit

-    End If

-End Sub

-

-Sub cmAbout()

-    dlgAbout.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlgAbout.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlgAbout.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlgAbout.Show

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-        helppath = "hh.exe " & .Path & "\Demark.chm"

-        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub cmSetStandaloneMode()

-    Application.ScreenUpdating = False

-    ProtectionDisable wb:=ThisWorkbook

-    SetEnvironment wb:=ThisWorkbook

-    ProtectionEnable wb:=ThisWorkbook

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    rp = common_pwd

-    dlgGetPwd.edPwd = ""

-    dlgGetPwd.Show

-    If dlgGetPwd.edPwd = rp Then

-        ProtectionDisable wb:=ThisWorkbook

-        RestoreEnvironment wb:=ThisWorkbook, DesignMode:=True

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmPrint()

-    If MsgBox( _

-            Prompt:="Вы желаете распечатать результат?", _

-            Buttons:=vbYesNo + vbQuestion, _

-            Title:=PROGRAM_NAME) = vbNo _

-    Then

-        Exit Sub

-    End If

-    Dim s_ticker, s_name, s_time As String

-    s_ticker = ThisWorkbook.Worksheets(FORM_SHEET).Range("CALC_TICKER_NAME")

-    s_name = ThisWorkbook.Worksheets(FORM_SHEET).Range("CALC_NAME")

-    s_time = Now

-    Application.ScreenUpdating = False

-    cmViewChart SwapPage:=False

-    Application.ScreenUpdating = False

-    With ThisWorkbook.Worksheets(FORM_SHEET).PageSetup

-        .LeftHeader = s_ticker

-        .CenterHeader = PROGRAM_NAME

-        .RightHeader = s_time

-        .LeftFooter = s_name

-        .CenterFooter = "Page &P of &N"

-        .RightFooter = ""

-        .LeftMargin = Application.InchesToPoints(0.75)

-        .RightMargin = Application.InchesToPoints(0.75)

-        .TopMargin = Application.InchesToPoints(0.78)

-        .BottomMargin = Application.InchesToPoints(0.92)

-        .HeaderMargin = Application.InchesToPoints(0.5)

-        .FooterMargin = Application.InchesToPoints(0.5)

-        .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 = 2

-    End With

-    With ThisWorkbook.Worksheets(CHART_SHEET).PageSetup

-        .LeftHeader = s_ticker

-        .CenterHeader = PROGRAM_NAME

-        .RightHeader = s_time

-        .LeftFooter = s_name

-        .CenterFooter = "Page &P of &N"

-        .RightFooter = ""

-        .LeftMargin = Application.InchesToPoints(0.75)

-        .RightMargin = Application.InchesToPoints(0.75)

-        .TopMargin = Application.InchesToPoints(0.78)

-        .BottomMargin = Application.InchesToPoints(0.92)

-        .HeaderMargin = Application.InchesToPoints(0.5)

-        .FooterMargin = Application.InchesToPoints(0.5)

-        .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 = 2

-    End With

-    Application.ScreenUpdating = False

-    ThisWorkbook.Worksheets(Array("MainForm", "Chart")).PrintOut Copies:=1, Collate:=True

-    cmViewForm

-End Sub

-<<<<<<
-======================
-mDemark
->>>>>>
-Attribute VB_Name = "mDemark"

-Option Explicit

-

-Public Const FORM_SHEET As String = "MainForm"

-

-'Form Ranges

-Public Const FILE_NAME As String = "FILE_NAME"

-Public Const TABLE_1 As String = "TABLE_1"

-Public Const TABLE_2 As String = "TABLE_2"

-Public Const TABLE_3 As String = "TABLE_3"

-Public Const TABLE_4 As String = "TABLE_4"

-Public Const TABLE_COMMENT As String = "TABLE_COMMENT"

-

-'Основной тип данных - стандарт 1

-

-'*********************

-Dim PriceDataArray As TPriceData

-Dim DenmarkDataArray As TDenmark

-

-Dim mobjAppRunEnable As New cEnableRun

-

-Sub ClearResultTables()

-    With ThisWorkbook.Worksheets(FORM_SHEET)

-        .Range(TABLE_1).ClearContents ' таблица-1

-        .Range(TABLE_2).ClearContents ' таблица-2

-        .Range(TABLE_3).ClearContents ' таблица-3

-        .Range(TABLE_COMMENT).Value = "" ' коментарий-3

-        .Range(TABLE_4).ClearContents ' таблица-4

-    End With

-End Sub

-

-Function TDenmark_Calc() As Boolean

-    

-    Dim nWindow As Integer

-    Dim bPrevCloseFilter, bSuccCloseFilter As Boolean

-    

-    TDenmark_Calc = False

-    

-    mobjAppRunEnable.EnableRun ESTIMATION_DATE, Now

-    

-    With ThisWorkbook

-        .Application.ScreenUpdating = False

-'1)    Read User data

-        With .Worksheets(VAR_SHEET)

-            DenmarkDataArray.ProjectNumber = .Range("DEN_PROECT").Value

-            DenmarkDataArray.SignalParameter = .Range("DEN_PARAM").Value

-            nWindow = .Range("DEN_WINDOW").Value

-            bPrevCloseFilter = .Range("BOOL_PREV_CLOSE").Value

-            bSuccCloseFilter = .Range("BOOL_SUCC_CLOSE").Value

-        End With

-

-'2)   Memory allocation

-        allocate_memory PriceDataArray, DenmarkDataArray, nWindow

-

-'3)   Read data

-        Dim TheRange As Range

-        Set TheRange = .Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE)

-        Dim LinesCount As Integer

-        LinesCount = ReadPricesData(Location:=TheRange, Hist:=PriceDataArray.tC, dt:=1, pPriceData:=PriceDataArray)

-        

-        'Init function result

-        TDenmark_Calc = LinesCount >= nWindow

-        

-        If LinesCount >= nWindow Then

-        

-'4)   Calculate metod TDenmarkDataArray

-            DetDenmark PriceDataArray, DenmarkDataArray, bPrevCloseFilter, bSuccCloseFilter

-            If Abs(DenmarkDataArray.SignalValue) > 1 Then  'ценовые ориентиры, если есть сигнал

-                DetProj PriceDataArray, DenmarkDataArray

-            End If

-'5)   Write result

-            Application.ScreenUpdating = False

-    

-'6)    Clear interface tables

-            ClearResultTables

-            

-            ResultLinesOut Location:=TheRange.Offset(2, 0), pPD:=PriceDataArray, pDen:=DenmarkDataArray

-            

-            With .Worksheets(FORM_SHEET)

-                Out_Table_1 TheRange:=.Range(TABLE_1).Cells(1, 1), pDen:=DenmarkDataArray, LastIdx:=PriceDataArray.tC

-                Out_Table_2 _

-                        TheRange:=.Range(TABLE_2).Cells(1, 1), _

-                        TheComment:=.Range("TABLE_COMMENT"), _

-                        pPD:=PriceDataArray, _

-                        pDen:=DenmarkDataArray

-                Out_Table_3 TheRange:=.Range(TABLE_3).Cells(1, 1), pDen:=DenmarkDataArray

-                Out_Table_4 TheRange:=.Range(TABLE_4).Cells(1, 1), pPD:=PriceDataArray

-                With .Range(TABLE_1)

-                    .Font.Name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-                With .Range(TABLE_2)

-                    .Font.Name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-                With .Range(TABLE_3)

-                    .Font.Name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-                With .Range(TABLE_4)

-                    .Font.Name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-            End With

-            .Worksheets(VAR_SHEET).Range("BOOL_DEMARK_READY") = True

-        Else

-            MsgBox _

-                Prompt:="Недостаточна глубина выборки данных." _

-                    & vbCrLf & "Измените параметры запроса и пробуйте снова.", _

-                Buttons:=vbOKOnly + vbExclamation, _

-                Title:=PROGRAM_NAME

-            .Worksheets(VAR_SHEET).Range("BOOL_DEMARK_READY") = False

-            .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False

-        End If

-'7)   Free unused memory

-        free_unused_memory PriceDataArray, DenmarkDataArray

-    End With

-End Function

-

-Sub allocate_memory(pPriceData As TPriceData, pDenmarkData As TDenmark, memsize As Integer)

-'  Память под TDenmark

-    ReDim pDenmarkData.ResistanceLine(1 To memsize)

-    ReDim pDenmarkData.ResistancePoints(1 To memsize)

-    ReDim pDenmarkData.SupportLine(1 To memsize)

-    ReDim pDenmarkData.SupportPoints(1 To memsize)

-   

-' Инициализация данных по ценам

-    pPriceData.tC = memsize

-    ReDim pPriceData.D(1 To memsize)

-    ReDim pPriceData.Tm(1 To memsize)

-    ReDim pPriceData.Opn(1 To memsize)

-    ReDim pPriceData.Hgh(1 To memsize)

-    ReDim pPriceData.Lw(1 To memsize)

-    ReDim pPriceData.Cls(1 To memsize)

-    ReDim pPriceData.Vl(1 To memsize)

-

-End Sub

-

-Sub free_unused_memory(pP As TPriceData, pD As TDenmark)

-'   Free Prices

-    pP.tC = 0

-    Erase pP.D

-    Erase pP.Tm

-    Erase pP.Opn

-    Erase pP.Hgh

-    Erase pP.Lw

-    Erase pP.Cls

-    Erase pP.Vl

-    

-'Free TDenmark

-    Erase pD.ResistanceLine

-    Erase pD.ResistancePoints

-    Erase pD.SupportLine

-    Erase pD.SupportPoints

-End Sub

-

-

-'*****************************************

-Sub DetDenmark(pPriceData As TPriceData, pDenmarkData As TDenmark, ByVal ClosePrev2 As Boolean, ByVal CloseSucc1 As Boolean)

-' определение элементов данных Денмарка (в цифровой форме)

-' на текущий момент времени времени tC

-' ИСХОДНЫЕ ДАННЫЕ:

-' pPriceData  - окно, стандартная форма данных по ценам (определена)

-' ClosePrev2 - H(t) > max{ H(t-1), H(t+1)} и  H(t) > Close(t-2)

-' CloseSucc1 - H(t) > max{ H(t-1), H(t+1)}  и  R(t+1) > Close(t+1)

-' РЕЗУЛЬТАТ:

-' pDenmarkData - элементы данных Денмарка (память выделена, SignalParameter - определен):

-' линии ResistanceLine,SupportLine их наклоны, опорные точки, сигналы к покупке или продаже

-' SignalValue = 0 сигнал отсутствует

-' SignalValue < 0 прорыв восходящего тренда (сигнал продажи)

-' SignalValue > 0 прорыв нисходящего тренда (сигнал покупки)

-' Если pDenmarkData.ResistancePointCount < 2, то элементы ResistanceLine не определяются

-' Если pDenmarkData.SupportPointsCount < 2, то элементы SupportLine не определяются

-

-' начальная установка

-    Const QUALIFICATOR_DISABLE As String = "-"

-    Const QUALIFICATOR_ENABLE As String = "Signal"

-    

-    Dim UpQual(1 To 3) As String

-    Dim DownQual(1 To 3) As String

-    Dim UpSignal, DownSignal As Integer

-    Dim i As Integer

-    

-    pDenmarkData.SignalValue = 0

-    UpSignal = 0

-    DownSignal = 0

-    

-    For i = 1 To 3

-        pDenmarkData.Qualificator(i) = QUALIFICATOR_DISABLE

-        UpQual(i) = QUALIFICATOR_DISABLE

-        DownQual(i) = QUALIFICATOR_DISABLE

-    Next i

-    

-' определение линии поддержки и сопротивления

-    ResLine _

-        pPriceData, _

-        pPriceData.tC, _

-        pDenmarkData.ResistancePointCount, _

-        pDenmarkData.ResistanceLine, _

-        pDenmarkData.ResistancePoints, _

-        ClosePrev2, _

-        CloseSucc1

-        

-    SuppLine _

-        pPriceData, _

-        pPriceData.tC, _

-        pDenmarkData.SupportPointsCount, _

-        pDenmarkData.SupportLine, _

-        pDenmarkData.SupportPoints, _

-        ClosePrev2, _

-        CloseSucc1

-

-        

-        

-    If pDenmarkData.ResistancePointCount >= 2 Then

-        pDenmarkData.ResistanceAngle = 57.29578 * _

-            Atn(pDenmarkData.ResistanceLine(pPriceData.tC) - _

-                pDenmarkData.ResistanceLine(pPriceData.tC - 1))

-    End If

-    If pDenmarkData.SupportPointsCount >= 2 Then

-        pDenmarkData.SupportAngle = 57.29578 * _

-            Atn(pDenmarkData.SupportLine(pPriceData.tC) - _

-                pDenmarkData.SupportLine(pPriceData.tC - 1))

-    End If

-

-' ФОРМИРОВАНИЕ СИГНАЛА ----------------------------------

-    Dim t As Integer

-' 1. случай нисходящего тренда: ResistanceLine определен и ResistanceLine падает *************

-    If pDenmarkData.ResistancePointCount >= 2 And pDenmarkData.ResistanceAngle < 0 Then

-'    необходимое условие прорыва вверх

-        If pDenmarkData.ResistanceLine(pPriceData.tC) < pPriceData.Cls(pPriceData.tC) Then

-            UpSignal = 1

-            For t = pPriceData.tC - pDenmarkData.SignalParameter To pPriceData.tC - 1

-                If pPriceData.Cls(t) > pDenmarkData.ResistanceLine(t) Then

-                    UpSignal = 0

-                    Exit For

-                End If

-            Next t

-        End If

-        If UpSignal = 1 Then

-'       Qualificator-1: close убывает накануне прорыва

-            If pPriceData.Cls(pPriceData.tC - 2) > pPriceData.Cls(pPriceData.tC - 1) Then

-                UpSignal = UpSignal + 1

-                UpQual(1) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-2: open > ResistanceLine в момент прорыва

-            If pPriceData.Opn(pPriceData.tC) > pDenmarkData.ResistanceLine(pPriceData.tC) Then

-                UpSignal = UpSignal + 1

-                UpQual(2) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-3 - demand value < ResistanceLine(tC)

-            If 2 * pPriceData.Cls(pPriceData.tC - 1) - pPriceData.Lw(pPriceData.tC - 1) < pDenmarkData.ResistanceLine(pPriceData.tC) Then

-                UpSignal = UpSignal + 1

-                UpQual(3) = QUALIFICATOR_ENABLE

-            End If

-        End If

-    End If  ' нисходящий тренд обработан ************************************

-

-' 2. случай восходящего тренда: SupportLine определен и SupportLine растет

-    If pDenmarkData.SupportPointsCount >= 2 And pDenmarkData.SupportAngle > 0 Then

-'    ---------------------------------------------

-'    необходимое условие прорыва вниз

-        If pPriceData.Cls(pPriceData.tC) < pDenmarkData.SupportLine(pPriceData.tC) Then

-            DownSignal = -1

-            For t = pPriceData.tC - pDenmarkData.SignalParameter To pPriceData.tC - 1

-                If pPriceData.Cls(t) < pDenmarkData.SupportLine(t) Then

-                    DownSignal = 0

-                    Exit For

-                End If

-            Next t

-        End If

-        If DownSignal = -1 Then

-'       Qualificator-1: Close растет накануне прорыва

-            If pPriceData.Cls(pPriceData.tC - 2) < pPriceData.Cls(pPriceData.tC - 1) Then

-                DownSignal = DownSignal - 1

-                DownQual(1) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-2: Open ниже ResistanceLine в момент прорыва

-            If pPriceData.Opn(pPriceData.tC) < pDenmarkData.SupportLine(pPriceData.tC) Then

-                DownSignal = DownSignal - 1

-                DownQual(2) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-3 - supply value(t-1) > SupportLine(tC)

-            If 2 * pPriceData.Cls(pPriceData.tC - 1) - pPriceData.Hgh(pPriceData.tC - 1) > pDenmarkData.SupportLine(pPriceData.tC) Then

-                DownSignal = DownSignal - 1

-                DownQual(3) = QUALIFICATOR_ENABLE

-            End If

-        End If

-'    ---------------------------------------------

-    End If

-'      Существует преобладание тенденции

-    If Abs(DownSignal) <> UpSignal Then

-        If Abs(DownSignal) > UpSignal Then

-            pDenmarkData.SignalValue = DownSignal

-            For i = 1 To 3

-                pDenmarkData.Qualificator(i) = DownQual(i)

-            Next i

-        Else

-            pDenmarkData.SignalValue = UpSignal

-            For i = 1 To 3

-                pDenmarkData.Qualificator(i) = UpQual(i)

-            Next i

-        End If

-    End If

-End Sub

-

-Sub DetProj(pPriceData As TPriceData, pDenmarkData As TDenmark)

-'Определение проекции при наличии сигнала: |Signal| > 1

-'Услловие применимости |Signal| > 1 !!!

-    Dim pM As Double, t As Integer, Tm As Integer, tL As Integer

-

-    If pDenmarkData.SignalValue >= 2 Then  ' СИГНАЛ ПОКУПКИ

-

-        tL = pDenmarkData.ResistancePoints(pDenmarkData.ResistancePointCount)     ' tR determination

-        If tL = pPriceData.tC Then

-            tL = pDenmarkData.ResistancePoints(pDenmarkData.ResistancePointCount - 1)

-        End If

-

-'  Projections 1,2 --------------------------------------------

-        If pDenmarkData.ProjectNumber >= 1 And pDenmarkData.ProjectNumber <= 2 Then

-'           t* = Arg min {L(t) : t R <= t  <= tb ,  L(t) < ResistanceLine(t)},

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Lw(Tm) ' L(t-1) < ResistanceLine(t-1) for t - break point !

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Lw(t) < pM And pPriceData.Lw(t) < pDenmarkData.ResistanceLine(t) Then

-                    pM = pPriceData.Lw(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            If pDenmarkData.ProjectNumber = 1 Then

-'               P1( tb) = ResistanceLine(tb) + ResistanceLine(t*) - L(t*)

-                pDenmarkData.ProjectPrice = pDenmarkData.ResistanceLine(pPriceData.tC) + pDenmarkData.ResistanceLine(Tm) - pPriceData.Lw(Tm)

-            Else

-                pDenmarkData.ProjectPrice = pDenmarkData.ResistanceLine(pPriceData.tC) + pDenmarkData.ResistanceLine(Tm) - pPriceData.Cls(Tm)

-            End If

-        End If ' pDenmarkData.ProjectNumber >= 1 And pDenmarkData.ProjectNumber <= 2

-   

-'  ----------------------------------------------------------------

-'  Projections 3

-        If pDenmarkData.ProjectNumber = 3 Then

-'           t*  = Arg min { С(t) : t R <= t  <= tb ,  C(t) < ResistanceLine(t)}

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Cls(Tm)

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Cls(t) < pM And pPriceData.Cls(t) < pDenmarkData.ResistanceLine(t) Then

-                    pM = pPriceData.Cls(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            pDenmarkData.ProjectPrice = pDenmarkData.ResistanceLine(pPriceData.tC) + pDenmarkData.ResistanceLine(Tm) - pPriceData.Cls(Tm)

-        End If

-    End If ' pDenmarkData.SignalValue >= 2

-

-'-------------------------------------------------------------------

-'*******************************************************************

-' ПРОЕКЦИЯ ДЛЯ СИГНАЛА ПРОДАЖИ

-    If pDenmarkData.SignalValue <= -2 Then

-        tL = pDenmarkData.SupportPoints(pDenmarkData.SupportPointsCount)  ' tR determination

-        If tL = pPriceData.tC Then

-            tL = pDenmarkData.ResistancePoints(pDenmarkData.SupportPointsCount - 1)

-        End If

-

-'  Projections 1,2 --------------------------------------------

-        If pDenmarkData.ProjectNumber = 1 Or pDenmarkData.ProjectNumber = 2 Then

-'           t* = Arg max {H(t) : t R <= t  <= tb ,  H(t) > SupportLine(t)},

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Hgh(Tm) ' H(t-1) > SupportLine(t-1) for t - break point !

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Hgh(t) > pM And pPriceData.Hgh(t) > pDenmarkData.SupportLine(t) Then

-                    pM = pPriceData.Hgh(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            If pDenmarkData.ProjectNumber = 1 Then

- '              P1( tb) = SupportLine(tb) + SupportLine(t*) - H(t*)

-                pDenmarkData.ProjectPrice = pDenmarkData.SupportLine(pPriceData.tC) + pDenmarkData.SupportLine(Tm) - pPriceData.Hgh(Tm)

-            Else

-'               P2( tb) = SupportLine(tb) + SupportLine(t*) - C(t*)

-                pDenmarkData.ProjectPrice = pDenmarkData.SupportLine(pPriceData.tC) + pDenmarkData.SupportLine(Tm) - pPriceData.Cls(Tm)

-            End If

-        End If

-   

-'  ----------------------------------------------------------------

-'  Projections 3

-        If pDenmarkData.ProjectNumber = 3 Then

-'           t*  = Arg max { С(t) : t R <= t  <= tb ,  C(t) >  SupportLine(t)}

-'           P3( tb) = SupportLine(tb) + SupportLine(t*) - C(t*)

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Cls(Tm)

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pM < pPriceData.Cls(t) And pPriceData.Cls(t) > pDenmarkData.SupportLine(t) Then

-                    pM = pPriceData.Cls(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            pDenmarkData.ProjectPrice = pDenmarkData.SupportLine(pPriceData.tC) + pDenmarkData.SupportLine(Tm) - pPriceData.Cls(Tm)

-        End If

-    End If ' pDenmarkData.SignalValue <= -2

-End Sub

-

-Sub ResLine(pP As TPriceData, tE As Integer, ResistancePointCount As Integer, _

-            ResistanceLine() As Double, s() As Integer, ClosePrev2 As Boolean, CloseSucc1 As Boolean)

-' Определение линии сопротивления по Демарку [1]

-' Основной вариант

-' ИСХОДНЫЕ ДАННЫЕ:

-' High, dom(High) = [1, tE]

-' ClosePrev2 - H(t) > max{ H(t-1), H(t+1)} и  H(t) > Close(t-2)

-' CloseSucc1 - H(t) > max{ H(t-1), H(t+1)}  и  R(t+1) > Close(t+1)

-' РЕЗУЛЬТАТ:

-' 1) линия сопротивления ResistanceLine, dom(ResistanceLine)=[s(1), tE], и

-' 2) s = {s(1), s(2), ..., s(ResistancePointCount)}, s(1) < s(2) < ...< s(ResistancePointCount)

-'   ( s(ResistancePointCount)<= tE )- опорные точки

-' 3) число опорных точек ResistancePointCount.

-' 4) s(1) -  первый момент времени с которого определена SupportLine

-'    то есть dom{Supp} = [s(1), tC]

-' Прим. Если число опорных точек окажется < 2, то линия

-' сопротивления не определяется. В этом случае следует

-' увеличить историю tE !!!

-    Dim t As Integer, i As Integer

-    Dim v As Double

-    Dim IsGoodPoint As Boolean

-  

-'1 определение опорных моментов времени

-    ResistancePointCount = 0

-    For t = 3 To tE - 1

- '      v = max{high(t-1), high(t+1)} < high(t)}

-        v = pP.Hgh(t - 1)

-        If v < pP.Hgh(t + 1) Then

-            v = pP.Hgh(t + 1)

-        End If

-        IsGoodPoint = pP.Hgh(t) > v

-        If IsGoodPoint And ClosePrev2 Then

-            IsGoodPoint = IsGoodPoint And (pP.Cls(t - 2) < pP.Hgh(t))

-        End If

-        

-        If IsGoodPoint Then       'alt.: v >= High(t + 1)

-            s(ResistancePointCount + 1) = t: ResistancePointCount = ResistancePointCount + 1

-        End If

-    Next t

-    

-loop_:

-    

-    If ResistancePointCount < 2 Then

-        GoTo done

-    End If

-

-' 2 определение линии сопротивления

-    ResistanceLine(s(1)) = pP.Hgh(s(1))

-    For i = 2 To ResistancePointCount

-        ResistanceLine(s(i)) = pP.Hgh(s(i))

-        v = (pP.Hgh(s(i)) - pP.Hgh(s(i - 1))) / (s(i) - s(i - 1))

-        For t = s(i - 1) + 1 To s(i) - 1

-            ResistanceLine(t) = pP.Hgh(s(i - 1)) + v * (t - s(i - 1))

-        Next t

-    Next i

-    If s(ResistancePointCount) < tE Then

-        v = (pP.Hgh(s(ResistancePointCount)) - pP.Hgh(s(ResistancePointCount - 1))) / (s(ResistancePointCount) - s(ResistancePointCount - 1))

-        For t = s(ResistancePointCount) + 1 To tE

-            ResistanceLine(t) = pP.Hgh(s(ResistancePointCount - 1)) + v * (t - s(ResistancePointCount - 1))

-        Next t

-    End If

-    If CloseSucc1 Then

-        For t = 1 To ResistancePointCount

-            If ResistanceLine(s(t) + 1) < pP.Cls(s(t) + 1) Then

-                ResistancePointCount = ResistancePointCount - 1

-                ' удалить точку

-                For i = t To ResistancePointCount

-                    s(i) = s(i + 1)

-                Next i

-                s(ResistancePointCount + 1) = 0

-                ' очистить массив линии

-                Dim Lb, Rb As Integer

-                Lb = LBound(ResistanceLine)

-                Rb = UBound(ResistanceLine)

-                Erase ResistanceLine

-                ReDim ResistanceLine(Lb To Rb)

-                GoTo loop_

-            End If

-        Next t

-    End If

-    

-done:

-End Sub

-

-Sub SuppLine(pP As TPriceData, tE As Integer, SupportPointsCount As Integer, _

-               SupportLine() As Double, s() As Integer, ClosePrev2 As Boolean, CloseSucc1 As Boolean)

-' Определение линии поддержки по Демарку [1] (от конца)

-' Исходные данные:

-' Low, dom(Low) = [1, tE]

-' ClosePrev2 - H(t) > max{ H(t-1), H(t+1)} и  H(t) > Close(t-2)

-' CloseSucc1 - H(t) > max{ H(t-1), H(t+1)}  и  R(t+1) > Close(t+1)

-' Результат:

-' 1) линия сопротивления SupportLine, dom(SupportLine)=[s(1), tE],

-' 2) s = {s(1), s(2), ..., s(SupportPointsCount)}, s(1) < s(2) < ...< s(SupportPointsCount) -

-'    опорные точки

-' 3) число опорных точек SupportPointsCount.

-' Прим. Если фактическое число опорных точек окажется < 2, то линия

-' поддержки не определяется.

-    Dim t As Integer, i As Integer

-    Dim v As Double

-    Dim IsGoodPoint As Boolean

-    

-'1 определение опорных моментов времени

-     SupportPointsCount = 0

-    For t = 3 To tE - 1

-'       v = min{Low(t-1), Low(t+1)} > Low(t)

-        v = pP.Lw(t - 1)

-        If v > pP.Lw(t + 1) Then

-            v = pP.Lw(t + 1)

-        End If

-        

-        IsGoodPoint = pP.Lw(t) < v

-        

-        If IsGoodPoint And ClosePrev2 Then

-            IsGoodPoint = IsGoodPoint And (pP.Cls(t - 2) > pP.Lw(t))

-        End If

-        

-        If IsGoodPoint Then     'alt.: v >= High(t + 1)

-            s(SupportPointsCount + 1) = t: SupportPointsCount = SupportPointsCount + 1

-        End If

-    Next t

-

-loop_:

-    If SupportPointsCount < 2 Then

-        GoTo done

-    End If

-' 2 определение линии поддержки

-    

-    SupportLine(s(1)) = pP.Lw(s(1))

-    For i = 2 To SupportPointsCount

-        SupportLine(s(i)) = pP.Lw(s(i))

-        v = (pP.Lw(s(i)) - pP.Lw(s(i - 1))) / (s(i) - s(i - 1))

-        For t = s(i - 1) + 1 To s(i) - 1

-            SupportLine(t) = pP.Lw(s(i - 1)) + v * (t - s(i - 1))

-        Next t

-    Next i

-    If s(1) < tE Then

-        v = (pP.Lw(s(SupportPointsCount)) - pP.Lw(s(SupportPointsCount - 1))) / (s(SupportPointsCount) - s(SupportPointsCount - 1))

-        For t = s(SupportPointsCount) + 1 To tE

-            SupportLine(t) = pP.Lw(s(SupportPointsCount - 1)) + v * (t - s(SupportPointsCount - 1))

-        Next t

-    End If

-    If CloseSucc1 Then

-        For t = 1 To SupportPointsCount

-            If SupportLine(s(t) + 1) > pP.Cls(s(t) + 1) Then

-                SupportPointsCount = SupportPointsCount - 1

-                ' удалить точку

-                For i = t To SupportPointsCount

-                    s(i) = s(i + 1)

-                Next i

-                s(SupportPointsCount + 1) = 0

-                ' очистить массив линии

-                Dim Lb, Rb As Integer

-                Lb = LBound(SupportLine)

-                Rb = UBound(SupportLine)

-                Erase SupportLine

-                ReDim SupportLine(Lb To Rb)

-                GoTo loop_

-            End If

-        Next t

-    End If

-done:

-End Sub

-

-<<<<<<
-======================
-mChart
->>>>>>
-Attribute VB_Name = "mChart"

-Option Explicit

-

-Const CHART_NAME As String = "PriceChart"

-

-Sub Draw_Chart(SignalDefined As Boolean)

-

-    Dim n As Integer

-    Dim theChart As Chart

-    Dim ChartDataAria, szLastNumber As String

-    Dim MinYScale As Double

-    

-    

-    With ThisWorkbook

-' Checking data

-' Disable screen out

-        .Application.Cursor = xlWait

-        .Application.ScreenUpdating = False

-' Create series range

-        n = GetLinesCount(Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE))

-        szLastNumber = n + 1

-        If SignalDefined Then

-            ChartDataAria = "A2:A" & szLastNumber _

-                        & ",D2:D" & szLastNumber _

-                        & ",G2:G" & szLastNumber _

-                        & ",I2:K" & szLastNumber

-        Else

-            ChartDataAria = "A2:A" & szLastNumber _

-                        & ",D2:D" & szLastNumber _

-                        & ",G2:G" & szLastNumber _

-                        & ",I2:J" & szLastNumber

-        End If

-        MinYScale = GetMinValue(.Worksheets(RAW_DATA_SHEET).Range(ChartDataAria))

-' Find and delete old chart

-        .Worksheets(CHART_SHEET).Unprotect

-        Dim WindowWidth, WindowHeight As Integer

-        With .Worksheets(CHART_SHEET)

-            WindowWidth = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-            WindowHeight = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-        End With

-        

-        

-        With .Worksheets(CHART_SHEET).ChartObjects

-            .Delete

-            With .Add(5, 5, WindowWidth - 10, WindowHeight - 10)

-                .SendToBack

-                Set theChart = .Chart

-            End With

-' Create a chart

-        End With

-        With theChart

-            .ChartType = xlLine

-            .SetSourceData Source:=Sheets(RAW_DATA_SHEET).Range( _

-                    ChartDataAria), PlotBy:=xlColumns

-'                   .Location Where:=xlLocationAsObject, Name:=CHART_SHEET

-            .HasTitle = True

-            With .ChartTitle

-                .Text = ThisWorkbook.Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE).Value

-                With .Font

-                    .Size = 8

-                    .Bold = True

-                End With

-            End With

-            .HasLegend = True

-            With .Legend

-                .Position = xlTop

-                With .Font

-                    .Name = "Arial"

-                    .Size = 8

-                End With

-            End With

-            .HasDataTable = False

-            With .Axes(xlCategory)

-                .HasMajorGridlines = True

-                .HasMinorGridlines = False

-                .TickLabels.Orientation = xlUpward

-                With .MajorGridlines.Border

-                    .ColorIndex = 48

-                    .Weight = xlHairline

-                    .LineStyle = xlDot

-                End With

-                .CrossesAt = 1

-                .TickLabelSpacing = 1

-                .TickMarkSpacing = 1

-                .AxisBetweenCategories = False

-                .ReversePlotOrder = False

-                .TickLabels.AutoScaleFont = True

-                With .TickLabels.Font

-                    .Name = "Arial"

-                    .Size = 8

-                End With

-            End With

-            With .Axes(xlValue)

-                .HasMajorGridlines = True

-                .HasMinorGridlines = False

-                With .MajorGridlines.Border

-                    .ColorIndex = 48

-                    .Weight = xlHairline

-                    .LineStyle = xlDot

-                End With

-                .MinimumScale = MinYScale

-                .MaximumScaleIsAuto = True

-                .MinorUnitIsAuto = True

-                .MajorUnitIsAuto = True

-                .Crosses = xlCustom

-                .CrossesAt = MinYScale

-                .ReversePlotOrder = False

-                .ScaleType = xlLinear

-                .TickLabels.AutoScaleFont = True

-                With .TickLabels.Font

-                    .Name = "Arial"

-                    .Size = 9

-                End With

-            End With

-            .ChartTitle.Top = 5

-            .ChartTitle.Left = 5

-            With .Legend

-                .Top = 5

-                .Fill.OneColorGradient _

-                    Style:=msoGradientHorizontal, _

-                    Variant:=3, _

-                    Degree:=0.303913939116503

-                .Fill.Visible = True

-                .Fill.ForeColor.SchemeColor = 71

-            End With

-            .PlotArea.Left = 10

-            .PlotArea.Top = .Legend.Top + .Legend.Height + 5

-            .PlotArea.Width = .ChartArea.Width - 20

-            .PlotArea.Height = .ChartArea.Height - .PlotArea.Top

-            

-' Tune OPEN line

-            With .SeriesCollection(1)

-                .Border.LineStyle = xlNone

-                .MarkerBackgroundColorIndex = xlNone

-                .MarkerForegroundColorIndex = 1

-                .MarkerStyle = xlPlus

-                .Smooth = False

-                .MarkerSize = 9

-                .Shadow = False

-            End With

-' Tune CLOSE line

-            With .SeriesCollection(2)

-                .Border.ColorIndex = 10

-                .Border.Weight = xlMedium

-                .Border.LineStyle = xlContinuous

-            End With

-' Tune RESISTANCE line

-            With .SeriesCollection(3)

-                .Border.ColorIndex = 3

-                .Border.Weight = xlThin

-                .Border.LineStyle = xlContinuous

-            End With

-' Tune SUUPORT line

-            With .SeriesCollection(4)

-                .Border.ColorIndex = 25

-                .Border.Weight = xlThin

-                .Border.LineStyle = xlContinuous

-            End With

-            If SignalDefined Then

-                With .SeriesCollection(5)

-                    .Border.ColorIndex = 6

-                    .Border.Weight = xlThin

-                    .Border.LineStyle = xlDot

-                End With

-            End If

-        End With

-        .Application.Cursor = xlDefault

-        With .Worksheets(CHART_SHEET)

-            .Select

-            .Protect userInterfaceOnly:=True

-        End With

-    End With

-End Sub

-

-Function GetMinValue(DataRange As Range) As Double

-    Dim Cell As Range

-    Dim MinValue, MaxValue, RangeValue, CorrectValue, Mult As Double

-    MinValue = MAX_PRICE_VALUE

-    MaxValue = MIN_PRICE_VALUE

-    For Each Cell In DataRange

-        If Not IsEmpty(Cell) And IsNumeric(Cell) Then

-            If Cell > MIN_PRICE_VALUE Then

-                If Cell < MinValue Then

-                    MinValue = Cell

-                End If

-                If Cell > MaxValue Then

-                    MaxValue = Cell

-                End If

-            End If

-        End If

-    Next

-    RangeValue = MaxValue - MinValue

-    If RangeValue < 0 Then

-        MinValue = 0

-    Else

-        CorrectValue = RangeValue / 4

-        Mult = MIN_PRICE_VALUE

-        While MinValue - Int(MinValue * Mult) / Mult > CorrectValue

-            Mult = Mult * 10

-        Wend

-        MinValue = Int(MinValue * Mult) / Mult

-    End If

-    GetMinValue = MinValue

-End Function

-

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub GetState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.Name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars("Worksheet Menu Bar").Visible = False

-End Sub

-

-

-Public Sub RestoreState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars("Worksheet Menu Bar").Visible = True

-End Sub

-

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{7596B8A3-31DF-4FA6-9CFD-63E745FC3A75}{E2D0F726-1F87-4336-9895-B0FC73E95498}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Private Sub CommandButton1_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-mWebQeury
->>>>>>
-Attribute VB_Name = "mWebQeury"

-Option Explicit

-

-Public Const Qry_DELETE_ALL As String = "Qry_DELETE_ALL"

-Public Const Qry_PATH_NO_CHANGE As String = "Qry_PATH_NO_CHANGE"

-

-

-Sub QryCreate(QryRange As Range, QryName As String, QryPath As String, Optional RefreshBkgnd = False)

-    Dim WebQuery As QueryTable

-    QryDelete QryRange:=QryRange, QryName:=QryName

-    

-    Set WebQuery = QryRange.Worksheet.QueryTables.Add( _

-            Connection:=QryPath, _

-            Destination:=QryRange)

-    

-    With WebQuery

-        .FieldNames = False

-        .Name = QryName

-        .RefreshStyle = xlOverwriteCells

-        .RowNumbers = False

-        .FillAdjacentFormulas = False

-        .RefreshOnFileOpen = False

-        .HasAutoFormat = False

-        .BackgroundQuery = False

-        .TablesOnlyFromHTML = False

-        .Refresh BackgroundQuery:=RefreshBkgnd

-        .SavePassword = False

-        .SaveData = True

-    End With

-End Sub

-

-Function QryRefresh(QryRange As Range, QryName As String, Optional QryPath As String = Qry_PATH_NO_CHANGE, Optional Background As Boolean = False) As Boolean

-    Dim qry_result As Boolean

-    qry_result = False

-    If QryExist(QryRange, QryName) Then

-        With QryRange.Worksheet.QueryTables(QryName)

-            If QryPath <> Qry_PATH_NO_CHANGE Then

-                .Connection = QryPath

-            End If

-            .Refresh BackgroundQuery:=Background

-            qry_result = True

-        End With

-    End If

-    QryRefresh = qry_result

-End Function

-

-Sub QryDelete(QryRange As Range, Optional QryName As String = Qry_DELETE_ALL)

-    Dim WebQuery As QueryTable

-    For Each WebQuery In QryRange.Worksheet.QueryTables

-        If QryName = Qry_DELETE_ALL Or WebQuery.Name = QryName Then

-            WebQuery.Delete

-        End If

-    Next

-End Sub

-

-Function QryExist(QryRange As Range, QryName As String) As Boolean

-    Dim WebQuery As QueryTable

-    For Each WebQuery In QryRange.Worksheet.QueryTables

-        If WebQuery.Name = QryName Then

-            QryExist = True

-            Exit For

-        End If

-    Next

-End Function

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Sub CreateCommandBar(theApp As Application)

-Attribute CreateCommandBar.VB_ProcData.VB_Invoke_Func = "R\n14"

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible + msoBarNoCustomize + msoBarNoMove + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Print"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 4

-                        .OnAction = "cmPrint"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Contents"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 49

-                        .OnAction = "cmHelpContents"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible + msoBarNoCustomize + msoBarNoMove + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(Flag As Boolean)

-    If Flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars("Worksheet Menu Bar")

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        cmHelpContents

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mTool
->>>>>>
-Attribute VB_Name = "mTool"

-Option Explicit

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub tool_delete_all_tables()

-    QryDelete ThisWorkbook.Worksheets(RAW_DATA_SHEET).Range("A1")

-End Sub

-

-Sub tool_delete_all_charts(theSheet As Worksheet)

-    Dim theChart As Chart

-    For Each theChart In theSheet

-        theChart.Unprotect

-        theChart.Delete

-    Next

-End Sub

-

-Sub DateTimeTest()

-    Dim the_date

-    Dim the_time

-    the_date = DateValue(Now)

-    the_time = TimeValue(Now)

-End Sub

-

-

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{122F0FA6-6A60-45B6-9F0E-0CE00712999B}{7C2DD166-FCE9-4666-A2DB-2FDD36929C39}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-

-Private Sub App_WorkbookOpen(ByVal wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If Application.Workbooks.count > 1 Then

-        wbname = wb.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKCancel, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            wb.Close Savechanges:=False

-        End If

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-mDataCommands
->>>>>>
-Attribute VB_Name = "mDataCommands"

-Option Explicit

-

-Sub evFileOpen()

-    Dim fileToOpen As String

-    Dim wb As Workbook

-    Dim ticker As String

-    Dim Result As Integer

-

-    fileToOpen = Application.GetOpenFilename("Text Files (*.txt), *.txt")

-    Set wb = ThisWorkbook

-    With wb

-        If fileToOpen <> "False" Then

-            If .Worksheets(VAR_SHEET).Range("BOOL_AUTORECALC") = True Then

-                .Worksheets(VAR_SHEET).Range("BOOL_AUTORECALC") = False

-            End If

-            .Worksheets(FORM_SHEET).Range(FILE_NAME) = fileToOpen

-            Result = UpdateHistoryFromFile(wb, fileToOpen)

-            .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False

-            .Worksheets(VAR_SHEET).Range("BOOL_DEMARK_READY") = False

-            

-            ClearResultTables

-            

-            Select Case Result

-                Case FUNCRES_FILE_OK

-                    .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = True

-                    If TDenmark_Calc Then

-                        With .Worksheets(RAW_DATA_SHEET)

-                            ticker = .Range("B1")

-                        End With

-                        With .Worksheets(FORM_SHEET)

-                            .Range("CALC_TICKER_NAME") = ticker

-                        End With

-                    End If

-                Case FUNCRES_FILE_VERY_SMALL

-                    .Worksheets(FORM_SHEET).Range("CALC_TICKER_NAME") = MSG_FILE_VERY_SMALL

-                    MsgBox MSG_FILE_VERY_SMALL, vbOKOnly, PROGRAM_NAME

-                Case FUNCRES_FILE_INVALID_FORMAT

-                    .Worksheets(FORM_SHEET).Range("CALC_TICKER_NAME") = MSG_FILE_INVALID_FORMAT

-                    MsgBox MSG_FILE_INVALID_FORMAT, vbOKOnly, PROGRAM_NAME

-                End Select

-            .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False

-        End If

-    End With 'wb

-End Sub

-

-Sub evSubmit_Click()

-    Dim ticker As String

-    Dim Period As String

-

-    Application.Cursor = xlWait

-    Dim wb As Workbook

-    Set wb = ThisWorkbook

-    With wb

-        With .Worksheets(VAR_SHEET)

-            ticker = .Range("DEN_SYMBOL")

-            Period = .Range("DEN_TIME")

-            If .Range("BOOL_DATA_READY") = False Or .Range("BOOL_LOAD_DATA") = True Then

-                .Range("BOOL_DATA_READY") = UpdateHistoryFromWeb(wb)

-            End If

-            .Range("BOOL_DEMARK_READY") = False

-        End With

-        If .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False Then

-            MsgBox _

-                Prompt:="Недостаточна глубина выборки данных." _

-                    & vbCrLf & "Измените параметры запроса и пробуйте снова.", _

-                Buttons:=vbOKOnly + vbExclamation, _

-                Title:=PROGRAM_NAME

-            

-            ClearResultTables

-            

-            With .Worksheets(FORM_SHEET)

-                .Range("CALC_TICKER_NAME") = ticker & ", Period=" & Period

-                .Range("FILE_NAME") = ""

-                .Range(TABLE_COMMENT).Value = "Недостаточно данных"

-            End With

-        Else

-            If TDenmark_Calc Then

-                With .Worksheets(FORM_SHEET)

-                    .Range("CALC_TICKER_NAME") = ticker & ", Period=" & Period

-                    .Range("FILE_NAME") = ""

-                End With

-            End If

-        End If

-    End With

-    Application.Cursor = xlDefault

-End Sub

-

-Sub evTicker_Change()

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("IDX_DEN_SECNAME") = .Range("IDX_DEN_SYMBOL")

-    End With

-    evHistory_Change

-End Sub

-

-Sub evSecName_Change()

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("IDX_DEN_SYMBOL") = .Range("IDX_DEN_SECNAME")

-    End With

-    evHistory_Change

-End Sub

-

-Sub evLastInterval_Change()

-    MsgBox "Не работает в этой версии"

-End Sub

-

-Sub evHistory_Change()

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("BOOL_DATA_READY") = False

-    End With

-End Sub

-

-Sub evGroupChange()

-    Dim GroupIdx, LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange As String

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        GroupIdx = .Range("IDX_DEN_LIST")

-        .Range("IDX_DEN_SYMBOL") = 1

-        NewRangeOffsetCol = (GroupIdx - 1) * 2

-        LinesCount = GetLinesCount(.Range("TICKER_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .Name & "!" & .Range(.Range("TICKER_TABLES").Offset(1, NewRangeOffsetCol), .Range("TICKER_TABLES").Offset(LinesCount, NewRangeOffsetCol)).Address

-        ThisWorkbook.Worksheets(FORM_SHEET).Shapes("cbxTikers").ControlFormat.ListFillRange = NewCbxRange

-        NewRangeOffsetCol = NewRangeOffsetCol + 1

-        NewCbxRange = .Name & "!" & .Range(.Range("TICKER_TABLES").Offset(1, NewRangeOffsetCol), .Range("TICKER_TABLES").Offset(LinesCount, NewRangeOffsetCol)).Address

-        ThisWorkbook.Worksheets(FORM_SHEET).Shapes("cbxSecName").ControlFormat.ListFillRange = NewCbxRange

-    End With

-    evTicker_Change

-End Sub

-

-Sub evUpdateTickerList()

-    UpdateTickerList ThisWorkbook

-    evHistory_Change

-End Sub

-<<<<<<
-======================
-mGetFileData
->>>>>>
-Attribute VB_Name = "mGetFileData"

-Option Explicit

-

-Dim mobjAppRunEnable As New cEnableRun

-

-Public Const MAX_LOAD_DATA_LINES As Integer = 16000

-

-Public Const MSG_FILE_VERY_SMALL As String = "В файле недостаточно данных"

-Public Const MSG_FILE_INVALID_FORMAT As String = "Неверный формат файла"

-

-Public Const FUNCRES_FILE_OK As Integer = 0

-Public Const FUNCRES_FILE_VERY_SMALL As Integer = -1

-Public Const FUNCRES_FILE_INVALID_FORMAT As Integer = -2

-

-Function UpdateHistoryFromFile(wb As Workbook, fileToOpen As String) As Integer

-    Dim DestRangeName As String

-    Dim ResultLength As Integer

-    Dim Location As Range

-    Dim denWindow As Integer

-    Dim IsIntraday As Boolean

-    Dim CalcNextTime As Boolean

-        

-    Dim SingleFileLine As String

-    Dim FileHandler As Integer

-    Dim i, j, row_idx As Integer

-    

-    UpdateHistoryFromFile = FUNCRES_FILE_INVALID_FORMAT

-    With wb

-        .Application.ScreenUpdating = False

-        With .Worksheets(VAR_SHEET)

-            CalcNextTime = .Range("BOOL_NEXT_TIME")

-            denWindow = .Range("DEN_WINDOW") + 1

-            If CalcNextTime Then

-                denWindow = denWindow + 1

-            End If

-            IsIntraday = True

-        End With

-        With .Worksheets(RAW_DATA_SHEET)

-            'Clear table include temp area

-            .Parent.Application.DisplayAlerts = False

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW - 1, RAW_DATA_RANGE_COL - 1), _

-                .Cells(65535, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-            ).ClearContents

-            Set Location = .Range(RAW_DATA_RANGE).Offset(-1, 0)

-            

-            ' Reading data from file

-            FileHandler = FreeFile

-            row_idx = 0

-            Open fileToOpen For Input As #FileHandler

-            Do While Not EOF(FileHandler) And row_idx < MAX_LOAD_DATA_LINES

-                Line Input #FileHandler, SingleFileLine

-                .Range(PRICE_TABLE).Offset(row_idx, 0) = SingleFileLine

-                row_idx = row_idx + 1

-            Loop

-            Close #FileHandler

-            

-            ' Parsing data

-            DestRangeName = "=" & RAW_DATA_SHEET & "!$B$1:$B" & row_idx

-            ResultLength = row_idx

-            

-            .Range(DestRangeName).TextToColumns _

-                Destination:=.Range(DestRangeName), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=True, _

-                Semicolon:=True, _

-                Comma:=True, _

-                Space:=False, _

-                Other:=False, _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 1), _

-                                Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1))

-            

-            .Parent.Application.DisplayAlerts = True

-            Dim CurrentDate As String

-            Dim RawData As Range

-            

-            Set RawData = .Range(RAW_DATA_RANGE)

-            

-            If Not CheckFileFormat(RawData.Offset(-1, 0)) Then

-                UpdateHistoryFromFile = FUNCRES_FILE_INVALID_FORMAT

-                Exit Function

-            End If

-            

-            row_idx = 0

-            With RawData

-                CurrentDate = .Value

-                For i = 1 To ResultLength

-                    If Not IsIntraday And CurrentDate = .Offset(i, DATE_IDX).Value Then

-                        ' skip virtual prices

-                        If (.Offset(i, VOLUME_IDX) > MIN_PRICE_VALUE) Then

-                            If .Offset(row_idx, HIGH_IDX).Value < .Offset(i, HIGH_IDX).Value Then

-                                .Offset(row_idx, HIGH_IDX).Value = .Offset(i, HIGH_IDX).Value

-                            End If

-                            If .Offset(row_idx, LOW_IDX).Value > .Offset(i, LOW_IDX).Value Then

-                                .Offset(row_idx, LOW_IDX).Value = .Offset(i, LOW_IDX).Value

-                            End If

-                            .Offset(row_idx, VOLUME_IDX).Value = _

-                                .Offset(row_idx, VOLUME_IDX).Value + .Offset(i, VOLUME_IDX).Value

-                            .Offset(row_idx, TIME_IDX).Value = .Offset(i, TIME_IDX).Value

-                            .Offset(row_idx, CLOSE_IDX).Value = .Offset(i, CLOSE_IDX).Value

-                        End If

-                    Else

-                        ' skip virtual prices

-                        If (.Offset(row_idx, VOLUME_IDX) > MIN_PRICE_VALUE) Then

-                            row_idx = row_idx + 1

-                        End If

-                        For j = DATE_IDX To VOLUME_IDX

-                            .Offset(row_idx, j) = .Offset(i, j)

-                        Next j

-                        CurrentDate = .Offset(i, DATE_IDX)

-                    End If

-                Next i

-            End With ' RawData

-            ' Clear unused Cells

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(65536, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-            ).ClearContents

-            

-            If row_idx > denWindow Then

-                row_idx = row_idx - denWindow

-                .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-                ).Delete xlShiftUp

-            Else

-                UpdateHistoryFromFile = FUNCRES_FILE_VERY_SMALL

-                Exit Function

-            End If

-            

-            row_idx = denWindow + 1

-            

-            Set Location = .Range( _

-                .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_IDX) _

-            )

-            

-            Location.TextToColumns _

-                Destination:=Location.Offset(0, DATE_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:="/", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2))

-            

-            Location.Offset(0, TIME_IDX).TextToColumns _

-                Destination:=Location.Offset(0, TIME_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:=":", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2))

-            

-            ' Check estimation date

-            

-            Dim end_date, end_time As Date

-            Dim year, month, day As Integer

-            Dim hour, minute As Integer

-            Dim next_time_exist As Boolean

-            

-            year = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 3)

-            month = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 2)

-            day = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 1)

-            hour = Location.Cells(denWindow - 1, TIME_STAMP_OFFSET + 1)

-            minute = Location.Cells(denWindow - 1, TIME_STAMP_OFFSET + 2)

-            

-            next_time_exist = day + month + year <> 0

-            

-            If next_time_exist Then

-                end_date = DateSerial(year, month, day)

-                end_time = TimeSerial(hour, minute, 0)

-                mobjAppRunEnable.EnableRun ESTIMATION_DATE, end_date

-            End If

-             

-            row_idx = 0

-            Dim temp_str As String

-                    

-            If IsIntraday Then

-                Do While IsEmpty(Location.Cells(1 + row_idx, 1 + DATE_IDX)) = False

-                       temp_str = Location.Cells(1 + row_idx, 1 + PROJECT_IDX + 1)

-                       temp_str = temp_str & "/"

-                       temp_str = temp_str & Location.Cells(1 + row_idx, 1 + PROJECT_IDX + 2)

-                       temp_str = temp_str & "-"

-                       temp_str = temp_str & Location.Cells(1 + row_idx, 1 + TIME_IDX)

-                       Location.Cells(1 + row_idx, DATE_IDX) = temp_str

-                       row_idx = row_idx + 1

-                Loop

-                row_idx = row_idx - 1

-                Dim condition As Boolean

-                condition = Not CalcNextTime And next_time_exist And end_date = DateValue(Now) And end_time > TimeValue(Now)

-                If condition Then

-                    .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL - 1), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-                    ).Delete xlShiftUp

-                End If

-            End If

-        End With ' .Worksheets(RAW_DATA_SHEET)

-    End With ' wb

-    UpdateHistoryFromFile = FUNCRES_FILE_OK

-End Function

-

-Function CheckFileFormat(HeaderString As Range) As Boolean

-    With HeaderString

-        CheckFileFormat = _

-            .Offset(0, DATE_IDX) = "Date" And _

-            .Offset(0, TIME_IDX) = "Time" And _

-            .Offset(0, OPEN_IDX) = "Open" And _

-            .Offset(0, CLOSE_IDX) = "Close" And _

-            .Offset(0, LOW_IDX) = "Low" And _

-            .Offset(0, HIGH_IDX) = "High" And _

-            .Offset(0, VOLUME_IDX) = "Volume"

-    End With

-End Function

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module2
->>>>>>
-Attribute VB_Name = "Module2"

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mRead
->>>>>>
-Attribute VB_Name = "mRead"

-

-Option Explicit

-

-

-

-

-Sub ReadData1(aPoint As String, Hist As Integer, dt As Integer, _

-              p As PriceData)

-'Инициализация типа PriceData из таблицы типа - 1

-'kопируются не более чем hist последних строк

-'aPoint - начало таблицы

-'первые две строки таблицы идентифицирует данные (строки)

- Dim n As Integer, i As Integer

-'Определение числа строк таблицы - n

- Dim theRange As Range

- Set theRange = ActiveSheet.Range(aPoint)

- n = 0

- Do While IsEmpty(theRange.Offset(n, 0).Value) = False

-     n = n + 1

- Loop

- If n = 0 Then             'обработать ошибку !!!

-    GoTo done

- End If

-' число строк определено ()

- If Hist > (n - 3) \ dt + 1 Then ' коррекция истории

-    Hist = (n - 3) \ dt + 1 '

- End If

- Dim t As Integer, s As Integer

- For t = 0 To Hist - 1

-      s = n - t * dt - 1

-      p.D(Hist - t) = theRange.Offset(s, 0).Value

-      p.Opn(Hist - t) = theRange.Offset(s, 1).Value

-      p.Hgh(Hist - t) = theRange.Offset(s, 2).Value

-      p.Lw(Hist - t) = theRange.Offset(s, 3).Value

-      p.Cls(Hist - t) = theRange.Offset(s, 4).Value

-'     p.Vl(hist - t) = theRange.Offset(s, 5).Value

- Next t

-done:

-End Sub

-

-

-Function StrNum(aPoint As String)

-' возвращает число строк таблицы

- Dim theRange As Range

- Set theRange = ActiveSheet.Range(aPoint)

- StrNum = 0

- Do While IsEmpty(theRange.Offset(StrNum, 0).Value) = False

-     StrNum = StrNum + 1

- Loop

-End Function

-

-

-Sub ReadData2(aPoint As String, Hist As Integer, tE As Integer, _

-              p As PriceData)  ' ??? не протестирован

-'Инициализация типа PriceData из таблицы типа - 1

-'kопируются не более чем hist последних строк

-'последней строкой считается строка с номером tE

-'aPoint - начало таблицы

-'Прим. Первые две строки таблицы идентифицирует данные (строки)

-'Число строк таблицы  должно быть больше tE (!)

- Dim n As Integer, i As Integer

-'1 ОПРЕДЕЛЕНИЕ ЧИСЛА СТРОК ТАБЛИЦЫ - n

- Dim theRange As Range

- Set theRange = ActiveSheet.Range(aPoint)

- If tE - 2 < Hist Then ' коррекция истории

-    Hist = tE - 2

- End If

- Dim t As Integer, s As Integer

- For s = 1 To Hist

-      t = tE - Hist + s - 1

-      p.D(s) = theRange.Offset(t, 0).Value

-      p.Opn(s) = theRange.Offset(t, 1).Value

-      p.Hgh(s) = theRange.Offset(t, 2).Value

-      p.Lw(s) = theRange.Offset(t, 3).Value

-      p.Cls(s) = theRange.Offset(t, 4).Value

-      p.Vl(s) = theRange.Offset(t, 5).Value

- Next s

-done:

-End Sub

-

-

-

-<<<<<<
-======================
-mSignal
->>>>>>
-Attribute VB_Name = "mSignal"

-

-Option Explicit

-'Основной тип данных - стандарт 1

-Type PriceData

-    D() As String      ' календарная дата

-    Opn() As Double    ' Open

-    Hgh() As Double    ' High

-    Lw() As Double     ' Low

-    Cls() As Double    ' Close

-    Vl() As Integer    ' Volume

-    tC As Integer      ' Current time

-End Type

-

-Type Denmark

-   Res() As Double    'Resistance line

-   tRes() As Integer  'Resistance pivot points

-   nRes As Integer    'The number of resistance pivot points

-   AnglRes As Double  'Angle of Declination of Res

-   

-   Supp() As Double       'Support line

-   tSupp() As Integer     'Support pivot points

-   nSupp As Integer       'The number of support pivot points

-   

-   pSig     As Integer    ' parameter for Signal

-   Signal As Integer      'Signal

-   

-   AnglSupp As Double     ' Angle of Declination of Supp

-   Qual(1 To 3) As String ' qualificators

- 

-   nPj As Integer         ' номер проекции

-   Pj  As Double          ' проекция

-   

-End Type

-

-'*********************

-Dim P_PD As PriceData

-Dim P_DEN As Denmark

-'*********************

-Sub Denmark_Click()    'm

-  Dim nWin As Integer, theList As String, thePoint As String

-  

-  nWin = Range("C3").Value

-  theList = Range("C4").Value

-  thePoint = Range("C5").Value

-  P_DEN.nPj = Range("C6").Value

-  P_DEN.pSig = Range("C7").Value

-' 1. Очистка

-  Range("F4:H6").ClearContents ' таблица-1

-' Range("E9:G9").ClearContents ' таблица-2

-' Range("K4:K6").ClearContents ' таблица-3

-  Range("B12:G112").Clear         ' таблица - 4

-  Range("H12:I112").ClearContents ' таблица - 4

-' 2. Выделение памяти

-  InitPriceData p:=P_PD, tE:=nWin

-  InitDenmark p:=P_DEN, tE:=nWin

-' 3. Чтение данных по ценам

-  Worksheets(theList).Select

-  ReadData1 aPoint:=thePoint, Hist:=P_PD.tC, dt:=1, p:=P_PD

-

-' 5.определение элементов P_DEN

-  DetDenmark P_PD, P_DEN

-  If Abs(P_DEN.Signal) > 1 Then  'ценовые ориентиры, если есть сигнал

-      DetProj P_PD, P_DEN

-  End If

-' 6. Output

-  Output_1 "List1", "B11", P_PD, P_DEN

-  Table1 "List1", "F4", P_DEN

-  Table2 "List1", "E9", P_DEN, P_PD

-  Table3 "List1", "k4", P_DEN

-End Sub

-Sub Table1(ListName As String, aPoint As String, pDen As Denmark)

-' Col = 2 - не определен !!!

-  Worksheets(ListName).Select

-  Dim theRange As Range

-  Set theRange = ActiveSheet.Range(aPoint)  'Точка вывода осн. данных

-' Status - Col = 0

-  If pDen.nRes >= 2 Then

-     theRange.Offset(0, 0).Value = "O'KEY"

-  Else

-     theRange.Offset(0, 0).Value = "ND!"

-  End If

-  If pDen.nSupp >= 2 Then

-     theRange.Offset(1, 0).Value = "O'KEY"

-  Else

-     theRange.Offset(1, 0).Value = "ND!"

-  End If

-' -----------------------------------------

-' углы наклонов линии сопротивления и поддержки - Col = 1

-  If pDen.nRes >= 2 Then

-    theRange.Offset(0, 1).Value = pDen.AnglRes

-  End If

-  If pDen.nSupp >= 2 Then

-    theRange.Offset(1, 1).Value = pDen.AnglSupp

-  End If

-  If pDen.nRes >= 2 And pDen.nSupp >= 2 Then

-    theRange.Offset(2, 1).Value = (pDen.AnglRes + pDen.AnglSupp) / 2

-  End If

-End Sub

-Sub Table2(ListName As String, aPoint As String, _

-           pDen As Denmark, pPD As PriceData)

-  

-  Worksheets(ListName).Select

-  Dim theRange As Range

-  Set theRange = ActiveSheet.Range(aPoint)  'Точка вывода осн. данных

-  If pDen.Signal >= 2 Then

-     MsgBox _

-     "Внимание! Buy Signal: возможен прорыв вверх нисходящего тренда с уровнем значимости = " & P_DEN.Signal - 1 & " ! "

-     theRange.Offset(0, 0).Value = "Buy"

-     theRange.Offset(0, 1).Value = pPD.D(pPD.tC)

-     theRange.Offset(0, 2).Value = pDen.Signal - 1

-     theRange.Offset(0, 3).Value = pDen.Pj

-  End If

-  If pDen.Signal <= -2 Then

-     MsgBox _

-     "Внимание! Sell Signal: возможен прорыв вниз восходящего тренда с уровнем значимости = " & -(P_DEN.Signal + 1) & "!"

-     theRange.Offset(0, 0).Value = "Sell"

-     theRange.Offset(0, 1).Value = pPD.D(pPD.tC)

-     theRange.Offset(0, 2).Value = pDen.Signal + 1

-     theRange.Offset(0, 3).Value = pDen.Pj

-    End If

-   

-End Sub

-Sub Table3(ListName As String, aPoint As String, pDen As Denmark)

-  Worksheets(ListName).Select

-  Dim theRange As Range

-  Set theRange = ActiveSheet.Range(aPoint)  'Точка вывода осн. данных

-  Dim i As Integer

-  For i = 1 To 3

-     theRange.Offset(i - 1, 0).Value = pDen.Qual(i)

-  Next i

-End Sub

-

-

-Sub InitDenmark(p As Denmark, tE As Integer)

-'  Память под Denmark

-   ReDim p.Res(1 To tE)

-   ReDim p.tRes(1 To tE)

-   ReDim p.Supp(1 To tE)

-   ReDim p.tSupp(1 To tE)

-End Sub

-Sub Output_1(ListName As String, aPoint As String, _

-             pPD As PriceData, pDen As Denmark)

-' Вывод ценовых данных и акcесcуаров Денмарка ???

-' на рабочую страницу ListName по адресу aPoint

-  Worksheets(ListName).Select

-  Dim theRange As Range

-  Set theRange = ActiveSheet.Range(aPoint) 'Точка ввода осн. данных

-  theRange.Offset(0, 0).Value = "No"

-  theRange.Offset(0, 1).Value = "Date"

-  theRange.Offset(0, 2).Value = "Open"

-  theRange.Offset(0, 3).Value = "High"

-  theRange.Offset(0, 4).Value = "Low"

-  theRange.Offset(0, 5).Value = "Close"

-  theRange.Offset(0, 6).Value = "Res"

-  theRange.Offset(0, 7).Value = "Supp"

-  Dim t As Integer, k As Integer

-  Dim i As Integer, j As Integer

-  i = 1: j = 1

-  For t = 1 To pPD.tC

-      theRange.Offset(t, 0).Value = t

-      theRange.Offset(t, 1).Value = pPD.D(t)

-      theRange.Offset(t, 2).Value = pPD.Opn(t)

-      theRange.Offset(t, 3).Value = pPD.Hgh(t)

-      theRange.Offset(t, 4).Value = pPD.Lw(t)

-      theRange.Offset(t, 5).Value = pPD.Cls(t)

-      If t >= pDen.tRes(1) Then

-        theRange.Offset(t, 6).Value = pDen.Res(t)

-      End If

-     If t >= pDen.tSupp(1) Then

-        theRange.Offset(t, 7).Value = pDen.Supp(t)

-     End If

-     If t = pDen.tRes(i) Then   'temp

-        theRange.Offset(t, 3).Interior.ColorIndex = 4

-        i = i + 1

-     End If

-     If t = pDen.tSupp(j) Then  'temp

-        theRange.Offset(t, 4).Interior.ColorIndex = 8

-        j = j + 1

-     End If

- Next t

-End Sub

-

-'*****************************************

-Sub DetDenmark(pPD As PriceData, pDen As Denmark)

-' определение элементов данных Денмарка (в цифровой форме)

-' на текущий момент времени времени tC

-' ИСХОДНЫЕ ДАННЫЕ:

-' pPD  - окно, стандартная форма данных по ценам (определена)

-' РЕЗУЛЬТАТ:

-' pDen - элементы данных Денмарка (память выделена, pSig - определен):

-' линии Res,Supp их наклоны, опорные точки, сигналы к покупке или продаже

-' Signal = 0 сигнал отсутствует

-' Signal < 0 прорыв восходящего тренда (сигнал продажи)

-' Signal > 0 прорыв нисходящего тренда (сигнал покупки)

-' Если pDen.nRes < 2, то элементы Res не определяются

-' Если pDen.nSupp < 2, то элементы Supp не определяются

-

-' начальная установка

-  Dim i As Integer

-  pDen.Signal = 0

-  For i = 1 To 3

-     pDen.Qual(i) = "-"

-  Next i

-

-' определение линии поддержки и сопротивления

-  ResLine pPD.Hgh, pPD.tC, pDen.nRes, pDen.Res, pDen.tRes

-  SuppLine pPD.Lw, pPD.tC, pDen.nSupp, pDen.Supp, pDen.tSupp

-  If pDen.nRes >= 2 Then

-       pDen.AnglRes = 57.29578 * _

-       Atn(pDen.Res(pPD.tC) - pDen.Res(pPD.tC - 1))

-  End If

-  If pDen.nSupp >= 2 Then

-       pDen.AnglSupp = 57.29578 * _

-       Atn(pDen.Supp(pPD.tC) - pDen.Supp(pPD.tC - 1))

-  End If

-

-' ФОРМИРОВАНИЕ СИГНАЛА ----------------------------------

-  Dim t As Integer

-' 1. случай нисходящего тренда: Res определен и Res падает *************

-  If pDen.nRes >= 2 And pDen.AnglRes < 0 Then

-'    необходимое условие прорыва вверх

-     If pDen.Res(pPD.tC) < pPD.Cls(pPD.tC) Then

-        pDen.Signal = 1

-        For t = pPD.tC - pDen.pSig To pPD.tC - 1

-           If pPD.Cls(t) > pDen.Res(t) Then

-             pDen.Signal = 0

-             Exit For

-           End If

-        Next t

-     End If

-     If pDen.Signal = 1 Then

-'       Qualificator-1: close убывает накануне прорыва

-        If pPD.Cls(pPD.tC - 2) > pPD.Cls(pPD.tC - 1) Then

-           pDen.Signal = pDen.Signal + 1

-           pDen.Qual(1) = "*"

-        End If

-'       Qualificator-2: open > Res в момент прорыва

-        If pPD.Opn(pPD.tC) > pDen.Res(pPD.tC) Then

-            pDen.Signal = pDen.Signal + 1

-            pDen.Qual(2) = "*"

-        End If

-'       Qualificator-3 - demand value < Res(tC)

-        If 2 * pPD.Cls(pPD.tC - 1) - pPD.Lw(pPD.tC - 1) < pDen.Res(pPD.tC) Then

-           pDen.Signal = pDen.Signal + 1

-           pDen.Qual(3) = "*"

-        End If

-     End If

-  End If  ' нисходящий тренд обработан ************************************

-

-' 2. случай восходящего тренда: supp определен и supp растет

-  If pDen.nSupp >= 2 And pDen.AnglSupp > 0 Then

-'    ---------------------------------------------

-'    необходимое условие прорыва вниз

-     If pPD.Cls(pPD.tC) < pDen.Supp(pPD.tC) Then

-        pDen.Signal = -1

-        For t = pPD.tC - pDen.pSig To pPD.tC - 1

-           If pPD.Cls(t) < pDen.Supp(t) Then

-             pDen.Signal = 0

-             Exit For

-           End If

-        Next t

-     End If

-     If pDen.Signal = -1 Then

-'       Qualificator-1: Close растет накануне прорыва

-        If pPD.Cls(pPD.tC - 2) < pPD.Cls(pPD.tC - 1) Then

-           pDen.Signal = pDen.Signal - 1

-           pDen.Qual(1) = "*"

-        End If

-'       Qualificator-2: Open ниже Res в момент прорыва

-        If pPD.Opn(pPD.tC) < pDen.Supp(pPD.tC) Then

-           pDen.Signal = pDen.Signal - 1

-           pDen.Qual(2) = "*"

-        End If

-'       Qualificator-3 - supply value(t-1) > Supp(tC)

-        If 2 * pPD.Cls(pPD.tC - 1) - pPD.Hgh(pPD.tC - 1) > pDen.Supp(pPD.tC) Then

-           pDen.Signal = pDen.Signal - 1

-           pDen.Qual(3) = "*"

-        End If

-     End If

-'    ---------------------------------------------

-  End If

-End Sub

-Sub DetProj(pPD As PriceData, pDen As Denmark)

-'Определение проекции при наличии сигнала: |Signal| > 1

-'Услловие применимости |Signal| > 1 !!!

-Dim pM As Double, t As Integer, tM As Integer, tL As Integer

-

-If pDen.Signal >= 2 Then  ' СИГНАЛ ПОКУПКИ

-

-   tL = pDen.tRes(pDen.nRes)     ' tR determination

-   If tL = pPD.tC Then

-      tL = pDen.tRes(pDen.nRes - 1)

-   End If

-

-'  Projections 1,2 --------------------------------------------

-   If pDen.nPj >= 1 And pDen.nPj <= 2 Then

-'       t* = Arg min {L(t) : t R <= t  <= tb ,  L(t) < Res(t)},

-        tM = pPD.tC - 1

-        pM = pPD.Lw(tM) ' L(t-1) < Res(t-1) for t - break point !

-        For t = pPD.tC - 2 To tL Step -1

-          If pPD.Lw(t) < pM And pPD.Lw(t) < pDen.Res(t) Then

-             pM = pPD.Lw(t): tM = t

-          End If

-        Next t

-'       t* is defined

-        If pDen.nPj = 1 Then

- '       P1( tb) = Res(tb) + Res(t*) - L(t*)

-           pDen.Pj = pDen.Res(pPD.tC) + pDen.Res(tM) - pPD.Lw(tM)

-        Else

-           pDen.Pj = pDen.Res(pPD.tC) + pDen.Res(tM) - pPD.Cls(tM)

-        End If

-   End If

-   

-'  ----------------------------------------------------------------

-'  Projections 3

-   If pDen.nPj = 3 Then

-'      t*  = Arg min { С(t) : t R <= t  <= tb ,  C(t) < Res(t)}

-       tM = pPD.tC - 1

-       pM = pPD.Cls(tM)

-       For t = pPD.tC - 2 To tL Step -1

-          If pPD.Cls(t) < pM And pPD.Cls(t) < pDen.Res(t) Then

-             pM = pPD.Cls(t): tM = t

-          End If

-       Next t

-'      t* is defined

-       pDen.Pj = pDen.Res(pPD.tC) + pDen.Res(tM) - pPD.Cls(tM)

-   End If

-End If

-

-'-------------------------------------------------------------------

-'*******************************************************************

-' ПРОЕКЦИЯ ДЛЯ СИГНАЛА ПРОДАЖИ

-If pDen.Signal <= -2 Then

-   tL = pDen.tSupp(pDen.nSupp)  ' tR determination

-   If tL = pPD.tC Then

-      tL = pDen.tRes(pDen.nSupp - 1)

-   End If

-

-'  Projections 1,2 --------------------------------------------

-   If pDen.nPj = 1 Or pDen.nPj = 2 Then

-'       t* = Arg max {H(t) : t R <= t  <= tb ,  H(t) > Supp(t)},

-        tM = pPD.tC - 1

-        pM = pPD.Hgh(tM) ' H(t-1) > Supp(t-1) for t - break point !

-        For t = pPD.tC - 2 To tL Step -1

-          If pPD.Hgh(t) > pM And pPD.Hgh(t) > pDen.Supp(t) Then

-             pM = pPD.Hgh(t): tM = t

-          End If

-        Next t

-'       t* is defined

-        If pDen.nPj = 1 Then

- '         P1( tb) = Supp(tb) + Supp(t*) - H(t*)

-           pDen.Pj = pDen.Supp(pPD.tC) + pDen.Supp(tM) - pPD.Hgh(tM)

-        Else

-'          P2( tb) = Supp(tb) + Supp(t*) - C(t*)

-           pDen.Pj = pDen.Supp(pPD.tC) + pDen.Supp(tM) - pPD.Cls(tM)

-        End If

-   End If

-   

-'  ----------------------------------------------------------------

-'  Projections 3

-   If pDen.nPj = 3 Then

-'     t*  = Arg max { С(t) : t R <= t  <= tb ,  C(t) >  Supp(t)}

-'     P3( tb) = Supp(tb) + Supp(t*) - C(t*)

-      tM = pPD.tC - 1

-      pM = pPD.Cls(tM)

-      For t = pPD.tC - 2 To tL Step -1

-          If pM < pPD.Cls(t) And pPD.Cls(t) > pDen.Supp(t) Then

-             pM = pPD.Cls(t): tM = t

-          End If

-      Next t

-'      t* is defined

-      pDen.Pj = pDen.Supp(pPD.tC) + pDen.Supp(tM) - pPD.Cls(tM)

-   End If

-End If

-End Sub

-

-Sub ResLine(High() As Double, tE As Integer, nRes As Integer, _

-            Res() As Double, s() As Integer)

-' Определение линии сопротивления по Демарку [1]

-' Основной вариант

-' ИСХОДНЫЕ ДАННЫЕ:

-' High, dom(High) = [1, tE]

-' РЕЗУЛЬТАТ:

-' 1) линия сопротивления Res, dom(Res)=[s(1), tE], и

-' 2) s = {s(1), s(2), ..., s(nRes)}, s(1) < s(2) < ...< s(nRes)

-'   ( s(nRes)<= tE )- опорные точки

-' 3) число опорных точек nRes.

-' 4) s(1) -  первый момент времени с которого определена Supp

-'    то есть dom{Supp} = [s(1), tC]

-' Прим. Если число опорных точек окажется < 2, то линия

-' сопротивления не определяется. В этом случае следует

-' увеличить историю tE !!!

- Dim t As Integer, i As Integer

- Dim v As Double

-'1 определение опорных моментов времени

- nRes = 0

- For t = 2 To tE - 1

- '   v = max{high(t-1), high(t+1)} < high(t)

-     v = High(t - 1)

-     If v < High(t + 1) Then

-        v = High(t + 1)

-     End If

-     If High(t) > v Then    'alt.: v >= High(t + 1)

-        s(nRes + 1) = t: nRes = nRes + 1

-     End If

- Next t

- If nRes < 2 Then

-    GoTo done

- End If

-' 2 определение линии сопротивления

- Res(s(1)) = High(s(1))

- For i = 2 To nRes

-    Res(s(i)) = High(s(i))

-    v = (High(s(i)) - High(s(i - 1))) / (s(i) - s(i - 1))

-    For t = s(i - 1) + 1 To s(i) - 1

-        Res(t) = High(s(i - 1)) + v * (t - s(i - 1))

-    Next t

- Next i

- If s(nRes) < tE Then

-    v = (High(s(nRes)) - High(s(nRes - 1))) / (s(nRes) - s(nRes - 1))

-    For t = s(nRes) + 1 To tE

-        Res(t) = High(s(nRes - 1)) + v * (t - s(nRes - 1))

-    Next t

- End If

-done:

-End Sub

-

-Sub SuppLine(Low() As Double, tE As Integer, nSupp As Integer, _

-               Supp() As Double, s() As Integer)

-' Определение линии поддержки по Демарку [1] (от конца)

-' Исходные данные:

-' Low, dom(Low) = [1, tE]

-' Результат:

-' 1) линия сопротивления Supp, dom(Supp)=[s(1), tE],

-' 2) s = {s(1), s(2), ..., s(nSupp)}, s(1) < s(2) < ...< s(nSupp) -

-'    опорные точки

-' 3) число опорных точек nSupp.

-' Прим. Если фактическое число опорных точек окажется < 2, то линия

-' поддержки не определяется.

- Dim t As Integer, i As Integer

- Dim v As Double

-'1 определение опорных моментов времени

- nSupp = 0

- For t = 2 To tE - 1

-'     v = min{Low(t-1), Low(t+1)} > Low(t)

-      v = Low(t - 1)

-      If v > Low(t + 1) Then

-         v = Low(t + 1)

-      End If

-      If Low(t) < v Then    'alt.: v >= High(t + 1)

-         s(nSupp + 1) = t: nSupp = nSupp + 1

-      End If

- Next t

- If nSupp < 2 Then

-    GoTo done

- End If

-' 2 определение линии поддержки

- Supp(s(1)) = Low(s(1))

- For i = 2 To nSupp

-    Supp(s(i)) = Low(s(i))

-    v = (Low(s(i)) - Low(s(i - 1))) / (s(i) - s(i - 1))

-    For t = s(i - 1) + 1 To s(i) - 1

-        Supp(t) = Low(s(i - 1)) + v * (t - s(i - 1))

-    Next t

- Next i

- If s(1) < tE Then

-    v = (Low(s(nSupp)) - Low(s(nSupp - 1))) / (s(nSupp) - s(nSupp - 1))

-    For t = s(nSupp) + 1 To tE

-        Supp(t) = Low(s(nSupp - 1)) + v * (t - s(nSupp - 1))

-    Next t

- End If

-done:

-End Sub

-

-Sub InitPriceData(p As PriceData, tE As Integer)

-' Инициализация данных по ценам

-  p.tC = tE

-  ReDim p.D(1 To tE)

-  ReDim p.Opn(1 To tE)

-  ReDim p.Hgh(1 To tE)

-  ReDim p.Lw(1 To tE)

-  ReDim p.Cls(1 To tE)

-  ReDim p.Vl(1 To tE)

-End Sub

-

-

-

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mTester1
->>>>>>
-Attribute VB_Name = "mTester1"

-Option Explicit

-Dim HISTORY As PriceData

-

-Sub Test1Denmark_Click()

-  

-  Dim nWin As Integer, nHist As Integer, _

-      theList As String, thePoint As String, _

-      Shift As Integer, pDen As Integer, pEMA As Integer

-' чтение данных-------------------------------

-  theList = Range("C4").Value     'Данные

-  thePoint = Range("C5").Value    'Начало

-  nHist = Range("C6").Value       'История

-  nWin = Range("C7").Value        'Окно

-  pEMA = Range("C8").Value        'порядок ск. среденего

-  Shift = Range("C9").Value       'смещение > 0

-  pDen = Range("C10").Value       'параметр Den

-' --------------------------------------------

-  Range("B16:H366").ClearContents

-

-' Определение элементов истории

-  InitPriceData p:=HISTORY, tE:=nHist   ' память под HISTORY

-  Worksheets(theList).Select            ' выбор листа с данными

-  ReadData1 aPoint:=thePoint, Hist:=HISTORY.tC, dt:=1, p:=HISTORY

-' Определены элементы истории цен  HISTORY

-  

-  Worksheets("Testing").Select

-  Dim Win As PriceData, Den As Denmark

-  InitPriceData Win, nWin  ' память под окно

-  InitDenmark Den, nWin    ' память под Den размер(Den) = размер(Win)

-  Den.pSig = pDen

-  

-  

-  Dim theRange As Range

-  Set theRange = ActiveSheet.Range("B16")  'Точка вывода осн. данных

-  

-  Dim t As Integer, i As Integer

-  Dim Sig As Integer, nSucc As Integer, nFall As Integer, Num As Integer

-  ReDim mov(1 To HISTORY.tC) As Double

-  Num = 0: nSucc = 0: nFall = 0

-  ExpMA1 HISTORY.Cls, 1, HISTORY.tC, 2 / (pEMA + 1), mov ' moving averige

-  

-  For t = Win.tC To HISTORY.tC - Shift   ' nWin  <= t <= P_DEN.tC

-'     Определение сигнала на момент t  по окну Win

-      Sig = DenSignal(t, Win, HISTORY, Den)

-      If Sig <> 0 Then

-         If Sig * Sign((mov(t + Shift) - mov(t))) >= 0 Then

-               nSucc = nSucc + 1

-         Else

-               nFall = nFall + 1

-         End If

-         Num = Num + 1

-      End If

-      theRange.Offset(t - nWin, 0).Value = t

-      theRange.Offset(t - nWin, 1).Value = HISTORY.D(t)

-      theRange.Offset(t - nWin, 2).Value = HISTORY.Opn(t)

-      theRange.Offset(t - nWin, 3).Value = HISTORY.Hgh(t)

-      theRange.Offset(t - nWin, 4).Value = HISTORY.Lw(t)

-      theRange.Offset(t - nWin, 5).Value = HISTORY.Cls(t)

-      If Sig <> 0 Then

-         theRange.Offset(t - nWin, 6).Value = Sig

-      End If

-  Next t

-  

-  Set theRange = ActiveSheet.Range("F4")  'Точка вывода осн. данных

-  theRange.Offset(0, 0).Value = Num

-  theRange.Offset(0, 1).Value = nSucc

-  theRange.Offset(0, 2).Value = nFall

-  theRange.Offset(0, 3).Value = nSucc / Num

-  

-  

-End Sub

-

-Function DenSignal(t As Integer, _

-                   Win As PriceData, _

-                   Hist As PriceData, _

-                   Den As Denmark) As Integer

-                   

-' Сигнал к покупке или продаже по Денмарку

-' исходные данные:

-' 1. t - момент времени, на который определяется сигнал

-'    win.tC <= t <= Hist.tC

-' 2. win.tC -размер временного окна, по которому определяются  линии Денмарка

-'    память под окно выделена.

-' 3. Hist - история, элементы истории полностью определены.

-' 4. Den.pSig - параметр сигнала, память для Den выделена

-' Результат:

-' DenSignal >= 1 -  сигнал к покупке ~ ожидается повышение

-' DenSignal =  0 -  сигнала нет

-' DenSignal <= -1 - сигнал к продаже ~ ожидается понижение

-' * Абсолютное значение DenSignal = числу реализованных квалификаторов

-

-' Определение окна

-  Dim i As Integer

-  For i = 1 To Win.tC

-      Win.D(i) = Hist.D(t - Win.tC + i)

-      Win.Cls(i) = Hist.Cls(t - Win.tC + i)

-      Win.Opn(i) = Hist.Opn(t - Win.tC + i)

-      Win.Hgh(i) = Hist.Hgh(t - Win.tC + i)

-      Win.Lw(i) = Hist.Lw(t - Win.tC + i)

-  Next i

-  DetDenmark Win, Den  'элементы Денмарка определены для t

-  If Den.Signal > 1 Then

-     DenSignal = Den.Signal - 1

-  End If

-  If Den.Signal < -1 Then

-     DenSignal = Den.Signal + 1

-  End If

-End Function

-

-Function Sign(x As Double) As Integer

-    Sign = 0

-    If x > 0 Then

-       Sign = 1

-    ElseIf x < 0 Then

-       Sign = -1

-    End If

-End Function

-

-' Экспоненциальное скользящее среднее

-Sub ExpMA1(x() As Double, t1 As Integer, t2 As Integer, alfa As Double, _

-           s() As Double)

-    ' x , dom(x) = [t1,t2], - исходный ряд

-    ' 0 <= alfa <= 1 - порядок сглаживания

-    ' alfa = 2/(nWin+1)

-    ' alfa <= 0 --> s = 0; alfa => 1 s = x

-    ' Результат: S , dom(S) = [t1,t2], - скользящее среднее

-    Dim S0 As Double, beta As Double

-    Dim k As Integer, t As Integer

-    ' S0 determination

-    If alfa <= 0 Then

-       For t = t1 To t2

-          s(t) = 0

-       Next t

-       GoTo done

-    End If

-    If alfa >= 1 Then

-       For t = t1 To t2

-          s(t) = x(t)

-       Next t

-       GoTo done

-    End If

-    S0 = 0

-    k = 5    ' порядок усреднения, k < (t2-t1+1)/2  !!!

-    For t = t1 To t1 + k - 1

-        S0 = S0 + x(t)

-    Next t

-    S0 = S0 / k

-    'main cycle

-    beta = 1 - alfa

-    s(t1) = alfa * x(t1) + beta * S0

-    For t = t1 + 1 To t2

-        s(t) = alfa * x(t) + beta * s(t - 1)

-    Next t

-done:

-End Sub

-

-

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'Denmark_method'
-Quirk - duff tag length======================
-MGetWebData
->>>>>>
-Attribute VB_Name = "MGetWebData"

-Option Explicit

-

-Const QueryDataName As String = "ExternalDenmarkData"

-

-Sub UpdateHistory()

-    Dim DestRangeName As String

-    Dim ResultLength As Integer

-    Dim QryPathStr As String

-    Dim Location As Range

-    Dim denWindow As Integer

-    With ThisWorkbook

-        .Activate

-        With .Worksheets(VAR_SHEET)

-            DestRangeName = .Range("DEN_SYMBOL")

-            denWindow = .Range("DEN_WINDOW") + 2

-        End With

-        With .Worksheets(RAW_DATA_SHEET)

-            .Range(PRICE_TABLE) = DestRangeName

-            'Clear table

-            .Range(.Cells(RAW_DATA_RANGE_ROW - 1, RAW_DATA_RANGE_COL), .Cells(65535, RAW_DATA_RANGE_COL + PROJECT_IDX)).ClearContents

-            QryPathStr = GetQryPath

-            Set Location = .Range(RAW_DATA_RANGE).Offset(-1, 0)

-            If Not QryExist(Location, QueryDataName) Then

-                QryCreate Location, QueryDataName, QryPathStr

-            Else

-                QryRefresh Location, QueryDataName, QryPathStr

-            End If

-            With Location.Worksheet.QueryTables(QueryDataName)

-                DestRangeName = .ResultRange.Name.RefersTo

-                ResultLength = .ResultRange.count

-            End With

-    

-    '        .Parent.Application.DisplayAlerts = False

-            

-            .Range(DestRangeName).TextToColumns _

-                Destination:=.Range(DestRangeName), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=True, _

-                Semicolon:=False, _

-                Comma:=True, _

-                Space:=False, _

-                Other:=False, _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 1), _

-                                Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1))

-            

-    '        .Parent.Application.DisplayAlerts = True

-            Dim i, j, row_idx As Integer

-            Dim CurrentDate As String

-            Dim RawData As Range

-            Set RawData = .Range(RAW_DATA_RANGE)

-            row_idx = 0

-            With RawData

-                CurrentDate = .Value

-                For i = 1 To ResultLength

-                    If CurrentDate = .Offset(i, DATE_IDX).Value Then

-                        ' skip virtual prices

-                        If (.Offset(i, VOLUME_IDX) > MIN_PRICE_VALUE) Then

-                            If .Offset(row_idx, HIGH_IDX).Value < .Offset(i, HIGH_IDX).Value Then

-                                .Offset(row_idx, HIGH_IDX).Value = .Offset(i, HIGH_IDX).Value

-                            End If

-                            If .Offset(row_idx, LOW_IDX).Value > .Offset(i, LOW_IDX).Value Then

-                                .Offset(row_idx, LOW_IDX).Value = .Offset(i, LOW_IDX).Value

-                            End If

-                            .Offset(row_idx, VOLUME_IDX).Value = _

-                                .Offset(row_idx, VOLUME_IDX).Value + .Offset(i, VOLUME_IDX).Value

-                            .Offset(row_idx, TIME_IDX).Value = .Offset(i, TIME_IDX).Value

-                            .Offset(row_idx, CLOSE_IDX).Value = .Offset(i, CLOSE_IDX).Value

-                        End If

-                    Else

-                        ' skip virtual prices

-                        If (.Offset(row_idx, VOLUME_IDX) > MIN_PRICE_VALUE) Then

-                            row_idx = row_idx + 1

-                        End If

-                        For j = DATE_IDX To VOLUME_IDX

-                            .Offset(row_idx, j) = .Offset(i, j)

-                        Next j

-                        CurrentDate = .Offset(i, DATE_IDX)

-                    End If

-                Next i

-            End With ' RawData

-            ' Clear unused Cells

-            .Range(.Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_IDX), .Cells(65536, RAW_DATA_RANGE_COL + PROJECT_IDX)).ClearContents

-            If row_idx > denWindow Then

-                row_idx = row_idx - denWindow

-                .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-                ).delete xlShiftUp

-            End If

-        End With ' .Worksheets(RAW_DATA_SHEET)

-    End With ' thisWorkbook

-End Sub

-

-Private Function GetQryPath() As String

-    Dim QryPathStr As String

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        QryPathStr = "URL;http://online.rbc.ru/cgi-bin/online/nph-single.cgi?"

-        QryPathStr = QryPathStr & "ticker=" & .Range("DEN_SYMBOL")

-        QryPathStr = QryPathStr & "&source=" & .Range("DEN_SOURCE")

-        QryPathStr = QryPathStr & "&board=" & .Range("DEN_BOARD")

-        QryPathStr = QryPathStr & "&period=60&oh=11&ch=18&separator=%2C&vmode=Ignore&vtype=BA2&format=Excel"

-        QryPathStr = QryPathStr & "&daysback=" & .Range("DEN_HISTORY")

-'        .Range("LAST_HIST_QRY") = QryPathStr

-    End With

-    GetQryPath = QryPathStr

-    

-End Function

-

-Sub UpdateTickerList()

-    Dim Idx, n As Integer

-    Dim ResultLength As Integer

-    Dim Location As Range

-    Dim QryPathStr As String

-    Dim QueryDataName As String

-    Dim DestRangeArea As String

-    

-    With ThisWorkbook

-        With .Worksheets(VAR_SHEET)

-            Idx = .Range("IDX_DEN_LIST")

-            Set Location = .Range("TICKER_TABLES").Offset(0, (Idx - 1) * 2)

-             .Range("IDX_DEN_SYMBOL") = 1

-            QueryDataName = Location.Offset(0, 0)

-            'Clear table

-            .Range(Location.Offset(1, 0), Location.Offset(65535 - Location.Row, 1)).ClearContents

-            

-            QryPathStr = GetListPath

-            If Not QryExist(Location.Offset(1, 0), QueryDataName) Then

-                QryCreate Location.Offset(1, 0), QueryDataName, QryPathStr

-            Else

-                QryRefresh Location.Offset(1, 0), QueryDataName, QryPathStr

-            End If

-            ' Remove header

-            ' Find [DATA]

-            n = 0

-            Do While Location.Offset(n, 0) <> "[DATA]"

-                n = n + 1

-            Loop

-            .Range(Location.Offset(1, 0), Location.Offset(n, 1)).delete Shift:=xlUp

-            With .QueryTables(QueryDataName)

-                DestRangeArea = .ResultRange.Name.RefersTo

-                ResultLength = .ResultRange.count

-            End With

-        

-        '        .Parent.Application.DisplayAlerts = False

-                

-            .Range(DestRangeArea).TextToColumns _

-                Destination:=.Range(DestRangeArea), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=True, _

-                Semicolon:=True, _

-                Comma:=True, _

-                Space:=False, _

-                Other:=False, _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 9))

-        ' Sort Data

-            Set Location = .Range(.Range(DestRangeArea).Offset(0, 0), .Range(DestRangeArea).Offset(ResultLength - 1, 1))

-            Location.Sort _

-                Key1:=.Range(DestRangeArea).Offset(0, 0), _

-                Order1:=xlAscending, _

-                Header:=xlNo, _

-                OrderCustom:=1, _

-                MatchCase:=False, _

-                Orientation:=xlTopToBottom

-        End With

-        ' Setup Ticker List

-         With .Worksheets(VAR_SHEET)

-            DestRangeArea = .Name & "!" & .Range(.Range(DestRangeArea).Cells(1, 1), .Range(DestRangeArea).Cells(ResultLength - 1, 1)).Address

-         End With

-        .Worksheets(FORM_SHEET) _

-            .Shapes("cbxTikers").ControlFormat.ListFillRange = DestRangeArea

-    End With

-End Sub

-

-Private Function GetListPath() As String

-    Dim QryPathStr As String

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        QryPathStr = "URL;http://online.rbc.ru/~anton/databuilder/secure/names.cgi?"

-        QryPathStr = QryPathStr & "&source=" & .Range("DEN_SOURCE")

-        QryPathStr = QryPathStr & "&board=" & .Range("DEN_BOARD")

-        QryPathStr = QryPathStr & "&category=STOCKS"

-        '.Range("LAST_DIR_QRY") = QryPathStr

-    End With

-    GetListPath = QryPathStr

-End Function

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    Set MyAppEvents.app = Application

-    Dim wbname As String

-    Application.ScreenUpdating = False

-    If Application.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        Shell "EXCEL " & wbname

-        ThisWorkbook.Close Savechanges:=False

-        Exit Sub

-    End If

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False

-    cmSetStandaloneMode

-    AppRunEnable.EnableRun (ESTIMATION_DATE)

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment wb:=ThisWorkbook, DesignMode:=False

-        If ThisWorkbook.Saved = False Then

-            ThisWorkbook.Save

-        End If

-    End If

-    Application.Caption = Empty

-    Application.CommandBars("Worksheet Menu Bar").Reset

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-        Dim MaxX, MaxY As Integer

-        With ThisWorkbook.Worksheets(FORM_SHEET)

-            MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-            MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-        End With

-

-        With ThisWorkbook.Application

-            .ScreenUpdating = False

-            .WindowState = xlNormal

-            .Height = MaxY

-            .Width = MaxX

-        End With

-End Sub

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mReadWrie
->>>>>>
-Attribute VB_Name = "mReadWrie"

-Option Explicit

-

-Public Const GOOD_LINE_STATUS As String = "Ok"

-Public Const BAD_LINE_STATUS As String = "N/A"

-

-Function ReadWebData(Location As Range, Hist As Integer, dt As Integer, _

-              pPriceData As TPriceData) As Integer

-    'Инициализация типа TPriceData из таблицы типа - 1

-    'kопируются не более чем hist последних строк

-    'aPoint - начало таблицы

-    'первые две строки таблицы идентифицирует данные (строки)

-    Dim n, i As Integer

-    

-    'Определение числа строк таблицы - n

-    n = GetLinesCount(Location)

-    ReadWebData = n

-    If n < 9 Then             'обработать ошибку !!!

-        GoTo done

-    End If

-    ' число строк определено ()

-    If Hist > (n - 3) \ dt + 1 Then ' коррекция истории

-        Hist = (n - 3) \ dt + 1 '

-    End If

-    Dim t, s As Integer

-    For t = 0 To Hist - 1

-        s = n - t * dt - 1

-        pPriceData.D(Hist - t) = Location.Offset(s, DATE_IDX).Value

-        pPriceData.Tm(Hist - t) = Location.Offset(s, TIME_IDX).Value

-        pPriceData.Opn(Hist - t) = Location.Offset(s, OPEN_IDX).Value

-        pPriceData.Hgh(Hist - t) = Location.Offset(s, HIGH_IDX).Value

-        pPriceData.Lw(Hist - t) = Location.Offset(s, LOW_IDX).Value

-        pPriceData.Cls(Hist - t) = Location.Offset(s, CLOSE_IDX).Value

-        pPriceData.Vl(Hist - t) = Location.Offset(s, VOLUME_IDX).Value

-    Next t

-    ReadWebData = t + 1

-done:

-End Function

-

-Sub ResultLinesOut(Location As Range, pPD As TPriceData, pDen As TDenmark)

-    Dim n As Integer

-    

-    n = GetLinesCount(Location)

-    With Location

-        .Offset(-1, RESIST_IDX) = "Res"

-        .Offset(-1, SUPPORT_IDX) = "Supp"

-        .Offset(-1, PROJECT_IDX) = "Project"

-    End With

-    Dim t, count, Idx, loc_idx As Integer

-    count = pPD.tC

-    For t = 0 To count - 1

-        Idx = count - t

-        loc_idx = n - t - 1

-        If pDen.res(Idx) > MIN_PRICE_VALUE Then

-            Location.Offset(loc_idx, RESIST_IDX).Value = pDen.res(Idx)

-        End If

-        If pDen.Supp(Idx) > MIN_PRICE_VALUE Then

-            Location.Offset(loc_idx, SUPPORT_IDX).Value = pDen.Supp(Idx)

-        End If

-        If Abs(pDen.Signal) > 1 Then

-            Location.Offset(loc_idx, PROJECT_IDX).Value = pDen.Pj

-        End If

-    Next t

-End Sub

-

-Sub Out_Table_1(TheRange As Range, pDen As TDenmark, LastIdx As Integer)

-    

-    

-    ' Col = 2 - не определен !!!

-    ' Status - Col = 0

-    If pDen.nRes >= 2 Then

-        TheRange.Offset(0, 0).Value = GOOD_LINE_STATUS

-    Else

-        TheRange.Offset(0, 0).Value = BAD_LINE_STATUS

-    End If

-    If pDen.nSupp >= 2 Then

-        TheRange.Offset(1, 0).Value = GOOD_LINE_STATUS

-    Else

-        TheRange.Offset(1, 0).Value = BAD_LINE_STATUS

-    End If

-    ' -----------------------------------------

-    ' углы наклонов линии сопротивления и поддержки - Col = 1

-    If pDen.nRes >= 2 Then

-        TheRange.Offset(0, 1).Value = pDen.AnglRes

-    End If

-    If pDen.nSupp >= 2 Then

-        TheRange.Offset(1, 1).Value = pDen.AnglSupp

-    End If

-    If pDen.nRes >= 2 And pDen.nSupp >= 2 Then

-        TheRange.Offset(2, 1).Value = (pDen.AnglRes + pDen.AnglSupp) / 2

-    End If

-    ' -----------------------------------------

-    ' Опорные цены линий денмарка на текущий момент

-    If pDen.nRes >= 2 Then

-        TheRange.Offset(0, 2).Value = pDen.res(LastIdx)

-    End If

-    If pDen.nSupp >= 2 Then

-        TheRange.Offset(1, 2).Value = pDen.Supp(LastIdx)

-    End If

-    If pDen.nRes >= 2 And pDen.nSupp >= 2 Then

-        TheRange.Offset(2, 2).Value = _

-            (pDen.res(LastIdx) + pDen.Supp(LastIdx)) / 2

-    End If

-    

-End Sub

-

-Sub Out_Table_2(TheRange As Range, pPD As TPriceData, pDen As TDenmark)

-    Dim signal_defined, allert_enable  As Boolean

-    Dim Message As String

-    signal_defined = False

-    allert_enable = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_ALLERT_DLG")

-    Message = "Сигнал об изменении тренда не идентифицирован."

-    If pDen.Signal >= 2 Then

-        signal_defined = True

-        TheRange.Offset(0, 0).Value = "BUY"

-        TheRange.Offset(0, 1).Value = pPD.D(pPD.tC)

-        TheRange.Offset(0, 2).Value = pDen.Signal - 1

-        TheRange.Offset(0, 3).Value = pDen.Pj

-        Message = "BUY Signal: возможен прорыв вверх нисходящего тренда с уровнем значимости = " & pDen.Signal - 1 & " ! "

-    End If

-    If pDen.Signal <= -2 Then

-        signal_defined = True

-        TheRange.Offset(0, 0).Value = "SELL"

-        TheRange.Offset(0, 1).Value = pPD.D(pPD.tC)

-        TheRange.Offset(0, 2).Value = pDen.Signal + 1

-        TheRange.Offset(0, 3).Value = pDen.Pj

-        Message = "SELL Signal: возможен прорыв вниз восходящего тренда с уровнем значимости = " & -(pDen.Signal + 1) & "!"

-    End If

-    With ThisWorkbook.Worksheets(FORM_SHEET).Range("TABLE_COMMENT")

-        .Value = Message

-        .Font.Bold = True

-        Dim color_idx As Integer

-        If signal_defined Then

-            If pDen.Signal < 0 Then

-                .Font.ColorIndex = 3

-            Else

-                .Font.ColorIndex = 5

-            End If

-        Else

-            .Font.ColorIndex = 14

-        End If

-    End With

-    If allert_enable And signal_defined Then

-        MsgBox _

-            Prompt:=Message, _

-            Title:=PROGRAM_NAME, _

-            Buttons:=vbOKOnly + vbInformation

-    End If

-End Sub

-

-Sub Out_Table_3(TheRange As Range, pDen As TDenmark)

-    Dim i As Integer

-    For i = 1 To 3

-        TheRange.Offset(i - 1, 0).Value = pDen.Qual(i)

-    Next i

-End Sub

-

-Sub Out_Table_4(TheRange As Range, pPD As TPriceData)

-    Dim LastIdx As Integer

-    LastIdx = pPD.tC

-    With TheRange

-        .Offset(0, 0) = pPD.D(LastIdx)

-        .Offset(0, 1) = pPD.Tm(LastIdx)

-        .Offset(0, 2) = pPD.Opn(LastIdx)

-        .Offset(0, 3) = pPD.Hgh(LastIdx)

-        .Offset(0, 4) = pPD.Lw(LastIdx)

-        .Offset(0, 5) = pPD.Cls(LastIdx)

-        .Offset(0, 6) = pPD.Cls(LastIdx) - pPD.Cls(LastIdx - 1)

-    End With

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Denmark method bar"

-Const common_pwd = "31415926"

-

-

-Sub SetEnvironment(wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    With Application

-        .Caption = PROGRAM_NAME

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .GetState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-    End With

-    With wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(FORM_SHEET).Select

-    End With

-    CreateCommandBar theApp:=wb.Application

-End Sub

-

-Sub RestoreEnvironment(wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Application.ScreenUpdating = False

-    With wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                     cWindow.DisplayHeadings = True

-                Next

-            End If

-        Next

-        .Worksheets(FORM_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu (True)

-        End If

-        With mobjAppState

-            .RestoreState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(wb As Workbook)

-    With wb

-        .Application.ScreenUpdating = False

-        

-        With .Worksheets(RAW_DATA_SHEET)

-            .Visible = xlVeryHidden

-            .Protect Password:=common_pwd, userInterfaceOnly:=True, Contents:=False

-        End With

-        With .Worksheets(VAR_SHEET)

-            .Visible = xlVeryHidden

-            .Protect Password:=common_pwd, userInterfaceOnly:=True, Contents:=False

-        End With

-        With .Worksheets(FORM_SHEET)

-            .EnableSelection = xlNoSelection

-            .Protect userInterfaceOnly:=True

-            .Select

-        End With

-        With .Worksheets(CHART_SHEET)

-            .EnableSelection = xlNoSelection

-            .Protect userInterfaceOnly:=True

-        End With

-        .Protect Windows:=True

-        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(wb As Workbook)

-    With wb

-        .Unprotect

-        .Application.ScreenUpdating = False

-        With .Worksheets(RAW_DATA_SHEET)

-            .Visible = xlVeryHidden

-            .Unprotect Password:=common_pwd

-        End With

-        With .Worksheets(VAR_SHEET)

-            .Visible = xlVeryHidden

-            .Unprotect Password:=common_pwd

-        End With

-        With .Worksheets(CHART_SHEET)

-            .Select

-            .Unprotect

-        End With

-        With .Worksheets(FORM_SHEET)

-            .Select

-            .Unprotect

-        End With

-        .Application.ScreenUpdating = True

-        

-    End With

-End Sub

-

-<<<<<<
-======================
-mTypes
->>>>>>
-Attribute VB_Name = "mTypes"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Метод господина Денмарка"

-Public Const PROGRAM_VERSION As String = "version 1.0"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-

-Public Const ESTIMATION_DATE As Long = 19980915

-'Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "J27"

-

-Public Const RAW_DATA_SHEET As String = "Raw_data"

-Public Const PRICE_TABLE As String = "A1"

-Public Const RAW_DATA_RANGE As String = "A3"

-Public Const RAW_DATA_RANGE_COL As Integer = 1

-Public Const RAW_DATA_RANGE_ROW As Integer = 3

-

-Public Const VAR_SHEET As String = "Var_s"

-

-Public Const CHART_SHEET As String = "Chart"

-

-Public Const MIN_PRICE_VALUE As Double = 0.000001

-Public Const MAX_PRICE_VALUE As Double = 1000000000

-

-' Fields indexes in RAW_DATA_RANGE

-Public Const DATE_IDX As Integer = 0

-Public Const TIME_IDX As Integer = 1

-Public Const OPEN_IDX As Integer = 2

-Public Const CLOSE_IDX As Integer = 3

-Public Const LOW_IDX As Integer = 4

-Public Const HIGH_IDX As Integer = 5

-Public Const VOLUME_IDX As Integer = 6

-Public Const RESIST_IDX As Integer = 7

-Public Const SUPPORT_IDX As Integer = 8

-Public Const PROJECT_IDX As Integer = 9

-

-Type TPriceData

-    D() As String      ' календарная дата

-    Tm() As String     ' время

-    Opn() As Double    ' Open

-    Hgh() As Double    ' High

-    Lw() As Double     ' Low

-    Cls() As Double    ' Close

-    Vl() As Double     ' Volume

-    tC As Integer      ' Current time

-End Type

-

-Type TDenmark

-   res() As Double          'Resistance line

-   tRes() As Integer        'Resistance pivot points

-   nRes As Integer          'The number of resistance pivot points

-   AnglRes As Double        'Angle of Declination of Res

-   

-   Supp() As Double         'Support line

-   tSupp() As Integer       'Support pivot points

-   nSupp As Integer         'The number of support pivot points

-   

-   pSig     As Integer      ' parameter for Signal

-   Signal As Integer        'Signal

-   

-   AnglSupp As Double       ' Angle of Declination of Supp

-   Qual(1 To 3) As String   ' qualificators

- 

-   nPj As Integer           ' номер проекции

-   Pj  As Double            ' проекция цены

-   

-End Type

-

-

-<<<<<<
-======================
-mCommands
->>>>>>
-Attribute VB_Name = "mCommands"

-Option Explicit

-Dim AppRunEnable As New cEnableRun

-

-Sub evHistory_Change()

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("BOOL_DATA_READY") = False

-    End With

-End Sub

-

-Sub evSubmit_Click()

-    Dim ticker As String

-    AppRunEnable.EnableRun (ESTIMATION_DATE)

-    Application.Cursor = xlWait

-    With ThisWorkbook

-        With .Worksheets(VAR_SHEET)

-            ticker = .Range("DEN_SYMBOL")

-            If .Range("BOOL_DATA_DOWNLOAD") = True Or .Range("BOOL_DATA_READY") = False Then

-                UpdateHistory

-                .Range("BOOL_DATA_READY") = True

-            End If

-        End With

-        If TDenmark_Calc Then

-            With .Worksheets(FORM_SHEET)

-                .Range("CALC_TICKER_NAME") = ticker

-            End With

-        End If

-    End With

-    Application.Cursor = xlDefault

-    

-End Sub

-

-

-Sub evParamChange()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DENMARK_READY") = False

-End Sub

-

-Sub evGroupChange()

-    Dim GroupIdx, LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange As String

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        GroupIdx = .Range("IDX_DEN_LIST")

-        .Range("IDX_DEN_SYMBOL") = 1

-        NewRangeOffsetCol = (GroupIdx - 1) * 2

-        LinesCount = GetLinesCount(.Range("TICKER_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .Name & "!" & .Range(.Range("TICKER_TABLES").Offset(1, NewRangeOffsetCol), .Range("TICKER_TABLES").Offset(LinesCount, NewRangeOffsetCol)).Address

-        ThisWorkbook.Worksheets(FORM_SHEET).Shapes("cbxTikers").ControlFormat.ListFillRange = NewCbxRange

-    End With

-    evHistory_Change

-End Sub

-

-Sub evUpdateTickerList()

-    UpdateTickerList

-    evHistory_Change

-End Sub

-

-Sub cmViewChart()

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        If .Range("BOOL_DENMARK_READY") <> True Then

-            If .Range("BOOL_AUTORECALC") = True Then

-                evSubmit_Click

-                If .Range("BOOL_DENMARK_READY") <> True Then

-                    Exit Sub

-                End If

-            Else

-                MsgBox _

-                    "График не может быть построен." & vbCrLf & "Исходные данные не обработаны.", _

-                    vbOKOnly + vbExclamation

-                Exit Sub

-            End If

-        End If

-    End With

-    With ThisWorkbook.Worksheets(FORM_SHEET)

-        With .Range("TABLE_1")

-            Dim test_lines As Boolean

-            test_lines = StrComp(.Cells(1, 1).Value, GOOD_LINE_STATUS)

-            test_lines = test_lines + StrComp(.Cells(2, 1).Value, GOOD_LINE_STATUS)

-            If test_lines <> 0 Then

-                MsgBox _

-                    Prompt:="График не может быть построен." & vbCrLf & "Опорные точки не определены .", _

-                    Title:=PROGRAM_NAME, _

-                    Buttons:=vbOKOnly + vbExclamation

-                Exit Sub

-            End If

-        End With

-        Draw_Chart Not IsEmpty(.Range("TABLE_2").Cells(1, 1))

-    End With

-    With ThisWorkbook

-        .Worksheets(CHART_SHEET).Select

-    End With

-End Sub

-

-Sub cmViewForm()

-    With ThisWorkbook

-        .Worksheets(FORM_SHEET).Select

-    End With

-End Sub

-

-Sub cmCloseProgram()

-    Dim res

-    res = MsgBox( _

-        Prompt:="Вы желаете завершить программу?", _

-        Buttons:=vbQuestion + vbYesNo, _

-        Title:=PROGRAM_NAME _

-    )

-    If res = vbYes Then

-       Application.Quit

-    End If

-End Sub

-

-Sub cmAbout()

-    dlgAbout.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlgAbout.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlgAbout.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlgAbout.Show

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-        helppath = "hh.exe " & .Path & "\help\Denmark.chm"

-        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub cmSetStandaloneMode()

-    Application.ScreenUpdating = False

-    ProtectionDisable wb:=ThisWorkbook

-    SetEnvironment wb:=ThisWorkbook

-    ProtectionEnable wb:=ThisWorkbook

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-End Sub

-

-Sub cmSetDesignerMode()

-    Const right_pwd As Long = 31415926

-    Dim rp As String

-    rp = right_pwd

-    dlgGetPwd.edPwd = ""

-    dlgGetPwd.Show

-    If dlgGetPwd.edPwd = rp Then

-        ProtectionDisable wb:=ThisWorkbook

-        RestoreEnvironment wb:=ThisWorkbook, DesignMode:=True

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-<<<<<<
-======================
-mDenmark
->>>>>>
-Attribute VB_Name = "mDenmark"

-Option Explicit

-

-Public Const FORM_SHEET As String = "MainForm"

-

-'Form Ranges

-Public Const TABLE_1 As String = "TABLE_1"

-Public Const TABLE_2 As String = "TABLE_2"

-Public Const TABLE_3 As String = "TABLE_3"

-Public Const TABLE_4 As String = "TABLE_4"

-Public Const TABLE_COMMENT As String = "TABLE_COMMENT"

-

-'Основной тип данных - стандарт 1

-

-'*********************

-Dim PriceDataArray As TPriceData

-Dim DenmarkDataArray As TDenmark

-

-Dim mobjAppRunEnable As New cEnableRun

-

-Function TDenmark_Calc() As Boolean

-    

-    Dim nWindow As Integer

-    

-    mobjAppRunEnable.EnableRun (ESTIMATION_DATE)

-    

-    With ThisWorkbook

-        .Activate

-'1)    Read User data

-        With .Worksheets(VAR_SHEET)

-            DenmarkDataArray.nPj = .Range("DEN_PROECT").Value

-            DenmarkDataArray.pSig = .Range("DEN_PARAM").Value

-            nWindow = .Range("DEN_WINDOW").Value

-        End With

-

-'2)   Memory allocation

-        allocate_memory PriceDataArray, DenmarkDataArray, nWindow

-

-'3)   Read data

-        Dim TheRange As Range

-        Set TheRange = .Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE)

-        Dim LinesCount As Integer

-        LinesCount = ReadWebData(Location:=TheRange, Hist:=PriceDataArray.tC, dt:=1, pPriceData:=PriceDataArray)

-        

-        'Init function result

-        TDenmark_Calc = LinesCount >= nWindow

-        

-        If LinesCount >= nWindow Then

-        

-'4)   Calculate metod TDenmarkDataArray

-            DetDenmark PriceDataArray, DenmarkDataArray

-            If Abs(DenmarkDataArray.Signal) > 1 Then  'ценовые ориентиры, если есть сигнал

-                DetProj PriceDataArray, DenmarkDataArray

-            End If

-'5)   Write result

-            Application.ScreenUpdating = False

-    

-'6)    Clear interface tables

-            With .Worksheets(FORM_SHEET)

-                .Range(TABLE_1).ClearContents ' таблица-1

-                .Range(TABLE_2).ClearContents ' таблица-2

-                .Range(TABLE_3).ClearContents ' таблица-3

-                .Range(TABLE_COMMENT).Value = "" ' коментарий-3

-                .Range(TABLE_4).ClearContents ' таблица-4

-            End With

-    

-            ResultLinesOut Location:=TheRange.Offset(2, 0), pPD:=PriceDataArray, pDen:=DenmarkDataArray

-            With .Worksheets(FORM_SHEET)

-                Out_Table_1 TheRange:=.Range(TABLE_1).Cells(1, 1), pDen:=DenmarkDataArray, LastIdx:=PriceDataArray.tC

-                Out_Table_2 TheRange:=.Range(TABLE_2).Cells(1, 1), pPD:=PriceDataArray, pDen:=DenmarkDataArray

-                Out_Table_3 TheRange:=.Range(TABLE_3).Cells(1, 1), pDen:=DenmarkDataArray

-                Out_Table_4 TheRange:=.Range(TABLE_4).Cells(1, 1), pPD:=PriceDataArray

-            End With

-            .Worksheets(VAR_SHEET).Range("BOOL_DENMARK_READY") = True

-        Else

-            MsgBox _

-                Prompt:="Недостаточна глубина выборки данных." _

-                    & vbCrLf & "Измените параметры запроса и пробуйте снова.", _

-                Buttons:=vbOKOnly + vbExclamation, _

-                Title:=PROGRAM_NAME

-            .Worksheets(VAR_SHEET).Range("BOOL_DENMARK_READY") = False

-            .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False

-        End If

-'7)   Free unused memory

-        free_unused_memory PriceDataArray, DenmarkDataArray

-    End With

-    

-End Function

-

-Sub allocate_memory(pPriceData As TPriceData, pDenmarkData As TDenmark, memsize As Integer)

-'  Память под TDenmark

-    ReDim pDenmarkData.res(1 To memsize)

-    ReDim pDenmarkData.tRes(1 To memsize)

-    ReDim pDenmarkData.Supp(1 To memsize)

-    ReDim pDenmarkData.tSupp(1 To memsize)

-   

-' Инициализация данных по ценам

-    pPriceData.tC = memsize

-    ReDim pPriceData.D(1 To memsize)

-    ReDim pPriceData.Tm(1 To memsize)

-    ReDim pPriceData.Opn(1 To memsize)

-    ReDim pPriceData.Hgh(1 To memsize)

-    ReDim pPriceData.Lw(1 To memsize)

-    ReDim pPriceData.Cls(1 To memsize)

-    ReDim pPriceData.Vl(1 To memsize)

-

-End Sub

-

-Sub free_unused_memory(pP As TPriceData, pD As TDenmark)

-'   Free Prices

-    pP.tC = 0

-    Erase pP.D

-    Erase pP.Tm

-    Erase pP.Opn

-    Erase pP.Hgh

-    Erase pP.Lw

-    Erase pP.Cls

-    Erase pP.Vl

-    

-'Free TDenmark

-    Erase pD.res

-    Erase pD.tRes

-    Erase pD.Supp

-    Erase pD.tSupp

-End Sub

-

-

-'*****************************************

-Sub DetDenmark(pPriceData As TPriceData, pDenmarkData As TDenmark)

-' определение элементов данных Денмарка (в цифровой форме)

-' на текущий момент времени времени tC

-' ИСХОДНЫЕ ДАННЫЕ:

-' pPriceData  - окно, стандартная форма данных по ценам (определена)

-' РЕЗУЛЬТАТ:

-' pDenmarkData - элементы данных Денмарка (память выделена, pSig - определен):

-' линии Res,Supp их наклоны, опорные точки, сигналы к покупке или продаже

-' Signal = 0 сигнал отсутствует

-' Signal < 0 прорыв восходящего тренда (сигнал продажи)

-' Signal > 0 прорыв нисходящего тренда (сигнал покупки)

-' Если pDenmarkData.nRes < 2, то элементы Res не определяются

-' Если pDenmarkData.nSupp < 2, то элементы Supp не определяются

-

-' начальная установка

-    Const QUALIFICATOR_DISABLE As String = "-"

-    Const QUALIFICATOR_ENABLE As String = "Signal"

-    

-    Dim i As Integer

-    pDenmarkData.Signal = 0

-    For i = 1 To 3

-        pDenmarkData.Qual(i) = QUALIFICATOR_DISABLE

-    Next i

-    

-' определение линии поддержки и сопротивления

-    ResLine pPriceData.Hgh, pPriceData.tC, pDenmarkData.nRes, pDenmarkData.res, pDenmarkData.tRes

-    SuppLine pPriceData.Lw, pPriceData.tC, pDenmarkData.nSupp, pDenmarkData.Supp, pDenmarkData.tSupp

-    If pDenmarkData.nRes >= 2 Then

-        pDenmarkData.AnglRes = 57.29578 * _

-            Atn(pDenmarkData.res(pPriceData.tC) - _

-                pDenmarkData.res(pPriceData.tC - 1))

-    End If

-    If pDenmarkData.nSupp >= 2 Then

-        pDenmarkData.AnglSupp = 57.29578 * _

-            Atn(pDenmarkData.Supp(pPriceData.tC) - _

-                pDenmarkData.Supp(pPriceData.tC - 1))

-    End If

-

-' ФОРМИРОВАНИЕ СИГНАЛА ----------------------------------

-    Dim t As Integer

-' 1. случай нисходящего тренда: Res определен и Res падает *************

-    If pDenmarkData.nRes >= 2 And pDenmarkData.AnglRes < 0 Then

-'    необходимое условие прорыва вверх

-        If pDenmarkData.res(pPriceData.tC) < pPriceData.Cls(pPriceData.tC) Then

-            pDenmarkData.Signal = 1

-            For t = pPriceData.tC - pDenmarkData.pSig To pPriceData.tC - 1

-                If pPriceData.Cls(t) > pDenmarkData.res(t) Then

-                    pDenmarkData.Signal = 0

-                    Exit For

-                End If

-            Next t

-        End If

-        If pDenmarkData.Signal = 1 Then

-'       Qualificator-1: close убывает накануне прорыва

-            If pPriceData.Cls(pPriceData.tC - 2) > pPriceData.Cls(pPriceData.tC - 1) Then

-                pDenmarkData.Signal = pDenmarkData.Signal + 1

-                pDenmarkData.Qual(1) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-2: open > Res в момент прорыва

-            If pPriceData.Opn(pPriceData.tC) > pDenmarkData.res(pPriceData.tC) Then

-                pDenmarkData.Signal = pDenmarkData.Signal + 1

-                pDenmarkData.Qual(2) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-3 - demand value < Res(tC)

-            If 2 * pPriceData.Cls(pPriceData.tC - 1) - pPriceData.Lw(pPriceData.tC - 1) < pDenmarkData.res(pPriceData.tC) Then

-                pDenmarkData.Signal = pDenmarkData.Signal + 1

-                pDenmarkData.Qual(3) = QUALIFICATOR_ENABLE

-            End If

-        End If

-    End If  ' нисходящий тренд обработан ************************************

-

-' 2. случай восходящего тренда: supp определен и supp растет

-    If pDenmarkData.nSupp >= 2 And pDenmarkData.AnglSupp > 0 Then

-'    ---------------------------------------------

-'    необходимое условие прорыва вниз

-        If pPriceData.Cls(pPriceData.tC) < pDenmarkData.Supp(pPriceData.tC) Then

-            pDenmarkData.Signal = -1

-            For t = pPriceData.tC - pDenmarkData.pSig To pPriceData.tC - 1

-                If pPriceData.Cls(t) < pDenmarkData.Supp(t) Then

-                    pDenmarkData.Signal = 0

-                    Exit For

-                End If

-            Next t

-        End If

-        If pDenmarkData.Signal = -1 Then

-'       Qualificator-1: Close растет накануне прорыва

-            If pPriceData.Cls(pPriceData.tC - 2) < pPriceData.Cls(pPriceData.tC - 1) Then

-                pDenmarkData.Signal = pDenmarkData.Signal - 1

-                pDenmarkData.Qual(1) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-2: Open ниже Res в момент прорыва

-            If pPriceData.Opn(pPriceData.tC) < pDenmarkData.Supp(pPriceData.tC) Then

-                pDenmarkData.Signal = pDenmarkData.Signal - 1

-                pDenmarkData.Qual(2) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-3 - supply value(t-1) > Supp(tC)

-            If 2 * pPriceData.Cls(pPriceData.tC - 1) - pPriceData.Hgh(pPriceData.tC - 1) > pDenmarkData.Supp(pPriceData.tC) Then

-                pDenmarkData.Signal = pDenmarkData.Signal - 1

-                pDenmarkData.Qual(3) = QUALIFICATOR_ENABLE

-            End If

-        End If

-'    ---------------------------------------------

-    End If

-End Sub

-

-Sub DetProj(pPriceData As TPriceData, pDenmarkData As TDenmark)

-'Определение проекции при наличии сигнала: |Signal| > 1

-'Услловие применимости |Signal| > 1 !!!

-    Dim pM As Double, t As Integer, Tm As Integer, tL As Integer

-

-    If pDenmarkData.Signal >= 2 Then  ' СИГНАЛ ПОКУПКИ

-

-        tL = pDenmarkData.tRes(pDenmarkData.nRes)     ' tR determination

-        If tL = pPriceData.tC Then

-            tL = pDenmarkData.tRes(pDenmarkData.nRes - 1)

-        End If

-

-'  Projections 1,2 --------------------------------------------

-        If pDenmarkData.nPj >= 1 And pDenmarkData.nPj <= 2 Then

-'           t* = Arg min {L(t) : t R <= t  <= tb ,  L(t) < Res(t)},

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Lw(Tm) ' L(t-1) < Res(t-1) for t - break point !

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Lw(t) < pM And pPriceData.Lw(t) < pDenmarkData.res(t) Then

-                    pM = pPriceData.Lw(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            If pDenmarkData.nPj = 1 Then

-'               P1( tb) = Res(tb) + Res(t*) - L(t*)

-                pDenmarkData.Pj = pDenmarkData.res(pPriceData.tC) + pDenmarkData.res(Tm) - pPriceData.Lw(Tm)

-            Else

-                pDenmarkData.Pj = pDenmarkData.res(pPriceData.tC) + pDenmarkData.res(Tm) - pPriceData.Cls(Tm)

-            End If

-        End If ' pDenmarkData.nPj >= 1 And pDenmarkData.nPj <= 2

-   

-'  ----------------------------------------------------------------

-'  Projections 3

-        If pDenmarkData.nPj = 3 Then

-'           t*  = Arg min { С(t) : t R <= t  <= tb ,  C(t) < Res(t)}

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Cls(Tm)

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Cls(t) < pM And pPriceData.Cls(t) < pDenmarkData.res(t) Then

-                    pM = pPriceData.Cls(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            pDenmarkData.Pj = pDenmarkData.res(pPriceData.tC) + pDenmarkData.res(Tm) - pPriceData.Cls(Tm)

-        End If

-    End If ' pDenmarkData.Signal >= 2

-

-'-------------------------------------------------------------------

-'*******************************************************************

-' ПРОЕКЦИЯ ДЛЯ СИГНАЛА ПРОДАЖИ

-    If pDenmarkData.Signal <= -2 Then

-        tL = pDenmarkData.tSupp(pDenmarkData.nSupp)  ' tR determination

-        If tL = pPriceData.tC Then

-            tL = pDenmarkData.tRes(pDenmarkData.nSupp - 1)

-        End If

-

-'  Projections 1,2 --------------------------------------------

-        If pDenmarkData.nPj = 1 Or pDenmarkData.nPj = 2 Then

-'           t* = Arg max {H(t) : t R <= t  <= tb ,  H(t) > Supp(t)},

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Hgh(Tm) ' H(t-1) > Supp(t-1) for t - break point !

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Hgh(t) > pM And pPriceData.Hgh(t) > pDenmarkData.Supp(t) Then

-                    pM = pPriceData.Hgh(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            If pDenmarkData.nPj = 1 Then

- '              P1( tb) = Supp(tb) + Supp(t*) - H(t*)

-                pDenmarkData.Pj = pDenmarkData.Supp(pPriceData.tC) + pDenmarkData.Supp(Tm) - pPriceData.Hgh(Tm)

-            Else

-'               P2( tb) = Supp(tb) + Supp(t*) - C(t*)

-                pDenmarkData.Pj = pDenmarkData.Supp(pPriceData.tC) + pDenmarkData.Supp(Tm) - pPriceData.Cls(Tm)

-            End If

-        End If

-   

-'  ----------------------------------------------------------------

-'  Projections 3

-        If pDenmarkData.nPj = 3 Then

-'           t*  = Arg max { С(t) : t R <= t  <= tb ,  C(t) >  Supp(t)}

-'           P3( tb) = Supp(tb) + Supp(t*) - C(t*)

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Cls(Tm)

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pM < pPriceData.Cls(t) And pPriceData.Cls(t) > pDenmarkData.Supp(t) Then

-                    pM = pPriceData.Cls(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            pDenmarkData.Pj = pDenmarkData.Supp(pPriceData.tC) + pDenmarkData.Supp(Tm) - pPriceData.Cls(Tm)

-        End If

-    End If ' pDenmarkData.Signal <= -2

-End Sub

-

-Sub ResLine(High() As Double, tE As Integer, nRes As Integer, _

-            res() As Double, s() As Integer)

-' Определение линии сопротивления по Демарку [1]

-' Основной вариант

-' ИСХОДНЫЕ ДАННЫЕ:

-' High, dom(High) = [1, tE]

-' РЕЗУЛЬТАТ:

-' 1) линия сопротивления Res, dom(Res)=[s(1), tE], и

-' 2) s = {s(1), s(2), ..., s(nRes)}, s(1) < s(2) < ...< s(nRes)

-'   ( s(nRes)<= tE )- опорные точки

-' 3) число опорных точек nRes.

-' 4) s(1) -  первый момент времени с которого определена Supp

-'    то есть dom{Supp} = [s(1), tC]

-' Прим. Если число опорных точек окажется < 2, то линия

-' сопротивления не определяется. В этом случае следует

-' увеличить историю tE !!!

-    Dim t As Integer, i As Integer

-    Dim v As Double

-'1 определение опорных моментов времени

-    nRes = 0

-    For t = 2 To tE - 1

- '      v = max{high(t-1), high(t+1)} < high(t)

-        v = High(t - 1)

-        If v < High(t + 1) Then

-            v = High(t + 1)

-        End If

-        If High(t) > v Then    'alt.: v >= High(t + 1)

-            s(nRes + 1) = t: nRes = nRes + 1

-        End If

-    Next t

-    If nRes < 2 Then

-        GoTo done

-    End If

-' 2 определение линии сопротивления

-    res(s(1)) = High(s(1))

-    For i = 2 To nRes

-        res(s(i)) = High(s(i))

-        v = (High(s(i)) - High(s(i - 1))) / (s(i) - s(i - 1))

-        For t = s(i - 1) + 1 To s(i) - 1

-            res(t) = High(s(i - 1)) + v * (t - s(i - 1))

-        Next t

-    Next i

-    If s(nRes) < tE Then

-        v = (High(s(nRes)) - High(s(nRes - 1))) / (s(nRes) - s(nRes - 1))

-        For t = s(nRes) + 1 To tE

-            res(t) = High(s(nRes - 1)) + v * (t - s(nRes - 1))

-        Next t

-    End If

-done:

-End Sub

-

-Sub SuppLine(Low() As Double, tE As Integer, nSupp As Integer, _

-               Supp() As Double, s() As Integer)

-' Определение линии поддержки по Демарку [1] (от конца)

-' Исходные данные:

-' Low, dom(Low) = [1, tE]

-' Результат:

-' 1) линия сопротивления Supp, dom(Supp)=[s(1), tE],

-' 2) s = {s(1), s(2), ..., s(nSupp)}, s(1) < s(2) < ...< s(nSupp) -

-'    опорные точки

-' 3) число опорных точек nSupp.

-' Прим. Если фактическое число опорных точек окажется < 2, то линия

-' поддержки не определяется.

-    Dim t As Integer, i As Integer

-    Dim v As Double

-'1 определение опорных моментов времени

-     nSupp = 0

-    For t = 2 To tE - 1

-'       v = min{Low(t-1), Low(t+1)} > Low(t)

-        v = Low(t - 1)

-        If v > Low(t + 1) Then

-            v = Low(t + 1)

-        End If

-        If Low(t) < v Then    'alt.: v >= High(t + 1)

-            s(nSupp + 1) = t: nSupp = nSupp + 1

-        End If

-    Next t

-    If nSupp < 2 Then

-        GoTo done

-    End If

-' 2 определение линии поддержки

-    Supp(s(1)) = Low(s(1))

-    For i = 2 To nSupp

-        Supp(s(i)) = Low(s(i))

-        v = (Low(s(i)) - Low(s(i - 1))) / (s(i) - s(i - 1))

-        For t = s(i - 1) + 1 To s(i) - 1

-            Supp(t) = Low(s(i - 1)) + v * (t - s(i - 1))

-        Next t

-    Next i

-    If s(1) < tE Then

-        v = (Low(s(nSupp)) - Low(s(nSupp - 1))) / (s(nSupp) - s(nSupp - 1))

-        For t = s(nSupp) + 1 To tE

-            Supp(t) = Low(s(nSupp - 1)) + v * (t - s(nSupp - 1))

-        Next t

-    End If

-done:

-End Sub

-

-<<<<<<
-======================
-mChart
->>>>>>
-Attribute VB_Name = "mChart"

-Option Explicit

-

-Const CHART_NAME As String = "PriceChart"

-

-Sub Draw_Chart(SignalDefined As Boolean)

-

-    Dim n As Integer

-    Dim theChart As Chart

-    Dim ChartDataAria, szLastNumber As String

-    Dim MinYScale As Double

-    

-    With ThisWorkbook

-' Disable screen out

-        .Application.Cursor = xlWait

-        .Application.ScreenUpdating = False

-' Create series range

-        n = GetLinesCount(Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE))

-        szLastNumber = n + 1

-        If SignalDefined Then

-            ChartDataAria = "A2:A" + szLastNumber + ",C2:D" + szLastNumber + ",H2:J" + szLastNumber

-        Else

-            ChartDataAria = "A2:A" + szLastNumber + ",C2:D" + szLastNumber + ",H2:I" + szLastNumber

-        End If

-        MinYScale = GetMinValue(.Worksheets(RAW_DATA_SHEET).Range(ChartDataAria))

-' Find and delete old chart

-        .Worksheets(CHART_SHEET).Unprotect

-        Dim WindowWidth, WindowHeight As Integer

-        With .Worksheets(CHART_SHEET)

-            WindowWidth = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-            WindowHeight = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-        End With

-        With .Worksheets(CHART_SHEET).ChartObjects

-            .delete

-            With .Add(5, 5, WindowWidth - 10, WindowHeight - 10)

-                .SendToBack

-                Set theChart = .Chart

-            End With

-' Create a chart

-        End With

-        With theChart

-            .ChartType = xlLine

-            .SetSourceData Source:=Sheets(RAW_DATA_SHEET).Range( _

-                    ChartDataAria), PlotBy:=xlColumns

-            .Location Where:=xlLocationAsObject, Name:=CHART_SHEET

-            .HasTitle = True

-            With .ChartTitle

-                .Text = ThisWorkbook.Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE).Value

-                With .Font

-                    .Size = 8

-                    .Bold = True

-                End With

-            End With

-            .HasLegend = True

-            With .Legend

-                .Position = xlTop

-                With .Font

-                    .Name = "Arial"

-                    .Size = 8

-                End With

-            End With

-            .HasDataTable = False

-            With .Axes(xlCategory)

-                .HasMajorGridlines = True

-                .HasMinorGridlines = False

-                .TickLabels.Orientation = xlUpward

-                With .MajorGridlines.Border

-                    .ColorIndex = 48

-                    .Weight = xlHairline

-                    .LineStyle = xlDot

-                End With

-                .CrossesAt = 1

-                .TickLabelSpacing = 1

-                .TickMarkSpacing = 1

-                .AxisBetweenCategories = False

-                .ReversePlotOrder = False

-                .TickLabels.AutoScaleFont = True

-                With .TickLabels.Font

-                    .Name = "Arial"

-                    .Size = 9

-                End With

-            End With

-            With .Axes(xlValue)

-                .HasMajorGridlines = True

-                .HasMinorGridlines = False

-                With .MajorGridlines.Border

-                    .ColorIndex = 48

-                    .Weight = xlHairline

-                    .LineStyle = xlDot

-                End With

-                .MinimumScale = MinYScale

-                .MaximumScaleIsAuto = True

-                .MinorUnitIsAuto = True

-                .MajorUnitIsAuto = True

-                .Crosses = xlCustom

-                .CrossesAt = MinYScale

-                .ReversePlotOrder = False

-                .ScaleType = xlLinear

-                .TickLabels.AutoScaleFont = True

-                With .TickLabels.Font

-                    .Name = "Arial"

-                    .Size = 9

-                End With

-            End With

-            .ChartTitle.Top = 5

-            .ChartTitle.Left = 5

-            With .Legend

-                .Top = 5

-                .Fill.OneColorGradient _

-                    Style:=msoGradientHorizontal, _

-                    Variant:=3, _

-                    Degree:=0.303913939116503

-                .Fill.Visible = True

-                .Fill.ForeColor.SchemeColor = 71

-            End With

-            .PlotArea.Left = 10

-            .PlotArea.Top = .Legend.Top + .Legend.Height + 5

-            .PlotArea.Width = .ChartArea.Width - 20

-            .PlotArea.Height = .ChartArea.Height - .PlotArea.Top

-            

-' Tune OPEN line

-            With .SeriesCollection(1)

-                .Border.LineStyle = xlNone

-                .MarkerBackgroundColorIndex = xlNone

-                .MarkerForegroundColorIndex = 1

-                .MarkerStyle = xlPlus

-                .Smooth = False

-                .MarkerSize = 9

-                .Shadow = False

-            End With

-' Tune CLOSE line

-            With .SeriesCollection(2)

-                .Border.ColorIndex = 10

-                .Border.Weight = xlMedium

-                .Border.LineStyle = xlContinuous

-            End With

-' Tune RESISTANCE line

-            With .SeriesCollection(3)

-                .Border.ColorIndex = 3

-                .Border.Weight = xlThin

-                .Border.LineStyle = xlContinuous

-            End With

-' Tune SUUPORT line

-            With .SeriesCollection(4)

-                .Border.ColorIndex = 25

-                .Border.Weight = xlThin

-                .Border.LineStyle = xlContinuous

-            End With

-            If SignalDefined Then

-                With .SeriesCollection(5)

-                    .Border.ColorIndex = 6

-                    .Border.Weight = xlThin

-                    .Border.LineStyle = xlDot

-                End With

-            End If

-        End With

-        .Application.Cursor = xlDefault

-        With .Worksheets(CHART_SHEET)

-            .Range("A1").Select

-            .Protect userInterfaceOnly:=True

-        End With

-    End With

-End Sub

-

-Function GetMinValue(DataRange As Range) As Double

-    Dim Cell As Range

-    Dim MinValue, MaxValue, RangeValue, CorrectValue, Mult As Double

-    MinValue = MAX_PRICE_VALUE

-    MaxValue = MIN_PRICE_VALUE

-    For Each Cell In DataRange

-        If Not IsEmpty(Cell) And IsNumeric(Cell) Then

-            If Cell > MIN_PRICE_VALUE Then

-                If Cell < MinValue Then

-                    MinValue = Cell

-                End If

-                If Cell > MaxValue Then

-                    MaxValue = Cell

-                End If

-            End If

-        End If

-    Next

-    RangeValue = MaxValue - MinValue

-    If RangeValue < 0 Then

-        MinValue = 0

-    Else

-        CorrectValue = RangeValue / 4

-        Mult = MIN_PRICE_VALUE

-        While MinValue - Int(MinValue * Mult) / Mult > CorrectValue

-            Mult = Mult * 10

-        Wend

-        MinValue = Int(MinValue * Mult) / Mult

-    End If

-    GetMinValue = MinValue

-End Function

-

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub GetState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        ActiveWorkbook.Close False

-

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.Name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars("Worksheet Menu Bar").Visible = False

-End Sub

-

-

-Public Sub RestoreState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars("Worksheet Menu Bar").Visible = True

-End Sub

-

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{04E12C90-FC33-11D3-B015-0050048697AF}{04E12C80-FC33-11D3-B015-0050048697AF}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub CommandButton1_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mWebQeury
->>>>>>
-Attribute VB_Name = "mWebQeury"

-Option Explicit

-

-Public Const Qry_DELETE_ALL As String = "Qry_DELETE_ALL"

-Public Const Qry_PATH_NO_CHANGE As String = "Qry_PATH_NO_CHANGE"

-

-

-Sub QryCreate(QryRange As Range, QryName As String, QryPath As String, Optional RefreshBkgnd = False)

-    Dim WebQuery As QueryTable

-    QryDelete QryRange:=QryRange, QryName:=QryName

-    

-    Set WebQuery = QryRange.Worksheet.QueryTables.Add( _

-            Connection:=QryPath, _

-            Destination:=QryRange)

-    

-    With WebQuery

-        .FieldNames = False

-        .Name = QryName

-        .RefreshStyle = xlOverwriteCells

-        .RowNumbers = False

-        .FillAdjacentFormulas = False

-        .RefreshOnFileOpen = False

-        .HasAutoFormat = False

-        .BackgroundQuery = False

-        .TablesOnlyFromHTML = False

-        .Refresh BackgroundQuery:=RefreshBkgnd

-        .SavePassword = False

-        .SaveData = True

-    End With

-End Sub

-

-Function QryRefresh(QryRange As Range, QryName As String, Optional QryPath As String = Qry_PATH_NO_CHANGE, Optional Background As Boolean = False) As Boolean

-    Dim qry_result As Boolean

-    qry_result = False

-    If QryExist(QryRange, QryName) Then

-        With QryRange.Worksheet.QueryTables(QryName)

-            If QryPath <> Qry_PATH_NO_CHANGE Then

-                .Connection = QryPath

-            End If

-            .Refresh BackgroundQuery:=Background

-            qry_result = True

-        End With

-    End If

-    QryRefresh = qry_result

-End Function

-

-Sub QryDelete(QryRange As Range, Optional QryName As String = Qry_DELETE_ALL)

-    Dim WebQuery As QueryTable

-    For Each WebQuery In QryRange.Worksheet.QueryTables

-        If QryName = Qry_DELETE_ALL Or WebQuery.Name = QryName Then

-            WebQuery.delete

-        End If

-    Next

-End Sub

-

-Function QryExist(QryRange As Range, QryName As String) As Boolean

-    Dim WebQuery As QueryTable

-    For Each WebQuery In QryRange.Worksheet.QueryTables

-        If WebQuery.Name = QryName Then

-            QryExist = True

-            Exit For

-        End If

-    Next

-End Function

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Sub CreateCommandBar(theApp As Application)

-Attribute CreateCommandBar.VB_ProcData.VB_Invoke_Func = "R\n14"

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible + msoBarNoCustomize + msoBarNoMove + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Contents"

-                        .OnAction = "cmHelpContents"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible + msoBarNoCustomize + msoBarNoMove + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(Flag As Boolean)

-    If Flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars("Worksheet Menu Bar")

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long)

-    If end_date = NO_ESTIMATION_DATE Then

-        Beep

-        Exit Sub

-    End If

-    Dim TheDate As Date ' Declare variables.

-    TheDate = Now

-    Dim day, month, year As Long

-    Dim curdate As Long

-    day = DatePart("d", TheDate)

-    month = DatePart("m", TheDate)

-    year = DatePart("yyyy", TheDate)

-    curdate = year * 10000

-    curdate = curdate + month * 100

-    curdate = curdate + day

-    If curdate > end_date Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mTool
->>>>>>
-Attribute VB_Name = "mTool"

-Option Explicit

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub tool_delete_all_tables()

-    QryDelete ThisWorkbook.Worksheets(RAW_DATA_SHEET).Range("A1")

-End Sub

-

-Sub tool_delete_all_charts()

-    Dim theChart As Chart

-    For Each theChart In ThisWorkbook.Charts

-        theChart.delete

-    Next

-End Sub

-

-

-

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{04E12C94-FC33-11D3-B015-0050048697AF}{04E12C88-FC33-11D3-B015-0050048697AF}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-

-

-Private Sub App_WorkbookOpen(ByVal wb As Workbook)

-    Dim wbname As String

-    If Application.Workbooks.count > 1 Then

-        wbname = wb.FullName

-        wb.Close Savechanges:=False

-        Shell "EXCEL " & wbname

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mRead
->>>>>>
-Attribute VB_Name = "mRead"

-

-Option Explicit

-

-

-

-

-Sub ReadData1(aPoint As String, Hist As Integer, dt As Integer, _

-              p As PriceData)

-'Инициализация типа PriceData из таблицы типа - 1

-'kопируются не более чем hist последних строк

-'aPoint - начало таблицы

-'первые две строки таблицы идентифицирует данные (строки)

- Dim n As Integer, i As Integer

-'Определение числа строк таблицы - n

- Dim theRange As Range

- Set theRange = ActiveSheet.Range(aPoint)

- n = 0

- Do While IsEmpty(theRange.Offset(n, 0).Value) = False

-     n = n + 1

- Loop

- If n = 0 Then             'обработать ошибку !!!

-    GoTo done

- End If

-' число строк определено ()

- If Hist > (n - 3) \ dt + 1 Then ' коррекция истории

-    Hist = (n - 3) \ dt + 1 '

- End If

- Dim t As Integer, s As Integer

- For t = 0 To Hist - 1

-      s = n - t * dt - 1

-      p.D(Hist - t) = theRange.Offset(s, 0).Value

-      p.Opn(Hist - t) = theRange.Offset(s, 1).Value

-      p.Hgh(Hist - t) = theRange.Offset(s, 2).Value

-      p.Lw(Hist - t) = theRange.Offset(s, 3).Value

-      p.Cls(Hist - t) = theRange.Offset(s, 4).Value

-'     p.Vl(hist - t) = theRange.Offset(s, 5).Value

- Next t

-done:

-End Sub

-

-

-Function StrNum(aPoint As String)

-' возвращает число строк таблицы

- Dim theRange As Range

- Set theRange = ActiveSheet.Range(aPoint)

- StrNum = 0

- Do While IsEmpty(theRange.Offset(StrNum, 0).Value) = False

-     StrNum = StrNum + 1

- Loop

-End Function

-

-

-Sub ReadData2(aPoint As String, Hist As Integer, tE As Integer, _

-              p As PriceData)  ' ??? не протестирован

-'Инициализация типа PriceData из таблицы типа - 1

-'kопируются не более чем hist последних строк

-'последней строкой считается строка с номером tE

-'aPoint - начало таблицы

-'Прим. Первые две строки таблицы идентифицирует данные (строки)

-'Число строк таблицы  должно быть больше tE (!)

- Dim n As Integer, i As Integer

-'1 ОПРЕДЕЛЕНИЕ ЧИСЛА СТРОК ТАБЛИЦЫ - n

- Dim theRange As Range

- Set theRange = ActiveSheet.Range(aPoint)

- If tE - 2 < Hist Then ' коррекция истории

-    Hist = tE - 2

- End If

- Dim t As Integer, s As Integer

- For s = 1 To Hist

-      t = tE - Hist + s - 1

-      p.D(s) = theRange.Offset(t, 0).Value

-      p.Opn(s) = theRange.Offset(t, 1).Value

-      p.Hgh(s) = theRange.Offset(t, 2).Value

-      p.Lw(s) = theRange.Offset(t, 3).Value

-      p.Cls(s) = theRange.Offset(t, 4).Value

-      p.Vl(s) = theRange.Offset(t, 5).Value

- Next s

-done:

-End Sub

-

-

-

-<<<<<<
-======================
-mSignal
->>>>>>
-Attribute VB_Name = "mSignal"

-

-Option Explicit

-'Основной тип данных - стандарт 1

-Type PriceData

-    D() As String      ' календарная дата

-    Opn() As Double    ' Open

-    Hgh() As Double    ' High

-    Lw() As Double     ' Low

-    Cls() As Double    ' Close

-    Vl() As Integer    ' Volume

-    tC As Integer      ' Current time

-End Type

-

-Type Denmark

-   Res() As Double    'Resistance line

-   tRes() As Integer  'Resistance pivot points

-   nRes As Integer    'The number of resistance pivot points

-   AnglRes As Double  'Angle of Declination of Res

-   

-   Supp() As Double       'Support line

-   tSupp() As Integer     'Support pivot points

-   nSupp As Integer       'The number of support pivot points

-   

-   pSig     As Integer    ' parameter for Signal

-   Signal As Integer      'Signal

-   

-   AnglSupp As Double     ' Angle of Declination of Supp

-   Qual(1 To 3) As String ' qualificators

- 

-   nPj As Integer         ' номер проекции

-   Pj  As Double          ' проекция

-   

-End Type

-

-'*********************

-Dim P_PD As PriceData

-Dim P_DEN As Denmark

-'*********************

-Sub Denmark_Click()    'm

-  Dim nWin As Integer, theList As String, thePoint As String

-  

-  nWin = Range("C3").Value

-  theList = Range("C4").Value

-  thePoint = Range("C5").Value

-  P_DEN.nPj = Range("C6").Value

-  P_DEN.pSig = Range("C7").Value

-' 1. Очистка

-  Range("F4:H6").ClearContents ' таблица-1

-' Range("E9:G9").ClearContents ' таблица-2

-' Range("K4:K6").ClearContents ' таблица-3

-  Range("B12:G112").Clear         ' таблица - 4

-  Range("H12:I112").ClearContents ' таблица - 4

-' 2. Выделение памяти

-  InitPriceData p:=P_PD, tE:=nWin

-  InitDenmark p:=P_DEN, tE:=nWin

-' 3. Чтение данных по ценам

-  Worksheets(theList).Select

-  ReadData1 aPoint:=thePoint, Hist:=P_PD.tC, dt:=1, p:=P_PD

-

-' 5.определение элементов P_DEN

-  DetDenmark P_PD, P_DEN

-  If Abs(P_DEN.Signal) > 1 Then  'ценовые ориентиры, если есть сигнал

-      DetProj P_PD, P_DEN

-  End If

-' 6. Output

-  Output_1 "List1", "B11", P_PD, P_DEN

-  Table1 "List1", "F4", P_DEN

-  Table2 "List1", "E9", P_DEN, P_PD

-  Table3 "List1", "k4", P_DEN

-End Sub

-Sub Table1(ListName As String, aPoint As String, pDen As Denmark)

-' Col = 2 - не определен !!!

-  Worksheets(ListName).Select

-  Dim theRange As Range

-  Set theRange = ActiveSheet.Range(aPoint)  'Точка вывода осн. данных

-' Status - Col = 0

-  If pDen.nRes >= 2 Then

-     theRange.Offset(0, 0).Value = "O'KEY"

-  Else

-     theRange.Offset(0, 0).Value = "ND!"

-  End If

-  If pDen.nSupp >= 2 Then

-     theRange.Offset(1, 0).Value = "O'KEY"

-  Else

-     theRange.Offset(1, 0).Value = "ND!"

-  End If

-' -----------------------------------------

-' углы наклонов линии сопротивления и поддержки - Col = 1

-  If pDen.nRes >= 2 Then

-    theRange.Offset(0, 1).Value = pDen.AnglRes

-  End If

-  If pDen.nSupp >= 2 Then

-    theRange.Offset(1, 1).Value = pDen.AnglSupp

-  End If

-  If pDen.nRes >= 2 And pDen.nSupp >= 2 Then

-    theRange.Offset(2, 1).Value = (pDen.AnglRes + pDen.AnglSupp) / 2

-  End If

-End Sub

-Sub Table2(ListName As String, aPoint As String, _

-           pDen As Denmark, pPD As PriceData)

-  

-  Worksheets(ListName).Select

-  Dim theRange As Range

-  Set theRange = ActiveSheet.Range(aPoint)  'Точка вывода осн. данных

-  If pDen.Signal >= 2 Then

-     MsgBox _

-     "Внимание! Buy Signal: возможен прорыв вверх нисходящего тренда с уровнем значимости = " & P_DEN.Signal - 1 & " ! "

-     theRange.Offset(0, 0).Value = "Buy"

-     theRange.Offset(0, 1).Value = pPD.D(pPD.tC)

-     theRange.Offset(0, 2).Value = pDen.Signal - 1

-     theRange.Offset(0, 3).Value = pDen.Pj

-  End If

-  If pDen.Signal <= -2 Then

-     MsgBox _

-     "Внимание! Sell Signal: возможен прорыв вниз восходящего тренда с уровнем значимости = " & -(P_DEN.Signal + 1) & "!"

-     theRange.Offset(0, 0).Value = "Sell"

-     theRange.Offset(0, 1).Value = pPD.D(pPD.tC)

-     theRange.Offset(0, 2).Value = pDen.Signal + 1

-     theRange.Offset(0, 3).Value = pDen.Pj

-    End If

-   

-End Sub

-Sub Table3(ListName As String, aPoint As String, pDen As Denmark)

-  Worksheets(ListName).Select

-  Dim theRange As Range

-  Set theRange = ActiveSheet.Range(aPoint)  'Точка вывода осн. данных

-  Dim i As Integer

-  For i = 1 To 3

-     theRange.Offset(i - 1, 0).Value = pDen.Qual(i)

-  Next i

-End Sub

-

-

-Sub InitDenmark(p As Denmark, tE As Integer)

-'  Память под Denmark

-   ReDim p.Res(1 To tE)

-   ReDim p.tRes(1 To tE)

-   ReDim p.Supp(1 To tE)

-   ReDim p.tSupp(1 To tE)

-End Sub

-Sub Output_1(ListName As String, aPoint As String, _

-             pPD As PriceData, pDen As Denmark)

-' Вывод ценовых данных и акcесcуаров Денмарка ???

-' на рабочую страницу ListName по адресу aPoint

-  Worksheets(ListName).Select

-  Dim theRange As Range

-  Set theRange = ActiveSheet.Range(aPoint) 'Точка ввода осн. данных

-  theRange.Offset(0, 0).Value = "No"

-  theRange.Offset(0, 1).Value = "Date"

-  theRange.Offset(0, 2).Value = "Open"

-  theRange.Offset(0, 3).Value = "High"

-  theRange.Offset(0, 4).Value = "Low"

-  theRange.Offset(0, 5).Value = "Close"

-  theRange.Offset(0, 6).Value = "Res"

-  theRange.Offset(0, 7).Value = "Supp"

-  Dim t As Integer, k As Integer

-  Dim i As Integer, j As Integer

-  i = 1: j = 1

-  For t = 1 To pPD.tC

-      theRange.Offset(t, 0).Value = t

-      theRange.Offset(t, 1).Value = pPD.D(t)

-      theRange.Offset(t, 2).Value = pPD.Opn(t)

-      theRange.Offset(t, 3).Value = pPD.Hgh(t)

-      theRange.Offset(t, 4).Value = pPD.Lw(t)

-      theRange.Offset(t, 5).Value = pPD.Cls(t)

-      If t >= pDen.tRes(1) Then

-        theRange.Offset(t, 6).Value = pDen.Res(t)

-      End If

-     If t >= pDen.tSupp(1) Then

-        theRange.Offset(t, 7).Value = pDen.Supp(t)

-     End If

-     If t = pDen.tRes(i) Then   'temp

-        theRange.Offset(t, 3).Interior.ColorIndex = 4

-        i = i + 1

-     End If

-     If t = pDen.tSupp(j) Then  'temp

-        theRange.Offset(t, 4).Interior.ColorIndex = 8

-        j = j + 1

-     End If

- Next t

-End Sub

-

-'*****************************************

-Sub DetDenmark(pPD As PriceData, pDen As Denmark)

-' определение элементов данных Денмарка (в цифровой форме)

-' на текущий момент времени времени tC

-' ИСХОДНЫЕ ДАННЫЕ:

-' pPD  - окно, стандартная форма данных по ценам (определена)

-' РЕЗУЛЬТАТ:

-' pDen - элементы данных Денмарка (память выделена, pSig - определен):

-' линии Res,Supp их наклоны, опорные точки, сигналы к покупке или продаже

-' Signal = 0 сигнал отсутствует

-' Signal < 0 прорыв восходящего тренда (сигнал продажи)

-' Signal > 0 прорыв нисходящего тренда (сигнал покупки)

-' Если pDen.nRes < 2, то элементы Res не определяются

-' Если pDen.nSupp < 2, то элементы Supp не определяются

-

-' начальная установка

-  Dim i As Integer

-  pDen.Signal = 0

-  For i = 1 To 3

-     pDen.Qual(i) = "-"

-  Next i

-

-' определение линии поддержки и сопротивления

-  ResLine pPD.Hgh, pPD.tC, pDen.nRes, pDen.Res, pDen.tRes

-  SuppLine pPD.Lw, pPD.tC, pDen.nSupp, pDen.Supp, pDen.tSupp

-  If pDen.nRes >= 2 Then

-       pDen.AnglRes = 57.29578 * _

-       Atn(pDen.Res(pPD.tC) - pDen.Res(pPD.tC - 1))

-  End If

-  If pDen.nSupp >= 2 Then

-       pDen.AnglSupp = 57.29578 * _

-       Atn(pDen.Supp(pPD.tC) - pDen.Supp(pPD.tC - 1))

-  End If

-

-' ФОРМИРОВАНИЕ СИГНАЛА ----------------------------------

-  Dim t As Integer

-' 1. случай нисходящего тренда: Res определен и Res падает *************

-  If pDen.nRes >= 2 And pDen.AnglRes < 0 Then

-'    необходимое условие прорыва вверх

-     If pDen.Res(pPD.tC) < pPD.Cls(pPD.tC) Then

-        pDen.Signal = 1

-        For t = pPD.tC - pDen.pSig To pPD.tC - 1

-           If pPD.Cls(t) > pDen.Res(t) Then

-             pDen.Signal = 0

-             Exit For

-           End If

-        Next t

-     End If

-     If pDen.Signal = 1 Then

-'       Qualificator-1: close убывает накануне прорыва

-        If pPD.Cls(pPD.tC - 2) > pPD.Cls(pPD.tC - 1) Then

-           pDen.Signal = pDen.Signal + 1

-           pDen.Qual(1) = "*"

-        End If

-'       Qualificator-2: open > Res в момент прорыва

-        If pPD.Opn(pPD.tC) > pDen.Res(pPD.tC) Then

-            pDen.Signal = pDen.Signal + 1

-            pDen.Qual(2) = "*"

-        End If

-'       Qualificator-3 - demand value < Res(tC)

-        If 2 * pPD.Cls(pPD.tC - 1) - pPD.Lw(pPD.tC - 1) < pDen.Res(pPD.tC) Then

-           pDen.Signal = pDen.Signal + 1

-           pDen.Qual(3) = "*"

-        End If

-     End If

-  End If  ' нисходящий тренд обработан ************************************

-

-' 2. случай восходящего тренда: supp определен и supp растет

-  If pDen.nSupp >= 2 And pDen.AnglSupp > 0 Then

-'    ---------------------------------------------

-'    необходимое условие прорыва вниз

-     If pPD.Cls(pPD.tC) < pDen.Supp(pPD.tC) Then

-        pDen.Signal = -1

-        For t = pPD.tC - pDen.pSig To pPD.tC - 1

-           If pPD.Cls(t) < pDen.Supp(t) Then

-             pDen.Signal = 0

-             Exit For

-           End If

-        Next t

-     End If

-     If pDen.Signal = -1 Then

-'       Qualificator-1: Close растет накануне прорыва

-        If pPD.Cls(pPD.tC - 2) < pPD.Cls(pPD.tC - 1) Then

-           pDen.Signal = pDen.Signal - 1

-           pDen.Qual(1) = "*"

-        End If

-'       Qualificator-2: Open ниже Res в момент прорыва

-        If pPD.Opn(pPD.tC) < pDen.Supp(pPD.tC) Then

-           pDen.Signal = pDen.Signal - 1

-           pDen.Qual(2) = "*"

-        End If

-'       Qualificator-3 - supply value(t-1) > Supp(tC)

-        If 2 * pPD.Cls(pPD.tC - 1) - pPD.Hgh(pPD.tC - 1) > pDen.Supp(pPD.tC) Then

-           pDen.Signal = pDen.Signal - 1

-           pDen.Qual(3) = "*"

-        End If

-     End If

-'    ---------------------------------------------

-  End If

-End Sub

-Sub DetProj(pPD As PriceData, pDen As Denmark)

-'Определение проекции при наличии сигнала: |Signal| > 1

-'Услловие применимости |Signal| > 1 !!!

-Dim pM As Double, t As Integer, tM As Integer, tL As Integer

-

-If pDen.Signal >= 2 Then  ' СИГНАЛ ПОКУПКИ

-

-   tL = pDen.tRes(pDen.nRes)     ' tR determination

-   If tL = pPD.tC Then

-      tL = pDen.tRes(pDen.nRes - 1)

-   End If

-

-'  Projections 1,2 --------------------------------------------

-   If pDen.nPj >= 1 And pDen.nPj <= 2 Then

-'       t* = Arg min {L(t) : t R <= t  <= tb ,  L(t) < Res(t)},

-        tM = pPD.tC - 1

-        pM = pPD.Lw(tM) ' L(t-1) < Res(t-1) for t - break point !

-        For t = pPD.tC - 2 To tL Step -1

-          If pPD.Lw(t) < pM And pPD.Lw(t) < pDen.Res(t) Then

-             pM = pPD.Lw(t): tM = t

-          End If

-        Next t

-'       t* is defined

-        If pDen.nPj = 1 Then

- '       P1( tb) = Res(tb) + Res(t*) - L(t*)

-           pDen.Pj = pDen.Res(pPD.tC) + pDen.Res(tM) - pPD.Lw(tM)

-        Else

-           pDen.Pj = pDen.Res(pPD.tC) + pDen.Res(tM) - pPD.Cls(tM)

-        End If

-   End If

-   

-'  ----------------------------------------------------------------

-'  Projections 3

-   If pDen.nPj = 3 Then

-'      t*  = Arg min { С(t) : t R <= t  <= tb ,  C(t) < Res(t)}

-       tM = pPD.tC - 1

-       pM = pPD.Cls(tM)

-       For t = pPD.tC - 2 To tL Step -1

-          If pPD.Cls(t) < pM And pPD.Cls(t) < pDen.Res(t) Then

-             pM = pPD.Cls(t): tM = t

-          End If

-       Next t

-'      t* is defined

-       pDen.Pj = pDen.Res(pPD.tC) + pDen.Res(tM) - pPD.Cls(tM)

-   End If

-End If

-

-'-------------------------------------------------------------------

-'*******************************************************************

-' ПРОЕКЦИЯ ДЛЯ СИГНАЛА ПРОДАЖИ

-If pDen.Signal <= -2 Then

-   tL = pDen.tSupp(pDen.nSupp)  ' tR determination

-   If tL = pPD.tC Then

-      tL = pDen.tRes(pDen.nSupp - 1)

-   End If

-

-'  Projections 1,2 --------------------------------------------

-   If pDen.nPj = 1 Or pDen.nPj = 2 Then

-'       t* = Arg max {H(t) : t R <= t  <= tb ,  H(t) > Supp(t)},

-        tM = pPD.tC - 1

-        pM = pPD.Hgh(tM) ' H(t-1) > Supp(t-1) for t - break point !

-        For t = pPD.tC - 2 To tL Step -1

-          If pPD.Hgh(t) > pM And pPD.Hgh(t) > pDen.Supp(t) Then

-             pM = pPD.Hgh(t): tM = t

-          End If

-        Next t

-'       t* is defined

-        If pDen.nPj = 1 Then

- '         P1( tb) = Supp(tb) + Supp(t*) - H(t*)

-           pDen.Pj = pDen.Supp(pPD.tC) + pDen.Supp(tM) - pPD.Hgh(tM)

-        Else

-'          P2( tb) = Supp(tb) + Supp(t*) - C(t*)

-           pDen.Pj = pDen.Supp(pPD.tC) + pDen.Supp(tM) - pPD.Cls(tM)

-        End If

-   End If

-   

-'  ----------------------------------------------------------------

-'  Projections 3

-   If pDen.nPj = 3 Then

-'     t*  = Arg max { С(t) : t R <= t  <= tb ,  C(t) >  Supp(t)}

-'     P3( tb) = Supp(tb) + Supp(t*) - C(t*)

-      tM = pPD.tC - 1

-      pM = pPD.Cls(tM)

-      For t = pPD.tC - 2 To tL Step -1

-          If pM < pPD.Cls(t) And pPD.Cls(t) > pDen.Supp(t) Then

-             pM = pPD.Cls(t): tM = t

-          End If

-      Next t

-'      t* is defined

-      pDen.Pj = pDen.Supp(pPD.tC) + pDen.Supp(tM) - pPD.Cls(tM)

-   End If

-End If

-End Sub

-

-Sub ResLine(High() As Double, tE As Integer, nRes As Integer, _

-            Res() As Double, s() As Integer)

-' Определение линии сопротивления по Демарку [1]

-' Основной вариант

-' ИСХОДНЫЕ ДАННЫЕ:

-' High, dom(High) = [1, tE]

-' РЕЗУЛЬТАТ:

-' 1) линия сопротивления Res, dom(Res)=[s(1), tE], и

-' 2) s = {s(1), s(2), ..., s(nRes)}, s(1) < s(2) < ...< s(nRes)

-'   ( s(nRes)<= tE )- опорные точки

-' 3) число опорных точек nRes.

-' 4) s(1) -  первый момент времени с которого определена Supp

-'    то есть dom{Supp} = [s(1), tC]

-' Прим. Если число опорных точек окажется < 2, то линия

-' сопротивления не определяется. В этом случае следует

-' увеличить историю tE !!!

- Dim t As Integer, i As Integer

- Dim v As Double

-'1 определение опорных моментов времени

- nRes = 0

- For t = 2 To tE - 1

- '   v = max{high(t-1), high(t+1)} < high(t)

-     v = High(t - 1)

-     If v < High(t + 1) Then

-        v = High(t + 1)

-     End If

-     If High(t) > v Then    'alt.: v >= High(t + 1)

-        s(nRes + 1) = t: nRes = nRes + 1

-     End If

- Next t

- If nRes < 2 Then

-    GoTo done

- End If

-' 2 определение линии сопротивления

- Res(s(1)) = High(s(1))

- For i = 2 To nRes

-    Res(s(i)) = High(s(i))

-    v = (High(s(i)) - High(s(i - 1))) / (s(i) - s(i - 1))

-    For t = s(i - 1) + 1 To s(i) - 1

-        Res(t) = High(s(i - 1)) + v * (t - s(i - 1))

-    Next t

- Next i

- If s(nRes) < tE Then

-    v = (High(s(nRes)) - High(s(nRes - 1))) / (s(nRes) - s(nRes - 1))

-    For t = s(nRes) + 1 To tE

-        Res(t) = High(s(nRes - 1)) + v * (t - s(nRes - 1))

-    Next t

- End If

-done:

-End Sub

-

-Sub SuppLine(Low() As Double, tE As Integer, nSupp As Integer, _

-               Supp() As Double, s() As Integer)

-' Определение линии поддержки по Демарку [1] (от конца)

-' Исходные данные:

-' Low, dom(Low) = [1, tE]

-' Результат:

-' 1) линия сопротивления Supp, dom(Supp)=[s(1), tE],

-' 2) s = {s(1), s(2), ..., s(nSupp)}, s(1) < s(2) < ...< s(nSupp) -

-'    опорные точки

-' 3) число опорных точек nSupp.

-' Прим. Если фактическое число опорных точек окажется < 2, то линия

-' поддержки не определяется.

- Dim t As Integer, i As Integer

- Dim v As Double

-'1 определение опорных моментов времени

- nSupp = 0

- For t = 2 To tE - 1

-'     v = min{Low(t-1), Low(t+1)} > Low(t)

-      v = Low(t - 1)

-      If v > Low(t + 1) Then

-         v = Low(t + 1)

-      End If

-      If Low(t) < v Then    'alt.: v >= High(t + 1)

-         s(nSupp + 1) = t: nSupp = nSupp + 1

-      End If

- Next t

- If nSupp < 2 Then

-    GoTo done

- End If

-' 2 определение линии поддержки

- Supp(s(1)) = Low(s(1))

- For i = 2 To nSupp

-    Supp(s(i)) = Low(s(i))

-    v = (Low(s(i)) - Low(s(i - 1))) / (s(i) - s(i - 1))

-    For t = s(i - 1) + 1 To s(i) - 1

-        Supp(t) = Low(s(i - 1)) + v * (t - s(i - 1))

-    Next t

- Next i

- If s(1) < tE Then

-    v = (Low(s(nSupp)) - Low(s(nSupp - 1))) / (s(nSupp) - s(nSupp - 1))

-    For t = s(nSupp) + 1 To tE

-        Supp(t) = Low(s(nSupp - 1)) + v * (t - s(nSupp - 1))

-    Next t

- End If

-done:

-End Sub

-

-Sub InitPriceData(p As PriceData, tE As Integer)

-' Инициализация данных по ценам

-  p.tC = tE

-  ReDim p.D(1 To tE)

-  ReDim p.Opn(1 To tE)

-  ReDim p.Hgh(1 To tE)

-  ReDim p.Lw(1 To tE)

-  ReDim p.Cls(1 To tE)

-  ReDim p.Vl(1 To tE)

-End Sub

-

-

-

-<<<<<<
-======================
-mTester1
->>>>>>
-Attribute VB_Name = "mTester1"

-Option Explicit

-Dim HISTORY As PriceData

-

-Sub Test1Denmark_Click()

-  

-  Dim nWin As Integer, nHist As Integer, _

-      theList As String, thePoint As String, _

-      Shift As Integer, pDen As Integer, pEMA As Integer

-' чтение данных-------------------------------

-  theList = Range("C4").Value     'Данные

-  thePoint = Range("C5").Value    'Начало

-  nHist = Range("C6").Value       'История

-  nWin = Range("C7").Value        'Окно

-  pEMA = Range("C8").Value        'порядок ск. среденего

-  Shift = Range("C9").Value       'смещение > 0

-  pDen = Range("C10").Value       'параметр Den

-' --------------------------------------------

-  Range("B16:H366").ClearContents

-

-' Определение элементов истории

-  InitPriceData p:=HISTORY, tE:=nHist   ' память под HISTORY

-  Worksheets(theList).Select            ' выбор листа с данными

-  ReadData1 aPoint:=thePoint, Hist:=HISTORY.tC, dt:=1, p:=HISTORY

-' Определены элементы истории цен  HISTORY

-  

-  Worksheets("Testing").Select

-  Dim Win As PriceData, Den As Denmark

-  InitPriceData Win, nWin  ' память под окно

-  InitDenmark Den, nWin    ' память под Den размер(Den) = размер(Win)

-  Den.pSig = pDen

-  

-  

-  Dim theRange As Range

-  Set theRange = ActiveSheet.Range("B16")  'Точка вывода осн. данных

-  

-  Dim t As Integer, i As Integer

-  Dim Sig As Integer, nSucc As Integer, nFall As Integer, Num As Integer

-  ReDim mov(1 To HISTORY.tC) As Double

-  Num = 0: nSucc = 0: nFall = 0

-  ExpMA1 HISTORY.Cls, 1, HISTORY.tC, 2 / (pEMA + 1), mov ' moving averige

-  

-  For t = Win.tC To HISTORY.tC - Shift   ' nWin  <= t <= P_DEN.tC

-'     Определение сигнала на момент t  по окну Win

-      Sig = DenSignal(t, Win, HISTORY, Den)

-      If Sig <> 0 Then

-         If Sig * Sign((mov(t + Shift) - mov(t))) >= 0 Then

-               nSucc = nSucc + 1

-         Else

-               nFall = nFall + 1

-         End If

-         Num = Num + 1

-      End If

-      theRange.Offset(t - nWin, 0).Value = t

-      theRange.Offset(t - nWin, 1).Value = HISTORY.D(t)

-      theRange.Offset(t - nWin, 2).Value = HISTORY.Opn(t)

-      theRange.Offset(t - nWin, 3).Value = HISTORY.Hgh(t)

-      theRange.Offset(t - nWin, 4).Value = HISTORY.Lw(t)

-      theRange.Offset(t - nWin, 5).Value = HISTORY.Cls(t)

-      If Sig <> 0 Then

-         theRange.Offset(t - nWin, 6).Value = Sig

-      End If

-  Next t

-  

-  Set theRange = ActiveSheet.Range("F4")  'Точка вывода осн. данных

-  theRange.Offset(0, 0).Value = Num

-  theRange.Offset(0, 1).Value = nSucc

-  theRange.Offset(0, 2).Value = nFall

-  theRange.Offset(0, 3).Value = nSucc / Num

-  

-  

-End Sub

-

-Function DenSignal(t As Integer, _

-                   Win As PriceData, _

-                   Hist As PriceData, _

-                   Den As Denmark) As Integer

-                   

-' Сигнал к покупке или продаже по Денмарку

-' исходные данные:

-' 1. t - момент времени, на который определяется сигнал

-'    win.tC <= t <= Hist.tC

-' 2. win.tC -размер временного окна, по которому определяются  линии Денмарка

-'    память под окно выделена.

-' 3. Hist - история, элементы истории полностью определены.

-' 4. Den.pSig - параметр сигнала, память для Den выделена

-' Результат:

-' DenSignal >= 1 -  сигнал к покупке ~ ожидается повышение

-' DenSignal =  0 -  сигнала нет

-' DenSignal <= -1 - сигнал к продаже ~ ожидается понижение

-' * Абсолютное значение DenSignal = числу реализованных квалификаторов

-

-' Определение окна

-  Dim i As Integer

-  For i = 1 To Win.tC

-      Win.D(i) = Hist.D(t - Win.tC + i)

-      Win.Cls(i) = Hist.Cls(t - Win.tC + i)

-      Win.Opn(i) = Hist.Opn(t - Win.tC + i)

-      Win.Hgh(i) = Hist.Hgh(t - Win.tC + i)

-      Win.Lw(i) = Hist.Lw(t - Win.tC + i)

-  Next i

-  DetDenmark Win, Den  'элементы Денмарка определены для t

-  If Den.Signal > 1 Then

-     DenSignal = Den.Signal - 1

-  End If

-  If Den.Signal < -1 Then

-     DenSignal = Den.Signal + 1

-  End If

-End Function

-

-Function Sign(x As Double) As Integer

-    Sign = 0

-    If x > 0 Then

-       Sign = 1

-    ElseIf x < 0 Then

-       Sign = -1

-    End If

-End Function

-

-' Экспоненциальное скользящее среднее

-Sub ExpMA1(x() As Double, t1 As Integer, t2 As Integer, alfa As Double, _

-           s() As Double)

-' x , dom(x) = [t1,t2], - исходный ряд

-' 0 <= alfa <= 1 - порядок сглаживания

-' alfa = 2/(nWin+1)

-' alfa <= 0 --> s = 0; alfa => 1 s = x

-' Результат: S , dom(S) = [t1,t2], - скользящее среднее

-Dim S0 As Double, beta As Double

-Dim k As Integer, t As Integer

-' S0 determination

-If alfa <= 0 Then

-   For t = t1 To t2

-      s(t) = 0

-   Next t

-   GoTo done

-End If

-If alfa >= 1 Then

-   For t = t1 To t2

-      s(t) = x(t)

-   Next t

-   GoTo done

-End If

-S0 = 0

-k = 5    ' порядок усреднения, k < (t2-t1+1)/2  !!!

-For t = t1 To t1 + k - 1

-    S0 = S0 + x(t)

-Next t

-S0 = S0 / k

-'main cycle

-beta = 1 - alfa

-s(t1) = alfa * x(t1) + beta * S0

-For t = t1 + 1 To t2

-    s(t) = alfa * x(t) + beta * s(t - 1)

-Next t

-done:

-End Sub

-

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'Denmark_method'
-Quirk - duff tag length======================
-MGetWebData
->>>>>>
-Attribute VB_Name = "MGetWebData"

-Option Explicit

-

-Dim mobjAppRunEnable As New cEnableRun

-

-Const QueryDataName As String = "ExternalDenmarkData"

-

-Function UpdateHistoryFromWeb(wb As Workbook) As Boolean

-    Dim DestRangeName As String

-    Dim ResultLength As Integer

-    Dim QryPathStr As String

-    Dim Location As Range

-    Dim denWindow As Integer

-    Dim IsIntraday As Boolean

-    Dim CalcNextTime As Boolean

-        

-    UpdateHistoryFromWeb = False

-    QryPathStr = GetQryPath(wb)

-    With wb

-        .Application.ScreenUpdating = False

-        With .Worksheets(VAR_SHEET)

-            DestRangeName = .Range("DEN_SYMBOL")

-            CalcNextTime = .Range("BOOL_NEXT_TIME")

-            denWindow = .Range("DEN_WINDOW")

-            If CalcNextTime Then

-                denWindow = denWindow + 1

-            End If

-            IsIntraday = IsNumeric(.Range("DEN_TIME"))

-        End With

-        With .Worksheets(RAW_DATA_SHEET)

-            .Range(PRICE_TABLE) = DestRangeName

-            'Clear table and temp area

-            With .Range( _

-                .Cells(RAW_DATA_RANGE_ROW - 1, RAW_DATA_RANGE_COL - 1), _

-                .Cells(65535, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE))

-                .ClearContents

-                .NumberFormat = "General"

-            End With

-            

-            Set Location = .Range(RAW_DATA_RANGE).Offset(-1, 0)

-            If Not QryExist(Location, QueryDataName) Then

-                QryCreate Location, QueryDataName, QryPathStr

-            Else

-                QryRefresh Location, QueryDataName, QryPathStr

-            End If

-            With Location.Worksheet.QueryTables(QueryDataName)

-                DestRangeName = .ResultRange.Name.RefersTo

-                ResultLength = .ResultRange.count

-            End With

-    

-'            .Parent.Application.DisplayAlerts = False

-    

-            If ResultLength < denWindow Then

-                Exit Function

-            End If

-            

-            .Range(DestRangeName).TextToColumns _

-                Destination:=Range(DestRangeName), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=True, _

-                Space:=False, _

-                Other:=False, _

-                OtherChar:="|", _

-                FieldInfo:=Array( _

-                                Array(1, xlSkipColumn), _

-                                Array(2, xlTextFormat), _

-                                Array(3, xlGeneralFormat), _

-                                Array(4, xlGeneralFormat), _

-                                Array(5, xlGeneralFormat), _

-                                Array(6, xlGeneralFormat), _

-                                Array(7, xlGeneralFormat), _

-                                Array(8, xlSkipColumn), _

-                                Array(9, xlSkipColumn), _

-                                Array(10, xlSkipColumn), _

-                                Array(11, xlSkipColumn), _

-                                Array(12, xlSkipColumn))

-            

-            .Range(DestRangeName).EntireColumn.AutoFit

-            

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(65536, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-            ).NumberFormat = "General"

-            

-            Dim RawData As Range

-            Dim row_idx As Integer

-            

-            Set RawData = .Range(DestRangeName).Offset(0, 1)

-            RawData.Insert Shift:=xlToRight

-            

-            If Not IsIntraday Then

-                Set RawData = RawData.Offset(0, -1)

-                RawData.Value = "18:00"

-                RawData.Cells(1, 1).FormulaR1C1 = "TIME"

-                Set RawData = RawData.Offset(0, -1)

-            Else

-                Set RawData = RawData.Offset(0, -2)

-                RawData.TextToColumns _

-                    Destination:=RawData, _

-                    DataType:=xlDelimited, _

-                    TextQualifier:=xlDoubleQuote, _

-                    ConsecutiveDelimiter:=False, _

-                    Tab:=False, _

-                    Semicolon:=False, _

-                    Comma:=False, _

-                    Space:=True, _

-                    Other:=False, _

-                    OtherChar:="/", _

-                    FieldInfo:=Array( _

-                                    Array(1, xlTextFormat), _

-                                    Array(2, xlTextFormat))

-                RawData.Cells(1, 2).FormulaR1C1 = "TIME"

-            End If

-            

-'            Dim end_date As Date

-'            end_date = RawData.Cells(ResultLength, 1).FormulaR1C1

-

-' Delete unused space

-            

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW + ResultLength, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(65536, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-            ).ClearContents

-            

-            Dim i As Integer

-' Delete blank intervals

-            

-            Set RawData = .Range(RAW_DATA_RANGE).Offset(0, 0)

-            row_idx = 0

-            For i = 1 To ResultLength

-                ' skip virtual prices

-                If RawData.Offset(row_idx, CLOSE_IDX).Value > MIN_PRICE_VALUE Then

-                    row_idx = row_idx + 1

-                Else

-                    Set Location = .Range( _

-                            .Cells(row_idx + RAW_DATA_RANGE_ROW, DATE_IDX + RAW_DATA_RANGE_COL), _

-                            .Cells(row_idx + RAW_DATA_RANGE_ROW, PROJECT_IDX + RAW_DATA_RANGE_COL) _

-                    )

-                    Location.Delete xlShiftUp

-                End If

-            Next i

-            

-            ResultLength = GetLinesCount(.Range(RAW_DATA_RANGE))

-            

-            row_idx = ResultLength - 1

-            If row_idx > denWindow Then

-                row_idx = row_idx - denWindow

-                .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-                ).Delete xlShiftUp

-            Else

-                Exit Function

-            End If

-            

-            Dim TmpStr As String

-                        

-            row_idx = GetLinesCount(.Range(RAW_DATA_RANGE))

-            

-            Set RawData = .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx - 1, RAW_DATA_RANGE_COL + DATE_IDX) _

-                )

-            RawData.TextToColumns _

-                Destination:=.Range(RAW_DATA_RANGE).Offset(0, DATE_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:="-", _

-                FieldInfo:=Array( _

-                                Array(1, xlTextFormat), _

-                                Array(2, xlTextFormat), _

-                                Array(3, xlTextFormat))

-            

-            Set Location = .Range(RAW_DATA_RANGE).Offset(0, -1)

-            

-            If IsIntraday Then

-                Set RawData = .Range( _

-                            .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + TIME_IDX), _

-                            .Cells(RAW_DATA_RANGE_ROW + row_idx - 1, RAW_DATA_RANGE_COL + TIME_IDX) _

-                    )

-                RawData.TextToColumns _

-                    Destination:=.Range(RAW_DATA_RANGE).Offset(0, TIME_STAMP_OFFSET), _

-                    DataType:=xlDelimited, _

-                    TextQualifier:=xlDoubleQuote, _

-                    ConsecutiveDelimiter:=False, _

-                    Tab:=False, _

-                    Semicolon:=False, _

-                    Comma:=False, _

-                    Space:=False, _

-                    Other:=True, _

-                    OtherChar:=":", _

-                    FieldInfo:=Array( _

-                                    Array(1, xlTextFormat), _

-                                    Array(2, xlTextFormat), _

-                                    Array(3, xlTextFormat))

-                                    

-                

-                For i = 0 To row_idx - 1

-                    Location.Offset(i, 0) = "'" & _

-                            .Range(RAW_DATA_RANGE).Offset(i, DATE_STAMP_OFFSET + 1).Value _

-                            & "/" & .Range(RAW_DATA_RANGE).Offset(i, DATE_STAMP_OFFSET + 2).Value _

-                            & "-" & .Range(RAW_DATA_RANGE).Offset(i, TIME_STAMP_OFFSET).Value _

-                            & ":" & .Range(RAW_DATA_RANGE).Offset(i, TIME_STAMP_OFFSET + 1).Value

-                Next

-            Else

-                For i = 0 To row_idx - 1

-                    Location.Offset(i, 0) = "'" & _

-                            .Range(RAW_DATA_RANGE).Offset(i, DATE_STAMP_OFFSET + 2).Value _

-                            & "/" & .Range(RAW_DATA_RANGE).Offset(i, DATE_STAMP_OFFSET + 1).Value _

-                            & "/" & .Range(RAW_DATA_RANGE).Offset(i, DATE_STAMP_OFFSET).Value

-                Next

-            End If

-            .Parent.Application.DisplayAlerts = True

-        End With ' .Worksheets(RAW_DATA_SHEET)

-    End With ' wb

-    UpdateHistoryFromWeb = True

-End Function

-

-Private Function GetQryPath(wb As Workbook) As String

-    Dim QryPathStr As String

-    Dim IsIntradai As Boolean

-    Dim DayCount As Integer

-    Const DataFormat As String = "&data_format=BROWSER"

-    With wb.Worksheets(VAR_SHEET)

-        IsIntradai = IsNumeric(.Range("DEN_TIME"))

-        

-        If IsIntradai Then

-        

-            QryPathStr = "URL;http://export.rbc.ru/export/"

-            QryPathStr = QryPathStr & .Range("DEN_SOURCE")

-            QryPathStr = QryPathStr & "." & .Range("DEN_BOARD")

-            QryPathStr = QryPathStr & "/?"

-            

-            QryPathStr = QryPathStr & "tickers=" & .Range("DEN_SYMBOL")

-            QryPathStr = QryPathStr & "&period=" & .Range("DEN_TIME")

-            QryPathStr = QryPathStr & "&virtual=PASS"

-            DayCount = .Range("DEN_HISTORY") * .Range("DEN_TIME") \ 420 + 1

-            QryPathStr = QryPathStr & "&lastdays=" & DayCount

-            QryPathStr = QryPathStr & "&separator=,"

-            QryPathStr = QryPathStr & DataFormat

-            QryPathStr = QryPathStr & "&header=1"

-        Else

-            QryPathStr = "URL;http://export.rbc.ru/cgi-bin/export/query_version/export.cgi?"

-            QryPathStr = QryPathStr & "&sourcename=" & .Range("DEN_SOURCE")

-            QryPathStr = QryPathStr & "." & .Range("DEN_BOARD")

-            QryPathStr = QryPathStr & "&tickers=" & .Range("DEN_SYMBOL")

-            QryPathStr = QryPathStr & "&period=DAILY"

-            QryPathStr = QryPathStr & "&virtual=PASS"

-            QryPathStr = QryPathStr & "&lastdays=" & .Range("DEN_HISTORY") + 1

-            QryPathStr = QryPathStr & "&separator=,"

-            QryPathStr = QryPathStr & DataFormat

-            QryPathStr = QryPathStr & "&header=1"

-        End If

-    .Range("LAST_HIST_QRY") = QryPathStr

-    End With

-    GetQryPath = QryPathStr

-End Function

-

-Sub UpdateTickerList(wb As Workbook)

-    Dim Idx, n As Integer

-    Dim ResultLength As Integer

-    Dim Location As Range

-    Dim QryPathStr As String

-    Dim QueryDataName As String

-    Dim DestRangeArea As String

-    

-    QryPathStr = GetListPath(wb)

-    With wb

-        With .Worksheets(VAR_SHEET)

-            Idx = .Range("IDX_DEN_LIST")

-            Set Location = .Range("TICKER_TABLES").Offset(0, (Idx - 1) * 2)

-             .Range("IDX_DEN_SYMBOL") = 1

-            QueryDataName = Location.Offset(0, 0)

-            'Clear table

-            .Range(Location.Offset(1, 0), Location.Offset(65535 - Location.Row, 1)).ClearContents

-            

-            If Not QryExist(Location.Offset(1, 0), QueryDataName) Then

-                QryCreate Location.Offset(1, 0), QueryDataName, QryPathStr

-            Else

-                QryRefresh Location.Offset(1, 0), QueryDataName, QryPathStr

-            End If

-            

-            With .QueryTables(QueryDataName)

-                DestRangeArea = .ResultRange.Name.RefersTo

-                ResultLength = .ResultRange.count

-            End With

-        

-            .Parent.Application.DisplayAlerts = False

-                

-            .Range(DestRangeArea).TextToColumns _

-                Destination:=.Range(DestRangeArea), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:=":", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 9))

-        ' Sort Data

-            Set Location = .Range(.Range(DestRangeArea).Offset(0, 0), .Range(DestRangeArea).Offset(ResultLength - 1, 1))

-            Location.Sort _

-                Key1:=.Range(DestRangeArea).Offset(0, 0), _

-                Order1:=xlAscending, _

-                Header:=xlNo, _

-                OrderCustom:=1, _

-                MatchCase:=False, _

-                Orientation:=xlTopToBottom

-        End With

-        ' Setup Ticker List

-         With .Worksheets(VAR_SHEET)

-            DestRangeArea = .Name & "!" & .Range(.Range(DestRangeArea).Cells(1, 1), .Range(DestRangeArea).Cells(ResultLength - 1, 1)).Address

-         End With

-        With .Worksheets(FORM_SHEET).Shapes("cbxTikers").ControlFormat

-            .ListFillRange = DestRangeArea

-            .ListIndex = 1

-        End With

-        ' Setup Name List

-         With .Worksheets(VAR_SHEET)

-            DestRangeArea = .Name & "!" & .Range(.Range(DestRangeArea).Cells(1, 1), .Range(DestRangeArea).Cells(ResultLength - 1, 1)).Offset(0, 1).Address

-         End With

-        With .Worksheets(FORM_SHEET).Shapes("cbxSecName").ControlFormat

-            .ListFillRange = DestRangeArea

-            .ListIndex = 1

-        End With

-        .Parent.Application.DisplayAlerts = True

-    End With

-End Sub

-

-Private Function GetListPath(wb As Workbook) As String

-    Dim QryPathStr As String

-    With wb.Worksheets(VAR_SHEET)

-        QryPathStr = "URL;http://export.rbc.ru/cgi-bin/export/tickers.cgi?"

-        QryPathStr = QryPathStr & "&source=" & .Range("DEN_SOURCE")

-        QryPathStr = QryPathStr & "." & .Range("DEN_BOARD")

-        .Range("LAST_DIR_QRY") = QryPathStr

-    End With

-    GetListPath = QryPathStr

-End Function

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    Set MyAppEvents.app = Application

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    If Application.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEL сейчас будут закрыты!", vbOKCancel, "$" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close Savechanges:=False

-            Exit Sub

-        End If

-    End If

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False

-    cmSetStandaloneMode

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment wb:=ThisWorkbook, DesignMode:=False

-        If ThisWorkbook.Saved = False Then

-            ThisWorkbook.Save

-        End If

-    End If

-    Application.Caption = Empty

-    Application.CommandBars("Worksheet Menu Bar").Reset

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-        Dim MaxX, MaxY As Integer

-        With ThisWorkbook.Worksheets(FORM_SHEET)

-            MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-            MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-        End With

-

-        With ThisWorkbook.Application

-            .ScreenUpdating = False

-            .WindowState = xlNormal

-            .Height = MaxY

-            .Width = MaxX

-        End With

-End Sub

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mReadWrite
->>>>>>
-Attribute VB_Name = "mReadWrite"

-Option Explicit

-

-Public Const GOOD_LINE_STATUS As String = "Ok"

-Public Const BAD_LINE_STATUS As String = "N/A"

-

-Function ReadPricesData(Location As Range, Hist As Integer, dt As Integer, _

-              pPriceData As TPriceData) As Integer

-    'Инициализация типа TPriceData из таблицы типа - 1

-    'kопируются не более чем hist последних строк

-    'aPoint - начало таблицы

-    'первые две строки таблицы идентифицирует данные (строки)

-    Dim n, i As Integer

-    

-    'Определение числа строк таблицы - n

-    n = GetLinesCount(Location)

-    ReadPricesData = n

-    If n < 9 Then             'обработать ошибку !!!

-        GoTo done

-    End If

-    ' число строк определено ()

-    If Hist > (n - 3) \ dt + 1 Then ' коррекция истории

-        Hist = (n - 3) \ dt + 1 '

-    End If

-    Dim t, s As Integer

-    For t = 0 To Hist - 1

-        s = n - t * dt - 1

-        pPriceData.D(Hist - t) = Location.Offset(s, DATE_IDX).Value

-        pPriceData.Tm(Hist - t) = Location.Offset(s, TIME_IDX).Value

-        pPriceData.Opn(Hist - t) = Location.Offset(s, OPEN_IDX).Value

-        pPriceData.Hgh(Hist - t) = Location.Offset(s, HIGH_IDX).Value

-        pPriceData.Lw(Hist - t) = Location.Offset(s, LOW_IDX).Value

-        pPriceData.Cls(Hist - t) = Location.Offset(s, CLOSE_IDX).Value

-        pPriceData.Vl(Hist - t) = Location.Offset(s, VOLUME_IDX).Value

-    Next t

-    ReadPricesData = t + 1

-done:

-End Function

-

-Sub ResultLinesOut(Location As Range, pPD As TPriceData, pDen As TDenmark)

-    Dim n As Integer

-    

-    n = GetLinesCount(Location)

-    With Location

-        .Offset(-1, RESIST_IDX) = "Resistance"

-        .Offset(-1, SUPPORT_IDX) = "Support"

-        .Offset(-1, PROJECT_IDX) = "Project"

-    End With

-    Dim t, count, Idx, loc_idx As Integer

-    count = pPD.tC

-    For t = 0 To count - 1

-        Idx = count - t

-        loc_idx = n - t - 1

-        If pDen.ResistanceLine(Idx) > MIN_PRICE_VALUE Then

-            Location.Offset(loc_idx, RESIST_IDX).Value = pDen.ResistanceLine(Idx)

-        End If

-        If pDen.SupportLine(Idx) > MIN_PRICE_VALUE Then

-            Location.Offset(loc_idx, SUPPORT_IDX).Value = pDen.SupportLine(Idx)

-        End If

-        If Abs(pDen.SignalValue) > 1 Then

-            Location.Offset(loc_idx, PROJECT_IDX).Value = pDen.ProjectPrice

-        End If

-    Next t

-End Sub

-

-Sub Out_Table_1(TheRange As Range, pDen As TDenmark, LastIdx As Integer)

-    

-    

-    ' Col = 2 - не определен !!!

-    ' Status - Col = 0

-    If pDen.ResistancePointCount >= 2 Then

-        TheRange.Offset(0, 0).Value = GOOD_LINE_STATUS

-    Else

-        TheRange.Offset(0, 0).Value = BAD_LINE_STATUS

-    End If

-    If pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(1, 0).Value = GOOD_LINE_STATUS

-    Else

-        TheRange.Offset(1, 0).Value = BAD_LINE_STATUS

-    End If

-    ' -----------------------------------------

-    ' углы наклонов линии сопротивления и поддержки - Col = 1

-    If pDen.ResistancePointCount >= 2 Then

-        TheRange.Offset(0, 1).Value = pDen.ResistanceAngle

-    End If

-    If pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(1, 1).Value = pDen.SupportAngle

-    End If

-    If pDen.ResistancePointCount >= 2 And pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(2, 1).Value = (pDen.ResistanceAngle + pDen.SupportAngle) / 2

-    End If

-    ' -----------------------------------------

-    ' Опорные цены линий денмарка на текущий момент

-    If pDen.ResistancePointCount >= 2 Then

-        TheRange.Offset(0, 2).Value = pDen.ResistanceLine(LastIdx)

-    End If

-    If pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(1, 2).Value = pDen.SupportLine(LastIdx)

-    End If

-    If pDen.ResistancePointCount >= 2 And pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(2, 2).Value = _

-            (pDen.ResistanceLine(LastIdx) + pDen.SupportLine(LastIdx)) / 2

-    End If

-    

-End Sub

-

-Sub Out_Table_2(TheRange As Range, TheComment As Range, pPD As TPriceData, pDen As TDenmark)

-    Const ColorIndexBUY = 5

-    Const ColorIndexSELL = 3

-    Const ColorIndexNOTHINK = 14

-    

-    Dim SignalValue_defined, allert_enable  As Boolean

-    Dim Message As String

-    SignalValue_defined = False

-    allert_enable = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_ALLERT_DLG")

-    Message = "Сигнал об изменении тренда не идентифицирован."

-    If pDen.SignalValue >= 2 Then

-        SignalValue_defined = True

-        With TheRange.Offset(0, 0)

-            .Value = "BUY"

-            .Font.Bold = True

-            .Font.ColorIndex = ColorIndexBUY

-        End With

-        TheRange.Offset(0, 1).Value2 = pPD.D(pPD.tC)

-        TheRange.Offset(0, 2).Value2 = pPD.Tm(pPD.tC)

-        TheRange.Offset(0, 3).Value = pDen.SignalValue - 1

-        TheRange.Offset(0, 4).Value = pDen.ProjectPrice

-        Message = "BUY Signal: возможен прорыв вверх нисходящего тренда с уровнем значимости = " & pDen.SignalValue - 1 & " ! "

-    End If

-    If pDen.SignalValue <= -2 Then

-        SignalValue_defined = True

-        With TheRange.Offset(0, 0)

-            .Value = "SELL"

-            .Font.Bold = True

-            .Font.ColorIndex = ColorIndexSELL

-        End With

-        TheRange.Offset(0, 1).Value2 = pPD.D(pPD.tC)

-        TheRange.Offset(0, 2).Value2 = pPD.Tm(pPD.tC)

-        TheRange.Offset(0, 3).Value = pDen.SignalValue + 1

-        TheRange.Offset(0, 4).Value = pDen.ProjectPrice

-        Message = "SELL Signal: возможен прорыв вниз восходящего тренда с уровнем значимости = " & -(pDen.SignalValue + 1) & "!"

-    End If

-    With TheComment

-        .Value = Message

-        .Font.Bold = True

-        Dim color_idx As Integer

-        If SignalValue_defined Then

-            If pDen.SignalValue > 0 Then

-                .Font.ColorIndex = ColorIndexBUY

-            Else

-                .Font.ColorIndex = ColorIndexSELL

-            End If

-        Else

-            .Font.ColorIndex = ColorIndexNOTHINK

-        End If

-    End With

-    If allert_enable And SignalValue_defined Then

-        MsgBox _

-            Prompt:=Message, _

-            Title:=PROGRAM_NAME, _

-            Buttons:=vbOKOnly + vbInformation

-    End If

-End Sub

-

-Sub Out_Table_3(TheRange As Range, pDen As TDenmark)

-    Dim i As Integer

-    For i = 1 To 3

-        TheRange.Offset(i - 1, 0).Value = pDen.Qualificator(i)

-    Next i

-End Sub

-

-Sub Out_Table_4(TheRange As Range, pPD As TPriceData)

-    Dim LastIdx As Integer

-    LastIdx = pPD.tC

-    With TheRange

-        .Offset(0, 0).Value2 = "'" & pPD.D(LastIdx)

-        .Offset(0, 1).Value2 = "'" & pPD.Tm(LastIdx)

-        .Offset(0, 2) = pPD.Opn(LastIdx)

-        .Offset(0, 3) = pPD.Hgh(LastIdx)

-        .Offset(0, 4) = pPD.Lw(LastIdx)

-        .Offset(0, 5) = pPD.Cls(LastIdx)

-        .Offset(0, 6) = pPD.Cls(LastIdx) - pPD.Cls(LastIdx - 1)

-    End With

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Denmark method bar"

-Public Const common_pwd As Long = 31415926

-

-

-Sub SetEnvironment(wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    With Application

-        .Caption = PROGRAM_NAME

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .GetState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-    End With

-    With wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(FORM_SHEET).Select

-    End With

-    CreateCommandBar theApp:=wb.Application

-End Sub

-

-Sub RestoreEnvironment(wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Application.ScreenUpdating = False

-    With wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                     cWindow.DisplayHeadings = True

-                Next

-            End If

-        Next

-        .Worksheets(FORM_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu (True)

-        End If

-        With mobjAppState

-            .RestoreState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(wb As Workbook)

-    With wb

-        .Application.ScreenUpdating = False

-        

-        With .Worksheets(RAW_DATA_SHEET)

-            .Visible = xlVeryHidden

-            .Protect Password:=common_pwd, userInterfaceOnly:=True, Contents:=False

-        End With

-        With .Worksheets(VAR_SHEET)

-            .Visible = xlVeryHidden

-            .Protect Password:=common_pwd, userInterfaceOnly:=True, Contents:=False

-        End With

-        With .Worksheets(FORM_SHEET)

-            .EnableSelection = xlNoSelection

-            .Protect userInterfaceOnly:=True

-            .Select

-        End With

-        With .Worksheets(CHART_SHEET)

-            .EnableSelection = xlNoSelection

-            .Protect userInterfaceOnly:=True

-        End With

-        .Protect Windows:=True

-        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(wb As Workbook)

-    With wb

-        .Unprotect

-        .Application.ScreenUpdating = False

-        With .Worksheets(RAW_DATA_SHEET)

-            .Visible = xlVeryHidden

-            .Unprotect Password:=common_pwd

-        End With

-        With .Worksheets(VAR_SHEET)

-            .Visible = xlVeryHidden

-            .Unprotect Password:=common_pwd

-        End With

-        With .Worksheets(CHART_SHEET)

-            .Select

-            .Unprotect

-        End With

-        With .Worksheets(FORM_SHEET)

-            .Select

-            .Unprotect

-        End With

-        .Application.ScreenUpdating = True

-        

-    End With

-End Sub

-

-<<<<<<
-======================
-mTypes
->>>>>>
-Attribute VB_Name = "mTypes"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Метод г-на Демарка II"

-Public Const PROGRAM_VERSION As String = "version 4.1 Professional"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-

-Public Const ESTIMATION_DATE As Long = 20010615

-'Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "J27"

-

-Public Const RAW_DATA_SHEET As String = "Raw_data"

-Public Const PRICE_TABLE As String = "B1"

-Public Const RAW_DATA_RANGE As String = "B3"

-Public Const RAW_DATA_RANGE_COL As Integer = 2

-Public Const RAW_DATA_RANGE_ROW As Integer = 3

-

-Public Const VAR_SHEET As String = "Var_s"

-

-Public Const CHART_SHEET As String = "Chart"

-

-Public Const MIN_PRICE_VALUE As Double = 0.000001

-Public Const MAX_PRICE_VALUE As Double = 1000000000

-

-' Fields indexes in RAW_DATA_RANGE

-Public Const DATE_IDX As Integer = 0

-Public Const TIME_IDX As Integer = 1

-Public Const OPEN_IDX As Integer = 2

-Public Const HIGH_IDX As Integer = 3

-Public Const LOW_IDX As Integer = 4

-Public Const CLOSE_IDX As Integer = 5

-Public Const VOLUME_IDX As Integer = 6

-Public Const RESIST_IDX As Integer = 7

-Public Const SUPPORT_IDX As Integer = 8

-Public Const PROJECT_IDX As Integer = 9

-

-Public Const DATE_STAMP_OFFSET = PROJECT_IDX + 1

-Public Const TIME_STAMP_OFFSET = PROJECT_IDX + 4

-Public Const DATE_TIME_STAMP_SIZE = 5

-

-Type TPriceData

-    D() As String      ' календарная дата

-    Tm() As String     ' время

-    Opn() As Double    ' Open

-    Hgh() As Double    ' High

-    Lw() As Double     ' Low

-    Cls() As Double    ' Close

-    Vl() As Double     ' Volume

-    tC As Integer      ' Current time

-End Type

-

-Type TDenmark

-   ResistanceLine() As Double           'Resistance line

-   ResistancePoints() As Integer        'Resistance pivot points

-   ResistancePointCount As Integer      'The number of resistance pivot points

-   ResistanceAngle As Double            'Angle of Declination of ResistanceLine

-   

-   SupportLine() As Double              'Support line

-   SupportPoints() As Integer           'Support pivot points

-   SupportPointsCount As Integer        'The number of support pivot points

-   SupportAngle As Double               ' Angle of Declination of SupportLine

-   

-   SignalParameter     As Integer       ' parameter for SignalValue

-   SignalValue      As Integer          'SignalValue

-   

-   

-   Qualificator(1 To 3) As String       ' qualificators

- 

-   ProjectNumber As Integer             ' номер проекции

-   ProjectPrice  As Double              ' проекция цены

-   

-End Type

-

-

-<<<<<<
-======================
-mCommands
->>>>>>
-Attribute VB_Name = "mCommands"

-Option Explicit

-Dim AppRunEnable As New cEnableRun

-

-Sub evParamChange()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DEMARK_READY") = False

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_AUTORECALC") = True Then

-        evSubmit_Click

-    End If

-End Sub

-

-Sub cmViewChart(Optional SwapPage As Boolean = True)

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("BOOL_CHART_READY") = False

-        If .Range("BOOL_DEMARK_READY") <> True Then

-            If .Range("BOOL_AUTORECALC") = True Then

-                evSubmit_Click

-                If .Range("BOOL_DEMARK_READY") <> True Then

-                    Exit Sub

-                End If

-            Else

-                MsgBox _

-                    "График не может быть построен." & vbCrLf & "Исходные данные не обработаны.", _

-                    vbOKOnly + vbExclamation, _

-                    PROGRAM_NAME

-                Exit Sub

-            End If

-        End If

-    End With

-    With ThisWorkbook.Worksheets(FORM_SHEET)

-        With .Range("TABLE_1")

-            Dim test_lines As Boolean

-            test_lines = StrComp(.Cells(1, 1).Value, GOOD_LINE_STATUS)

-            test_lines = test_lines + StrComp(.Cells(2, 1).Value, GOOD_LINE_STATUS)

-            If test_lines <> 0 Then

-                MsgBox _

-                    Prompt:="График не может быть построен." & vbCrLf & "Опорные точки не определены .", _

-                    Title:=PROGRAM_NAME, _

-                    Buttons:=vbOKOnly + vbExclamation

-                Exit Sub

-            End If

-        End With

-        Draw_Chart Not IsEmpty(.Range("TABLE_2").Cells(1, 1))

-    End With

-    With ThisWorkbook

-        .Worksheets(VAR_SHEET).Range("BOOL_CHART_READY") = True

-        If SwapPage Then

-            .Worksheets(CHART_SHEET).Select

-        End If

-    End With

-End Sub

-

-Sub cmViewForm()

-    With ThisWorkbook

-        .Worksheets(FORM_SHEET).Select

-    End With

-End Sub

-

-Sub cmCloseProgram()

-    Dim ResistanceLine

-    ResistanceLine = MsgBox( _

-        Prompt:="Вы желаете завершить программу?", _

-        Buttons:=vbQuestion + vbYesNo, _

-        Title:=PROGRAM_NAME _

-    )

-    If ResistanceLine = vbYes Then

-       Application.Quit

-    End If

-End Sub

-

-Sub cmAbout()

-    dlgAbout.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlgAbout.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlgAbout.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlgAbout.Show

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-        helppath = "hh.exe " & .Path & "\Demark.chm"

-        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub cmSetStandaloneMode()

-    Application.ScreenUpdating = False

-    ProtectionDisable wb:=ThisWorkbook

-    SetEnvironment wb:=ThisWorkbook

-    ProtectionEnable wb:=ThisWorkbook

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    rp = common_pwd

-    dlgGetPwd.edPwd = ""

-    dlgGetPwd.Show

-    If dlgGetPwd.edPwd = rp Then

-        ProtectionDisable wb:=ThisWorkbook

-        RestoreEnvironment wb:=ThisWorkbook, DesignMode:=True

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmPrint()

-    If MsgBox( _

-            Prompt:="Вы желаете распечатать результат?", _

-            Buttons:=vbYesNo + vbQuestion, _

-            Title:=PROGRAM_NAME) = vbNo _

-    Then

-        Exit Sub

-    End If

-    Dim s_ticker, s_name, s_time As String

-    s_ticker = ThisWorkbook.Worksheets(FORM_SHEET).Range("CALC_TICKER_NAME")

-    s_name = ThisWorkbook.Worksheets(FORM_SHEET).Range("CALC_NAME")

-    s_time = Now

-    Application.ScreenUpdating = False

-    cmViewChart SwapPage:=False

-    Application.ScreenUpdating = False

-    With ThisWorkbook.Worksheets(FORM_SHEET).PageSetup

-        .LeftHeader = s_ticker

-        .CenterHeader = PROGRAM_NAME

-        .RightHeader = s_time

-        .LeftFooter = s_name

-        .CenterFooter = "Page &P of &N"

-        .RightFooter = ""

-        .LeftMargin = Application.InchesToPoints(0.75)

-        .RightMargin = Application.InchesToPoints(0.75)

-        .TopMargin = Application.InchesToPoints(0.78)

-        .BottomMargin = Application.InchesToPoints(0.92)

-        .HeaderMargin = Application.InchesToPoints(0.5)

-        .FooterMargin = Application.InchesToPoints(0.5)

-        .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 = 2

-    End With

-    With ThisWorkbook.Worksheets(CHART_SHEET).PageSetup

-        .LeftHeader = s_ticker

-        .CenterHeader = PROGRAM_NAME

-        .RightHeader = s_time

-        .LeftFooter = s_name

-        .CenterFooter = "Page &P of &N"

-        .RightFooter = ""

-        .LeftMargin = Application.InchesToPoints(0.75)

-        .RightMargin = Application.InchesToPoints(0.75)

-        .TopMargin = Application.InchesToPoints(0.78)

-        .BottomMargin = Application.InchesToPoints(0.92)

-        .HeaderMargin = Application.InchesToPoints(0.5)

-        .FooterMargin = Application.InchesToPoints(0.5)

-        .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 = 2

-    End With

-    Application.ScreenUpdating = False

-    ThisWorkbook.Worksheets(Array("MainForm", "Chart")).PrintOut Copies:=1, Collate:=True

-    cmViewForm

-End Sub

-<<<<<<
-======================
-mDemark
->>>>>>
-Attribute VB_Name = "mDemark"

-Option Explicit

-

-Public Const FORM_SHEET As String = "MainForm"

-

-'Form Ranges

-Public Const FILE_NAME As String = "FILE_NAME"

-Public Const TABLE_1 As String = "TABLE_1"

-Public Const TABLE_2 As String = "TABLE_2"

-Public Const TABLE_3 As String = "TABLE_3"

-Public Const TABLE_4 As String = "TABLE_4"

-Public Const TABLE_COMMENT As String = "TABLE_COMMENT"

-

-'Основной тип данных - стандарт 1

-

-'*********************

-Dim PriceDataArray As TPriceData

-Dim DenmarkDataArray As TDenmark

-

-Dim mobjAppRunEnable As New cEnableRun

-

-Sub ClearResultTables()

-    With ThisWorkbook.Worksheets(FORM_SHEET)

-        .Range(TABLE_1).ClearContents ' таблица-1

-        .Range(TABLE_2).ClearContents ' таблица-2

-        .Range(TABLE_3).ClearContents ' таблица-3

-        .Range(TABLE_COMMENT).Value = "" ' коментарий-3

-        .Range(TABLE_4).ClearContents ' таблица-4

-    End With

-End Sub

-

-Function TDenmark_Calc() As Boolean

-    

-    Dim nWindow As Integer

-    Dim bPrevCloseFilter, bSuccCloseFilter As Boolean

-    

-    TDenmark_Calc = False

-    

-    mobjAppRunEnable.EnableRun ESTIMATION_DATE, Now

-    

-    With ThisWorkbook

-        .Application.ScreenUpdating = False

-'1)    Read User data

-        With .Worksheets(VAR_SHEET)

-            DenmarkDataArray.ProjectNumber = .Range("DEN_PROECT").Value

-            DenmarkDataArray.SignalParameter = .Range("DEN_PARAM").Value

-            nWindow = .Range("DEN_WINDOW").Value

-            bPrevCloseFilter = .Range("BOOL_PREV_CLOSE").Value

-            bSuccCloseFilter = .Range("BOOL_SUCC_CLOSE").Value

-        End With

-

-'2)   Memory allocation

-        allocate_memory PriceDataArray, DenmarkDataArray, nWindow

-

-'3)   Read data

-        Dim TheRange As Range

-        Set TheRange = .Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE)

-        Dim LinesCount As Integer

-        LinesCount = ReadPricesData(Location:=TheRange, Hist:=PriceDataArray.tC, dt:=1, pPriceData:=PriceDataArray)

-        

-        'Init function result

-        TDenmark_Calc = LinesCount >= nWindow

-        

-        If LinesCount >= nWindow Then

-        

-'4)   Calculate metod TDenmarkDataArray

-            DetDenmark PriceDataArray, DenmarkDataArray, bPrevCloseFilter, bSuccCloseFilter

-            If Abs(DenmarkDataArray.SignalValue) > 1 Then  'ценовые ориентиры, если есть сигнал

-                DetProj PriceDataArray, DenmarkDataArray

-            End If

-'5)   Write result

-            Application.ScreenUpdating = False

-    

-'6)    Clear interface tables

-            ClearResultTables

-            

-            ResultLinesOut Location:=TheRange.Offset(2, 0), pPD:=PriceDataArray, pDen:=DenmarkDataArray

-            

-            With .Worksheets(FORM_SHEET)

-                Out_Table_1 TheRange:=.Range(TABLE_1).Cells(1, 1), pDen:=DenmarkDataArray, LastIdx:=PriceDataArray.tC

-                Out_Table_2 _

-                        TheRange:=.Range(TABLE_2).Cells(1, 1), _

-                        TheComment:=.Range("TABLE_COMMENT"), _

-                        pPD:=PriceDataArray, _

-                        pDen:=DenmarkDataArray

-                Out_Table_3 TheRange:=.Range(TABLE_3).Cells(1, 1), pDen:=DenmarkDataArray

-                Out_Table_4 TheRange:=.Range(TABLE_4).Cells(1, 1), pPD:=PriceDataArray

-                With .Range(TABLE_1)

-                    .Font.Name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-                With .Range(TABLE_2)

-                    .Font.Name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-                With .Range(TABLE_3)

-                    .Font.Name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-                With .Range(TABLE_4)

-                    .Font.Name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-            End With

-            .Worksheets(VAR_SHEET).Range("BOOL_DEMARK_READY") = True

-        Else

-            MsgBox _

-                Prompt:="Недостаточна глубина выборки данных." _

-                    & vbCrLf & "Измените параметры запроса и пробуйте снова.", _

-                Buttons:=vbOKOnly + vbExclamation, _

-                Title:=PROGRAM_NAME

-            .Worksheets(VAR_SHEET).Range("BOOL_DEMARK_READY") = False

-            .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False

-        End If

-'7)   Free unused memory

-        free_unused_memory PriceDataArray, DenmarkDataArray

-    End With

-End Function

-

-Sub allocate_memory(pPriceData As TPriceData, pDenmarkData As TDenmark, memsize As Integer)

-'  Память под TDenmark

-    ReDim pDenmarkData.ResistanceLine(1 To memsize)

-    ReDim pDenmarkData.ResistancePoints(1 To memsize)

-    ReDim pDenmarkData.SupportLine(1 To memsize)

-    ReDim pDenmarkData.SupportPoints(1 To memsize)

-   

-' Инициализация данных по ценам

-    pPriceData.tC = memsize

-    ReDim pPriceData.D(1 To memsize)

-    ReDim pPriceData.Tm(1 To memsize)

-    ReDim pPriceData.Opn(1 To memsize)

-    ReDim pPriceData.Hgh(1 To memsize)

-    ReDim pPriceData.Lw(1 To memsize)

-    ReDim pPriceData.Cls(1 To memsize)

-    ReDim pPriceData.Vl(1 To memsize)

-

-End Sub

-

-Sub free_unused_memory(pP As TPriceData, pD As TDenmark)

-'   Free Prices

-    pP.tC = 0

-    Erase pP.D

-    Erase pP.Tm

-    Erase pP.Opn

-    Erase pP.Hgh

-    Erase pP.Lw

-    Erase pP.Cls

-    Erase pP.Vl

-    

-'Free TDenmark

-    Erase pD.ResistanceLine

-    Erase pD.ResistancePoints

-    Erase pD.SupportLine

-    Erase pD.SupportPoints

-End Sub

-

-

-'*****************************************

-Sub DetDenmark(pPriceData As TPriceData, pDenmarkData As TDenmark, ByVal ClosePrev2 As Boolean, ByVal CloseSucc1 As Boolean)

-' определение элементов данных Денмарка (в цифровой форме)

-' на текущий момент времени времени tC

-' ИСХОДНЫЕ ДАННЫЕ:

-' pPriceData  - окно, стандартная форма данных по ценам (определена)

-' ClosePrev2 - H(t) > max{ H(t-1), H(t+1)} и  H(t) > Close(t-2)

-' CloseSucc1 - H(t) > max{ H(t-1), H(t+1)}  и  R(t+1) > Close(t+1)

-' РЕЗУЛЬТАТ:

-' pDenmarkData - элементы данных Денмарка (память выделена, SignalParameter - определен):

-' линии ResistanceLine,SupportLine их наклоны, опорные точки, сигналы к покупке или продаже

-' SignalValue = 0 сигнал отсутствует

-' SignalValue < 0 прорыв восходящего тренда (сигнал продажи)

-' SignalValue > 0 прорыв нисходящего тренда (сигнал покупки)

-' Если pDenmarkData.ResistancePointCount < 2, то элементы ResistanceLine не определяются

-' Если pDenmarkData.SupportPointsCount < 2, то элементы SupportLine не определяются

-

-' начальная установка

-    Const QUALIFICATOR_DISABLE As String = "-"

-    Const QUALIFICATOR_ENABLE As String = "Signal"

-    

-    Dim UpQual(1 To 3) As String

-    Dim DownQual(1 To 3) As String

-    Dim UpSignal, DownSignal As Integer

-    Dim i As Integer

-    

-    pDenmarkData.SignalValue = 0

-    UpSignal = 0

-    DownSignal = 0

-    

-    For i = 1 To 3

-        pDenmarkData.Qualificator(i) = QUALIFICATOR_DISABLE

-        UpQual(i) = QUALIFICATOR_DISABLE

-        DownQual(i) = QUALIFICATOR_DISABLE

-    Next i

-    

-' определение линии поддержки и сопротивления

-    ResLine _

-        pPriceData, _

-        pPriceData.tC, _

-        pDenmarkData.ResistancePointCount, _

-        pDenmarkData.ResistanceLine, _

-        pDenmarkData.ResistancePoints, _

-        ClosePrev2, _

-        CloseSucc1

-        

-    SuppLine _

-        pPriceData, _

-        pPriceData.tC, _

-        pDenmarkData.SupportPointsCount, _

-        pDenmarkData.SupportLine, _

-        pDenmarkData.SupportPoints, _

-        ClosePrev2, _

-        CloseSucc1

-

-        

-        

-    If pDenmarkData.ResistancePointCount >= 2 Then

-        pDenmarkData.ResistanceAngle = 57.29578 * _

-            Atn(pDenmarkData.ResistanceLine(pPriceData.tC) - _

-                pDenmarkData.ResistanceLine(pPriceData.tC - 1))

-    End If

-    If pDenmarkData.SupportPointsCount >= 2 Then

-        pDenmarkData.SupportAngle = 57.29578 * _

-            Atn(pDenmarkData.SupportLine(pPriceData.tC) - _

-                pDenmarkData.SupportLine(pPriceData.tC - 1))

-    End If

-

-' ФОРМИРОВАНИЕ СИГНАЛА ----------------------------------

-    Dim t As Integer

-' 1. случай нисходящего тренда: ResistanceLine определен и ResistanceLine падает *************

-    If pDenmarkData.ResistancePointCount >= 2 And pDenmarkData.ResistanceAngle < 0 Then

-'    необходимое условие прорыва вверх

-        If pDenmarkData.ResistanceLine(pPriceData.tC) < pPriceData.Cls(pPriceData.tC) Then

-            UpSignal = 1

-            For t = pPriceData.tC - pDenmarkData.SignalParameter To pPriceData.tC - 1

-                If pPriceData.Cls(t) > pDenmarkData.ResistanceLine(t) Then

-                    UpSignal = 0

-                    Exit For

-                End If

-            Next t

-        End If

-        If UpSignal = 1 Then

-'       Qualificator-1: close убывает накануне прорыва

-            If pPriceData.Cls(pPriceData.tC - 2) > pPriceData.Cls(pPriceData.tC - 1) Then

-                UpSignal = UpSignal + 1

-                UpQual(1) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-2: open > ResistanceLine в момент прорыва

-            If pPriceData.Opn(pPriceData.tC) > pDenmarkData.ResistanceLine(pPriceData.tC) Then

-                UpSignal = UpSignal + 1

-                UpQual(2) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-3 - demand value < ResistanceLine(tC)

-            If 2 * pPriceData.Cls(pPriceData.tC - 1) - pPriceData.Lw(pPriceData.tC - 1) < pDenmarkData.ResistanceLine(pPriceData.tC) Then

-                UpSignal = UpSignal + 1

-                UpQual(3) = QUALIFICATOR_ENABLE

-            End If

-        End If

-    End If  ' нисходящий тренд обработан ************************************

-

-' 2. случай восходящего тренда: SupportLine определен и SupportLine растет

-    If pDenmarkData.SupportPointsCount >= 2 And pDenmarkData.SupportAngle > 0 Then

-'    ---------------------------------------------

-'    необходимое условие прорыва вниз

-        If pPriceData.Cls(pPriceData.tC) < pDenmarkData.SupportLine(pPriceData.tC) Then

-            DownSignal = -1

-            For t = pPriceData.tC - pDenmarkData.SignalParameter To pPriceData.tC - 1

-                If pPriceData.Cls(t) < pDenmarkData.SupportLine(t) Then

-                    DownSignal = 0

-                    Exit For

-                End If

-            Next t

-        End If

-        If DownSignal = -1 Then

-'       Qualificator-1: Close растет накануне прорыва

-            If pPriceData.Cls(pPriceData.tC - 2) < pPriceData.Cls(pPriceData.tC - 1) Then

-                DownSignal = DownSignal - 1

-                DownQual(1) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-2: Open ниже ResistanceLine в момент прорыва

-            If pPriceData.Opn(pPriceData.tC) < pDenmarkData.SupportLine(pPriceData.tC) Then

-                DownSignal = DownSignal - 1

-                DownQual(2) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-3 - supply value(t-1) > SupportLine(tC)

-            If 2 * pPriceData.Cls(pPriceData.tC - 1) - pPriceData.Hgh(pPriceData.tC - 1) > pDenmarkData.SupportLine(pPriceData.tC) Then

-                DownSignal = DownSignal - 1

-                DownQual(3) = QUALIFICATOR_ENABLE

-            End If

-        End If

-'    ---------------------------------------------

-    End If

-'      Существует преобладание тенденции

-    If Abs(DownSignal) <> UpSignal Then

-        If Abs(DownSignal) > UpSignal Then

-            pDenmarkData.SignalValue = DownSignal

-            For i = 1 To 3

-                pDenmarkData.Qualificator(i) = DownQual(i)

-            Next i

-        Else

-            pDenmarkData.SignalValue = UpSignal

-            For i = 1 To 3

-                pDenmarkData.Qualificator(i) = UpQual(i)

-            Next i

-        End If

-    End If

-End Sub

-

-Sub DetProj(pPriceData As TPriceData, pDenmarkData As TDenmark)

-'Определение проекции при наличии сигнала: |Signal| > 1

-'Услловие применимости |Signal| > 1 !!!

-    Dim pM As Double, t As Integer, Tm As Integer, tL As Integer

-

-    If pDenmarkData.SignalValue >= 2 Then  ' СИГНАЛ ПОКУПКИ

-

-        tL = pDenmarkData.ResistancePoints(pDenmarkData.ResistancePointCount)     ' tR determination

-        If tL = pPriceData.tC Then

-            tL = pDenmarkData.ResistancePoints(pDenmarkData.ResistancePointCount - 1)

-        End If

-

-'  Projections 1,2 --------------------------------------------

-        If pDenmarkData.ProjectNumber >= 1 And pDenmarkData.ProjectNumber <= 2 Then

-'           t* = Arg min {L(t) : t R <= t  <= tb ,  L(t) < ResistanceLine(t)},

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Lw(Tm) ' L(t-1) < ResistanceLine(t-1) for t - break point !

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Lw(t) < pM And pPriceData.Lw(t) < pDenmarkData.ResistanceLine(t) Then

-                    pM = pPriceData.Lw(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            If pDenmarkData.ProjectNumber = 1 Then

-'               P1( tb) = ResistanceLine(tb) + ResistanceLine(t*) - L(t*)

-                pDenmarkData.ProjectPrice = pDenmarkData.ResistanceLine(pPriceData.tC) + pDenmarkData.ResistanceLine(Tm) - pPriceData.Lw(Tm)

-            Else

-                pDenmarkData.ProjectPrice = pDenmarkData.ResistanceLine(pPriceData.tC) + pDenmarkData.ResistanceLine(Tm) - pPriceData.Cls(Tm)

-            End If

-        End If ' pDenmarkData.ProjectNumber >= 1 And pDenmarkData.ProjectNumber <= 2

-   

-'  ----------------------------------------------------------------

-'  Projections 3

-        If pDenmarkData.ProjectNumber = 3 Then

-'           t*  = Arg min { С(t) : t R <= t  <= tb ,  C(t) < ResistanceLine(t)}

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Cls(Tm)

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Cls(t) < pM And pPriceData.Cls(t) < pDenmarkData.ResistanceLine(t) Then

-                    pM = pPriceData.Cls(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            pDenmarkData.ProjectPrice = pDenmarkData.ResistanceLine(pPriceData.tC) + pDenmarkData.ResistanceLine(Tm) - pPriceData.Cls(Tm)

-        End If

-    End If ' pDenmarkData.SignalValue >= 2

-

-'-------------------------------------------------------------------

-'*******************************************************************

-' ПРОЕКЦИЯ ДЛЯ СИГНАЛА ПРОДАЖИ

-    If pDenmarkData.SignalValue <= -2 Then

-        tL = pDenmarkData.SupportPoints(pDenmarkData.SupportPointsCount)  ' tR determination

-        If tL = pPriceData.tC Then

-            tL = pDenmarkData.ResistancePoints(pDenmarkData.SupportPointsCount - 1)

-        End If

-

-'  Projections 1,2 --------------------------------------------

-        If pDenmarkData.ProjectNumber = 1 Or pDenmarkData.ProjectNumber = 2 Then

-'           t* = Arg max {H(t) : t R <= t  <= tb ,  H(t) > SupportLine(t)},

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Hgh(Tm) ' H(t-1) > SupportLine(t-1) for t - break point !

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Hgh(t) > pM And pPriceData.Hgh(t) > pDenmarkData.SupportLine(t) Then

-                    pM = pPriceData.Hgh(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            If pDenmarkData.ProjectNumber = 1 Then

- '              P1( tb) = SupportLine(tb) + SupportLine(t*) - H(t*)

-                pDenmarkData.ProjectPrice = pDenmarkData.SupportLine(pPriceData.tC) + pDenmarkData.SupportLine(Tm) - pPriceData.Hgh(Tm)

-            Else

-'               P2( tb) = SupportLine(tb) + SupportLine(t*) - C(t*)

-                pDenmarkData.ProjectPrice = pDenmarkData.SupportLine(pPriceData.tC) + pDenmarkData.SupportLine(Tm) - pPriceData.Cls(Tm)

-            End If

-        End If

-   

-'  ----------------------------------------------------------------

-'  Projections 3

-        If pDenmarkData.ProjectNumber = 3 Then

-'           t*  = Arg max { С(t) : t R <= t  <= tb ,  C(t) >  SupportLine(t)}

-'           P3( tb) = SupportLine(tb) + SupportLine(t*) - C(t*)

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Cls(Tm)

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pM < pPriceData.Cls(t) And pPriceData.Cls(t) > pDenmarkData.SupportLine(t) Then

-                    pM = pPriceData.Cls(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            pDenmarkData.ProjectPrice = pDenmarkData.SupportLine(pPriceData.tC) + pDenmarkData.SupportLine(Tm) - pPriceData.Cls(Tm)

-        End If

-    End If ' pDenmarkData.SignalValue <= -2

-End Sub

-

-Sub ResLine(pP As TPriceData, tE As Integer, ResistancePointCount As Integer, _

-            ResistanceLine() As Double, s() As Integer, ClosePrev2 As Boolean, CloseSucc1 As Boolean)

-' Определение линии сопротивления по Демарку [1]

-' Основной вариант

-' ИСХОДНЫЕ ДАННЫЕ:

-' High, dom(High) = [1, tE]

-' ClosePrev2 - H(t) > max{ H(t-1), H(t+1)} и  H(t) > Close(t-2)

-' CloseSucc1 - H(t) > max{ H(t-1), H(t+1)}  и  R(t+1) > Close(t+1)

-' РЕЗУЛЬТАТ:

-' 1) линия сопротивления ResistanceLine, dom(ResistanceLine)=[s(1), tE], и

-' 2) s = {s(1), s(2), ..., s(ResistancePointCount)}, s(1) < s(2) < ...< s(ResistancePointCount)

-'   ( s(ResistancePointCount)<= tE )- опорные точки

-' 3) число опорных точек ResistancePointCount.

-' 4) s(1) -  первый момент времени с которого определена SupportLine

-'    то есть dom{Supp} = [s(1), tC]

-' Прим. Если число опорных точек окажется < 2, то линия

-' сопротивления не определяется. В этом случае следует

-' увеличить историю tE !!!

-    Dim t As Integer, i As Integer

-    Dim v As Double

-    Dim IsGoodPoint As Boolean

-  

-'1 определение опорных моментов времени

-    ResistancePointCount = 0

-    For t = 3 To tE - 1

- '      v = max{high(t-1), high(t+1)} < high(t)}

-        v = pP.Hgh(t - 1)

-        If v < pP.Hgh(t + 1) Then

-            v = pP.Hgh(t + 1)

-        End If

-        IsGoodPoint = pP.Hgh(t) > v

-        If IsGoodPoint And ClosePrev2 Then

-            IsGoodPoint = IsGoodPoint And (pP.Cls(t - 2) < pP.Hgh(t))

-        End If

-        

-        If IsGoodPoint Then       'alt.: v >= High(t + 1)

-            s(ResistancePointCount + 1) = t: ResistancePointCount = ResistancePointCount + 1

-        End If

-    Next t

-    

-loop_:

-    

-    If ResistancePointCount < 2 Then

-        GoTo done

-    End If

-

-' 2 определение линии сопротивления

-    ResistanceLine(s(1)) = pP.Hgh(s(1))

-    For i = 2 To ResistancePointCount

-        ResistanceLine(s(i)) = pP.Hgh(s(i))

-        v = (pP.Hgh(s(i)) - pP.Hgh(s(i - 1))) / (s(i) - s(i - 1))

-        For t = s(i - 1) + 1 To s(i) - 1

-            ResistanceLine(t) = pP.Hgh(s(i - 1)) + v * (t - s(i - 1))

-        Next t

-    Next i

-    If s(ResistancePointCount) < tE Then

-        v = (pP.Hgh(s(ResistancePointCount)) - pP.Hgh(s(ResistancePointCount - 1))) / (s(ResistancePointCount) - s(ResistancePointCount - 1))

-        For t = s(ResistancePointCount) + 1 To tE

-            ResistanceLine(t) = pP.Hgh(s(ResistancePointCount - 1)) + v * (t - s(ResistancePointCount - 1))

-        Next t

-    End If

-    If CloseSucc1 Then

-        For t = 1 To ResistancePointCount

-            If ResistanceLine(s(t) + 1) < pP.Cls(s(t) + 1) Then

-                ResistancePointCount = ResistancePointCount - 1

-                ' удалить точку

-                For i = t To ResistancePointCount

-                    s(i) = s(i + 1)

-                Next i

-                s(ResistancePointCount + 1) = 0

-                ' очистить массив линии

-                Dim Lb, Rb As Integer

-                Lb = LBound(ResistanceLine)

-                Rb = UBound(ResistanceLine)

-                Erase ResistanceLine

-                ReDim ResistanceLine(Lb To Rb)

-                GoTo loop_

-            End If

-        Next t

-    End If

-    

-done:

-End Sub

-

-Sub SuppLine(pP As TPriceData, tE As Integer, SupportPointsCount As Integer, _

-               SupportLine() As Double, s() As Integer, ClosePrev2 As Boolean, CloseSucc1 As Boolean)

-' Определение линии поддержки по Демарку [1] (от конца)

-' Исходные данные:

-' Low, dom(Low) = [1, tE]

-' ClosePrev2 - H(t) > max{ H(t-1), H(t+1)} и  H(t) > Close(t-2)

-' CloseSucc1 - H(t) > max{ H(t-1), H(t+1)}  и  R(t+1) > Close(t+1)

-' Результат:

-' 1) линия сопротивления SupportLine, dom(SupportLine)=[s(1), tE],

-' 2) s = {s(1), s(2), ..., s(SupportPointsCount)}, s(1) < s(2) < ...< s(SupportPointsCount) -

-'    опорные точки

-' 3) число опорных точек SupportPointsCount.

-' Прим. Если фактическое число опорных точек окажется < 2, то линия

-' поддержки не определяется.

-    Dim t As Integer, i As Integer

-    Dim v As Double

-    Dim IsGoodPoint As Boolean

-    

-'1 определение опорных моментов времени

-     SupportPointsCount = 0

-    For t = 3 To tE - 1

-'       v = min{Low(t-1), Low(t+1)} > Low(t)

-        v = pP.Lw(t - 1)

-        If v > pP.Lw(t + 1) Then

-            v = pP.Lw(t + 1)

-        End If

-        

-        IsGoodPoint = pP.Lw(t) < v

-        

-        If IsGoodPoint And ClosePrev2 Then

-            IsGoodPoint = IsGoodPoint And (pP.Cls(t - 2) > pP.Lw(t))

-        End If

-        

-        If IsGoodPoint Then     'alt.: v >= High(t + 1)

-            s(SupportPointsCount + 1) = t: SupportPointsCount = SupportPointsCount + 1

-        End If

-    Next t

-

-loop_:

-    If SupportPointsCount < 2 Then

-        GoTo done

-    End If

-' 2 определение линии поддержки

-    

-    SupportLine(s(1)) = pP.Lw(s(1))

-    For i = 2 To SupportPointsCount

-        SupportLine(s(i)) = pP.Lw(s(i))

-        v = (pP.Lw(s(i)) - pP.Lw(s(i - 1))) / (s(i) - s(i - 1))

-        For t = s(i - 1) + 1 To s(i) - 1

-            SupportLine(t) = pP.Lw(s(i - 1)) + v * (t - s(i - 1))

-        Next t

-    Next i

-    If s(1) < tE Then

-        v = (pP.Lw(s(SupportPointsCount)) - pP.Lw(s(SupportPointsCount - 1))) / (s(SupportPointsCount) - s(SupportPointsCount - 1))

-        For t = s(SupportPointsCount) + 1 To tE

-            SupportLine(t) = pP.Lw(s(SupportPointsCount - 1)) + v * (t - s(SupportPointsCount - 1))

-        Next t

-    End If

-    If CloseSucc1 Then

-        For t = 1 To SupportPointsCount

-            If SupportLine(s(t) + 1) > pP.Cls(s(t) + 1) Then

-                SupportPointsCount = SupportPointsCount - 1

-                ' удалить точку

-                For i = t To SupportPointsCount

-                    s(i) = s(i + 1)

-                Next i

-                s(SupportPointsCount + 1) = 0

-                ' очистить массив линии

-                Dim Lb, Rb As Integer

-                Lb = LBound(SupportLine)

-                Rb = UBound(SupportLine)

-                Erase SupportLine

-                ReDim SupportLine(Lb To Rb)

-                GoTo loop_

-            End If

-        Next t

-    End If

-done:

-End Sub

-

-<<<<<<
-======================
-mChart
->>>>>>
-Attribute VB_Name = "mChart"

-Option Explicit

-

-Const CHART_NAME As String = "PriceChart"

-

-Sub Draw_Chart(SignalDefined As Boolean)

-

-    Dim n As Integer

-    Dim theChart As Chart

-    Dim ChartDataAria, szLastNumber As String

-    Dim MinYScale As Double

-    

-    

-    With ThisWorkbook

-' Checking data

-' Disable screen out

-        .Application.Cursor = xlWait

-        .Application.ScreenUpdating = False

-' Create series range

-        n = GetLinesCount(Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE))

-        szLastNumber = n + 1

-        If SignalDefined Then

-            ChartDataAria = "A2:A" & szLastNumber _

-                        & ",D2:D" & szLastNumber _

-                        & ",G2:G" & szLastNumber _

-                        & ",I2:K" & szLastNumber

-        Else

-            ChartDataAria = "A2:A" & szLastNumber _

-                        & ",D2:D" & szLastNumber _

-                        & ",G2:G" & szLastNumber _

-                        & ",I2:J" & szLastNumber

-        End If

-        MinYScale = GetMinValue(.Worksheets(RAW_DATA_SHEET).Range(ChartDataAria))

-' Find and delete old chart

-        .Worksheets(CHART_SHEET).Unprotect

-        Dim WindowWidth, WindowHeight As Integer

-        With .Worksheets(CHART_SHEET)

-            WindowWidth = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-            WindowHeight = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-        End With

-        

-        

-        With .Worksheets(CHART_SHEET).ChartObjects

-            .Delete

-            With .Add(5, 5, WindowWidth - 10, WindowHeight - 10)

-                .SendToBack

-                Set theChart = .Chart

-            End With

-' Create a chart

-        End With

-        With theChart

-            .ChartType = xlLine

-            .SetSourceData Source:=Sheets(RAW_DATA_SHEET).Range( _

-                    ChartDataAria), PlotBy:=xlColumns

-'                   .Location Where:=xlLocationAsObject, Name:=CHART_SHEET

-            .HasTitle = True

-            With .ChartTitle

-                .Text = ThisWorkbook.Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE).Value

-                With .Font

-                    .Size = 8

-                    .Bold = True

-                End With

-            End With

-            .HasLegend = True

-            With .Legend

-                .Position = xlTop

-                With .Font

-                    .Name = "Arial"

-                    .Size = 8

-                End With

-            End With

-            .HasDataTable = False

-            With .Axes(xlCategory)

-                .HasMajorGridlines = True

-                .HasMinorGridlines = False

-                .TickLabels.Orientation = xlUpward

-                With .MajorGridlines.Border

-                    .ColorIndex = 48

-                    .Weight = xlHairline

-                    .LineStyle = xlDot

-                End With

-                .CrossesAt = 1

-                .TickLabelSpacing = 1

-                .TickMarkSpacing = 1

-                .AxisBetweenCategories = False

-                .ReversePlotOrder = False

-                .TickLabels.AutoScaleFont = True

-                With .TickLabels.Font

-                    .Name = "Arial"

-                    .Size = 8

-                End With

-            End With

-            With .Axes(xlValue)

-                .HasMajorGridlines = True

-                .HasMinorGridlines = False

-                With .MajorGridlines.Border

-                    .ColorIndex = 48

-                    .Weight = xlHairline

-                    .LineStyle = xlDot

-                End With

-                .MinimumScale = MinYScale

-                .MaximumScaleIsAuto = True

-                .MinorUnitIsAuto = True

-                .MajorUnitIsAuto = True

-                .Crosses = xlCustom

-                .CrossesAt = MinYScale

-                .ReversePlotOrder = False

-                .ScaleType = xlLinear

-                .TickLabels.AutoScaleFont = True

-                With .TickLabels.Font

-                    .Name = "Arial"

-                    .Size = 9

-                End With

-            End With

-            .ChartTitle.Top = 5

-            .ChartTitle.Left = 5

-            With .Legend

-                .Top = 5

-                .Fill.OneColorGradient _

-                    Style:=msoGradientHorizontal, _

-                    Variant:=3, _

-                    Degree:=0.303913939116503

-                .Fill.Visible = True

-                .Fill.ForeColor.SchemeColor = 71

-            End With

-            .PlotArea.Left = 10

-            .PlotArea.Top = .Legend.Top + .Legend.Height + 5

-            .PlotArea.Width = .ChartArea.Width - 20

-            .PlotArea.Height = .ChartArea.Height - .PlotArea.Top

-            

-' Tune OPEN line

-            With .SeriesCollection(1)

-                .Border.LineStyle = xlNone

-                .MarkerBackgroundColorIndex = xlNone

-                .MarkerForegroundColorIndex = 1

-                .MarkerStyle = xlPlus

-                .Smooth = False

-                .MarkerSize = 9

-                .Shadow = False

-            End With

-' Tune CLOSE line

-            With .SeriesCollection(2)

-                .Border.ColorIndex = 10

-                .Border.Weight = xlMedium

-                .Border.LineStyle = xlContinuous

-            End With

-' Tune RESISTANCE line

-            With .SeriesCollection(3)

-                .Border.ColorIndex = 3

-                .Border.Weight = xlThin

-                .Border.LineStyle = xlContinuous

-            End With

-' Tune SUUPORT line

-            With .SeriesCollection(4)

-                .Border.ColorIndex = 25

-                .Border.Weight = xlThin

-                .Border.LineStyle = xlContinuous

-            End With

-            If SignalDefined Then

-                With .SeriesCollection(5)

-                    .Border.ColorIndex = 6

-                    .Border.Weight = xlThin

-                    .Border.LineStyle = xlDot

-                End With

-            End If

-        End With

-        .Application.Cursor = xlDefault

-        With .Worksheets(CHART_SHEET)

-            .Select

-            .Protect userInterfaceOnly:=True

-        End With

-    End With

-End Sub

-

-Function GetMinValue(DataRange As Range) As Double

-    Dim Cell As Range

-    Dim MinValue, MaxValue, RangeValue, CorrectValue, Mult As Double

-    MinValue = MAX_PRICE_VALUE

-    MaxValue = MIN_PRICE_VALUE

-    For Each Cell In DataRange

-        If Not IsEmpty(Cell) And IsNumeric(Cell) Then

-            If Cell > MIN_PRICE_VALUE Then

-                If Cell < MinValue Then

-                    MinValue = Cell

-                End If

-                If Cell > MaxValue Then

-                    MaxValue = Cell

-                End If

-            End If

-        End If

-    Next

-    RangeValue = MaxValue - MinValue

-    If RangeValue < 0 Then

-        MinValue = 0

-    Else

-        CorrectValue = RangeValue / 4

-        Mult = MIN_PRICE_VALUE

-        While MinValue - Int(MinValue * Mult) / Mult > CorrectValue

-            Mult = Mult * 10

-        Wend

-        MinValue = Int(MinValue * Mult) / Mult

-    End If

-    GetMinValue = MinValue

-End Function

-

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub GetState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.Name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars("Worksheet Menu Bar").Visible = False

-End Sub

-

-

-Public Sub RestoreState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars("Worksheet Menu Bar").Visible = True

-End Sub

-

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{DF5FA93A-BD73-481A-846E-B5DA6D5395F7}{78BC8148-0EFA-432A-A856-1E6ADF571B7E}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Private Sub CommandButton1_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-mWebQeury
->>>>>>
-Attribute VB_Name = "mWebQeury"

-Option Explicit

-

-Public Const Qry_DELETE_ALL As String = "Qry_DELETE_ALL"

-Public Const Qry_PATH_NO_CHANGE As String = "Qry_PATH_NO_CHANGE"

-

-

-Sub QryCreate(QryRange As Range, QryName As String, QryPath As String, Optional RefreshBkgnd = False)

-    Dim WebQuery As QueryTable

-    QryDelete QryRange:=QryRange, QryName:=QryName

-    

-    Set WebQuery = QryRange.Worksheet.QueryTables.Add( _

-            Connection:=QryPath, _

-            Destination:=QryRange)

-    

-    With WebQuery

-        .FieldNames = False

-        .Name = QryName

-        .RefreshStyle = xlOverwriteCells

-        .RowNumbers = False

-        .FillAdjacentFormulas = False

-        .RefreshOnFileOpen = False

-        .HasAutoFormat = False

-        .BackgroundQuery = False

-        .TablesOnlyFromHTML = False

-        .Refresh BackgroundQuery:=RefreshBkgnd

-        .SavePassword = False

-        .SaveData = True

-    End With

-End Sub

-

-Function QryRefresh(QryRange As Range, QryName As String, Optional QryPath As String = Qry_PATH_NO_CHANGE, Optional Background As Boolean = False) As Boolean

-    Dim qry_result As Boolean

-    qry_result = False

-    If QryExist(QryRange, QryName) Then

-        With QryRange.Worksheet.QueryTables(QryName)

-            If QryPath <> Qry_PATH_NO_CHANGE Then

-                .Connection = QryPath

-            End If

-            .Refresh BackgroundQuery:=Background

-            qry_result = True

-        End With

-    End If

-    QryRefresh = qry_result

-End Function

-

-Sub QryDelete(QryRange As Range, Optional QryName As String = Qry_DELETE_ALL)

-    Dim WebQuery As QueryTable

-    For Each WebQuery In QryRange.Worksheet.QueryTables

-        If QryName = Qry_DELETE_ALL Or WebQuery.Name = QryName Then

-            WebQuery.Delete

-        End If

-    Next

-End Sub

-

-Function QryExist(QryRange As Range, QryName As String) As Boolean

-    Dim WebQuery As QueryTable

-    For Each WebQuery In QryRange.Worksheet.QueryTables

-        If WebQuery.Name = QryName Then

-            QryExist = True

-            Exit For

-        End If

-    Next

-End Function

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Sub CreateCommandBar(theApp As Application)

-Attribute CreateCommandBar.VB_ProcData.VB_Invoke_Func = "R\n14"

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible + msoBarNoCustomize + msoBarNoMove + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Print"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 4

-                        .OnAction = "cmPrint"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Contents"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 49

-                        .OnAction = "cmHelpContents"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible + msoBarNoCustomize + msoBarNoMove + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(Flag As Boolean)

-    If Flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars("Worksheet Menu Bar")

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        cmHelpContents

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mTool
->>>>>>
-Attribute VB_Name = "mTool"

-Option Explicit

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub tool_delete_all_tables()

-    QryDelete ThisWorkbook.Worksheets(RAW_DATA_SHEET).Range("A1")

-End Sub

-

-Sub tool_delete_all_charts(theSheet As Worksheet)

-    Dim theChart As Chart

-    For Each theChart In theSheet

-        theChart.Unprotect

-        theChart.Delete

-    Next

-End Sub

-

-Sub DateTimeTest()

-    Dim the_date

-    Dim the_time

-    the_date = DateValue(Now)

-    the_time = TimeValue(Now)

-End Sub

-

-

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{66FF4B59-65DE-49BF-B9F9-D0ECF0F365BE}{4D08F867-80C2-47C5-9CFA-069E31BEAB8C}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-

-Private Sub App_WorkbookOpen(ByVal wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If Application.Workbooks.count > 1 Then

-        wbname = wb.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKCancel, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            wb.Close Savechanges:=False

-        End If

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-mDataCommands
->>>>>>
-Attribute VB_Name = "mDataCommands"

-Option Explicit

-

-Sub evFileOpen()

-    Dim fileToOpen As String

-    Dim wb As Workbook

-    Dim ticker As String

-    Dim Result As Integer

-

-    fileToOpen = Application.GetOpenFilename("Text Files (*.txt), *.txt, Data Files (*.csv), *.csv")

-    Set wb = ThisWorkbook

-    With wb

-        If fileToOpen <> "False" Then

-            If .Worksheets(VAR_SHEET).Range("BOOL_AUTORECALC") = True Then

-                .Worksheets(VAR_SHEET).Range("BOOL_AUTORECALC") = False

-            End If

-            .Worksheets(FORM_SHEET).Range(FILE_NAME) = fileToOpen

-            Result = UpdateHistoryFromFile(wb, fileToOpen)

-            .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False

-            .Worksheets(VAR_SHEET).Range("BOOL_DEMARK_READY") = False

-            

-            ClearResultTables

-            

-            Select Case Result

-                Case FUNCRES_FILE_OK

-                    .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = True

-                    If TDenmark_Calc Then

-                        With .Worksheets(RAW_DATA_SHEET)

-                            ticker = .Range("B1")

-                        End With

-                        With .Worksheets(FORM_SHEET)

-                            .Range("CALC_TICKER_NAME") = ticker

-                        End With

-                    End If

-                Case FUNCRES_FILE_VERY_SMALL

-                    .Worksheets(FORM_SHEET).Range("CALC_TICKER_NAME") = MSG_FILE_VERY_SMALL

-                    MsgBox MSG_FILE_VERY_SMALL, vbOKOnly, PROGRAM_NAME

-                Case FUNCRES_FILE_INVALID_FORMAT

-                    .Worksheets(FORM_SHEET).Range("CALC_TICKER_NAME") = MSG_FILE_INVALID_FORMAT

-                    MsgBox MSG_FILE_INVALID_FORMAT, vbOKOnly, PROGRAM_NAME

-                End Select

-            .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False

-        End If

-    End With 'wb

-End Sub

-

-Sub evSubmit_Click()

-    Dim ticker As String

-    Dim Period As String

-

-    Application.Cursor = xlWait

-    Dim wb As Workbook

-    Set wb = ThisWorkbook

-    With wb

-        With .Worksheets(VAR_SHEET)

-            ticker = .Range("DEN_SYMBOL")

-            Period = .Range("DEN_TIME")

-            If .Range("BOOL_DATA_READY") = False Or .Range("BOOL_LOAD_DATA") = True Then

-                .Range("BOOL_DATA_READY") = UpdateHistoryFromWeb(wb)

-            End If

-            .Range("BOOL_DEMARK_READY") = False

-        End With

-        If .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False Then

-            MsgBox _

-                Prompt:="Недостаточна глубина выборки данных." _

-                    & vbCrLf & "Измените параметры запроса и пробуйте снова.", _

-                Buttons:=vbOKOnly + vbExclamation, _

-                Title:=PROGRAM_NAME

-            

-            ClearResultTables

-            

-            With .Worksheets(FORM_SHEET)

-                .Range("CALC_TICKER_NAME") = ticker & ", Period=" & Period

-                .Range("FILE_NAME") = ""

-                .Range(TABLE_COMMENT).Value = "Недостаточно данных"

-            End With

-        Else

-            If TDenmark_Calc Then

-                With .Worksheets(FORM_SHEET)

-                    .Range("CALC_TICKER_NAME") = ticker & ", Period=" & Period

-                    .Range("FILE_NAME") = ""

-                End With

-            End If

-        End If

-    End With

-    Application.Cursor = xlDefault

-End Sub

-

-Sub evTicker_Change()

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("IDX_DEN_SECNAME") = .Range("IDX_DEN_SYMBOL")

-    End With

-    evHistory_Change

-End Sub

-

-Sub evSecName_Change()

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("IDX_DEN_SYMBOL") = .Range("IDX_DEN_SECNAME")

-    End With

-    evHistory_Change

-End Sub

-

-Sub evLastInterval_Change()

-    MsgBox "Не работает в этой версии"

-End Sub

-

-Sub evHistory_Change()

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("BOOL_DATA_READY") = False

-    End With

-End Sub

-

-Sub evGroupChange()

-    Dim GroupIdx, LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange As String

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        GroupIdx = .Range("IDX_DEN_LIST")

-        .Range("IDX_DEN_SYMBOL") = 1

-        NewRangeOffsetCol = (GroupIdx - 1) * 2

-        LinesCount = GetLinesCount(.Range("TICKER_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .Name & "!" & .Range(.Range("TICKER_TABLES").Offset(1, NewRangeOffsetCol), .Range("TICKER_TABLES").Offset(LinesCount, NewRangeOffsetCol)).Address

-        ThisWorkbook.Worksheets(FORM_SHEET).Shapes("cbxTikers").ControlFormat.ListFillRange = NewCbxRange

-        NewRangeOffsetCol = NewRangeOffsetCol + 1

-        NewCbxRange = .Name & "!" & .Range(.Range("TICKER_TABLES").Offset(1, NewRangeOffsetCol), .Range("TICKER_TABLES").Offset(LinesCount, NewRangeOffsetCol)).Address

-        ThisWorkbook.Worksheets(FORM_SHEET).Shapes("cbxSecName").ControlFormat.ListFillRange = NewCbxRange

-    End With

-    evTicker_Change

-End Sub

-

-Sub evUpdateTickerList()

-    UpdateTickerList ThisWorkbook

-    evHistory_Change

-End Sub

-<<<<<<
-======================
-mGetFileData
->>>>>>
-Attribute VB_Name = "mGetFileData"

-Option Explicit

-

-Dim mobjAppRunEnable As New cEnableRun

-

-Public Const MAX_LOAD_DATA_LINES As Integer = 16000

-

-Public Const MSG_FILE_VERY_SMALL As String = "В файле недостаточно данных"

-Public Const MSG_FILE_INVALID_FORMAT As String = "Неверный формат файла"

-

-Public Const FUNCRES_FILE_OK As Integer = 0

-Public Const FUNCRES_FILE_VERY_SMALL As Integer = -1

-Public Const FUNCRES_FILE_INVALID_FORMAT As Integer = -2

-

-Function UpdateHistoryFromFile(wb As Workbook, fileToOpen As String) As Integer

-    Dim DestRangeName As String

-    Dim ResultLength As Integer

-    Dim Location As Range

-    Dim denWindow As Integer

-    Dim IsIntraday As Boolean

-    Dim CalcNextTime As Boolean

-        

-    Dim SingleFileLine As String

-    Dim FileHandler As Integer

-    Dim i, j, row_idx As Integer

-    

-    UpdateHistoryFromFile = FUNCRES_FILE_INVALID_FORMAT

-    With wb

-        .Application.ScreenUpdating = False

-        With .Worksheets(VAR_SHEET)

-            CalcNextTime = .Range("BOOL_NEXT_TIME")

-            denWindow = .Range("DEN_WINDOW") + 1

-            If CalcNextTime Then

-                denWindow = denWindow + 1

-            End If

-            IsIntraday = True

-        End With

-        With .Worksheets(RAW_DATA_SHEET)

-            'Clear table include temp area

-            .Parent.Application.DisplayAlerts = False

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW - 1, RAW_DATA_RANGE_COL - 1), _

-                .Cells(65535, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-            ).ClearContents

-            Set Location = .Range(RAW_DATA_RANGE).Offset(-1, 0)

-            

-            ' Reading data from file

-            FileHandler = FreeFile

-            row_idx = 0

-            Open fileToOpen For Input As #FileHandler

-            Do While Not EOF(FileHandler) And row_idx < MAX_LOAD_DATA_LINES

-                Line Input #FileHandler, SingleFileLine

-                .Range(PRICE_TABLE).Offset(row_idx, 0) = SingleFileLine

-                row_idx = row_idx + 1

-            Loop

-            Close #FileHandler

-            

-            ' Parsing data

-            DestRangeName = "=" & RAW_DATA_SHEET & "!$B$1:$B" & row_idx

-            ResultLength = row_idx

-            

-            .Range(DestRangeName).TextToColumns _

-                Destination:=.Range(DestRangeName), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=True, _

-                Semicolon:=True, _

-                Comma:=True, _

-                Space:=False, _

-                Other:=False, _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 1), _

-                                Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1))

-            

-            .Parent.Application.DisplayAlerts = True

-            Dim CurrentDate As String

-            Dim RawData As Range

-            

-            Set RawData = .Range(RAW_DATA_RANGE)

-            

-            If Not CheckFileFormat(RawData.Offset(-1, 0)) Then

-                UpdateHistoryFromFile = FUNCRES_FILE_INVALID_FORMAT

-                Exit Function

-            End If

-            

-            row_idx = 0

-            With RawData

-                CurrentDate = .Value

-                For i = 1 To ResultLength

-                    If Not IsIntraday And CurrentDate = .Offset(i, DATE_IDX).Value Then

-                        ' skip virtual prices

-                        If (.Offset(i, VOLUME_IDX) > MIN_PRICE_VALUE) Then

-                            If .Offset(row_idx, HIGH_IDX).Value < .Offset(i, HIGH_IDX).Value Then

-                                .Offset(row_idx, HIGH_IDX).Value = .Offset(i, HIGH_IDX).Value

-                            End If

-                            If .Offset(row_idx, LOW_IDX).Value > .Offset(i, LOW_IDX).Value Then

-                                .Offset(row_idx, LOW_IDX).Value = .Offset(i, LOW_IDX).Value

-                            End If

-                            .Offset(row_idx, VOLUME_IDX).Value = _

-                                .Offset(row_idx, VOLUME_IDX).Value + .Offset(i, VOLUME_IDX).Value

-                            .Offset(row_idx, TIME_IDX).Value = .Offset(i, TIME_IDX).Value

-                            .Offset(row_idx, CLOSE_IDX).Value = .Offset(i, CLOSE_IDX).Value

-                        End If

-                    Else

-                        ' skip virtual prices

-                        If (.Offset(row_idx, VOLUME_IDX) > MIN_PRICE_VALUE) Then

-                            row_idx = row_idx + 1

-                        End If

-                        For j = DATE_IDX To VOLUME_IDX

-                            .Offset(row_idx, j) = .Offset(i, j)

-                        Next j

-                        CurrentDate = .Offset(i, DATE_IDX)

-                    End If

-                Next i

-            End With ' RawData

-            ' Clear unused Cells

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(65536, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-            ).ClearContents

-            

-            If row_idx > denWindow Then

-                row_idx = row_idx - denWindow

-                .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-                ).Delete xlShiftUp

-            Else

-                UpdateHistoryFromFile = FUNCRES_FILE_VERY_SMALL

-                Exit Function

-            End If

-            

-            row_idx = denWindow + 1

-            

-            Set Location = .Range( _

-                .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_IDX) _

-            )

-            

-            Location.TextToColumns _

-                Destination:=Location.Offset(0, DATE_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:="/", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2))

-            

-            Location.Offset(0, TIME_IDX).TextToColumns _

-                Destination:=Location.Offset(0, TIME_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:=":", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2))

-            

-            ' Check estimation date

-            

-            Dim end_date, end_time As Date

-            Dim year, month, day As Integer

-            Dim hour, minute As Integer

-            Dim next_time_exist As Boolean

-            

-            year = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 3)

-            month = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 2)

-            day = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 1)

-            hour = Location.Cells(denWindow - 1, TIME_STAMP_OFFSET + 1)

-            minute = Location.Cells(denWindow - 1, TIME_STAMP_OFFSET + 2)

-            

-            next_time_exist = day + month + year <> 0

-            

-            If next_time_exist Then

-                end_date = DateSerial(year, month, day)

-                end_time = TimeSerial(hour, minute, 0)

-                mobjAppRunEnable.EnableRun ESTIMATION_DATE, end_date

-            End If

-             

-            row_idx = 0

-            Dim temp_str As String

-                    

-            If IsIntraday Then

-                Do While IsEmpty(Location.Cells(1 + row_idx, 1 + DATE_IDX)) = False

-                       temp_str = Location.Cells(1 + row_idx, 1 + PROJECT_IDX + 1)

-                       temp_str = temp_str & "/"

-                       temp_str = temp_str & Location.Cells(1 + row_idx, 1 + PROJECT_IDX + 2)

-                       temp_str = temp_str & "-"

-                       temp_str = temp_str & Location.Cells(1 + row_idx, 1 + TIME_IDX)

-                       Location.Cells(1 + row_idx, DATE_IDX) = temp_str

-                       row_idx = row_idx + 1

-                Loop

-                row_idx = row_idx - 1

-                Dim condition As Boolean

-                condition = Not CalcNextTime And next_time_exist And end_date = DateValue(Now) And end_time > TimeValue(Now)

-                If condition Then

-                    .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL - 1), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-                    ).Delete xlShiftUp

-                End If

-            End If

-        End With ' .Worksheets(RAW_DATA_SHEET)

-    End With ' wb

-    UpdateHistoryFromFile = FUNCRES_FILE_OK

-End Function

-

-Function CheckFileFormat(HeaderString As Range) As Boolean

-    With HeaderString

-        CheckFileFormat = _

-            .Offset(0, DATE_IDX) = "Date" And _

-            .Offset(0, TIME_IDX) = "Time" And _

-            .Offset(0, OPEN_IDX) = "Open" And _

-            .Offset(0, CLOSE_IDX) = "Close" And _

-            .Offset(0, LOW_IDX) = "Low" And _

-            .Offset(0, HIGH_IDX) = "High" And _

-            .Offset(0, VOLUME_IDX) = "Volume"

-    End With

-End Function

-<<<<<<
-Project Name : 'Denmark_method'
-Quirk - duff tag length======================
-MGetWebData
->>>>>>
-Attribute VB_Name = "MGetWebData"

-Option Explicit

-

-Dim mobjAppRunEnable As New cEnableRun

-

-Const QueryDataName As String = "ExternalDenmarkData"

-

-Function UpdateHistoryFromWeb(wb As Workbook) As Boolean

-    Dim DestRangeName As String

-    Dim ResultLength As Integer

-    Dim QryPathStr As String

-    Dim Location As Range

-    Dim denWindow As Integer

-    Dim IsIntraday As Boolean

-    Dim CalcNextTime As Boolean

-        

-    UpdateHistoryFromWeb = False

-    QryPathStr = GetQryPath(wb)

-    With wb

-        .Application.ScreenUpdating = False

-        With .Worksheets(VAR_SHEET)

-            DestRangeName = .Range("DEN_SYMBOL")

-            CalcNextTime = .Range("BOOL_NEXT_TIME")

-            denWindow = .Range("DEN_WINDOW")

-            If CalcNextTime Then

-                denWindow = denWindow + 1

-            End If

-            IsIntraday = IsNumeric(.Range("DEN_TIME"))

-        End With

-        With .Worksheets(RAW_DATA_SHEET)

-            .Range(PRICE_TABLE) = DestRangeName

-            'Clear table and temp area

-            With .Range( _

-                .Cells(RAW_DATA_RANGE_ROW - 1, RAW_DATA_RANGE_COL - 1), _

-                .Cells(65535, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE))

-                .ClearContents

-                .NumberFormat = "General"

-            End With

-            

-            Set Location = .Range(RAW_DATA_RANGE).Offset(-1, 0)

-            If Not QryExist(Location, QueryDataName) Then

-                QryCreate Location, QueryDataName, QryPathStr

-            Else

-                QryRefresh Location, QueryDataName, QryPathStr

-            End If

-            With Location.Worksheet.QueryTables(QueryDataName)

-                DestRangeName = .ResultRange.Name.RefersTo

-                ResultLength = .ResultRange.count

-            End With

-    

-'            .Parent.Application.DisplayAlerts = False

-    

-            If ResultLength < denWindow Then

-                Exit Function

-            End If

-            

-            .Range(DestRangeName).TextToColumns _

-                Destination:=Range(DestRangeName), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=True, _

-                Space:=False, _

-                Other:=False, _

-                OtherChar:="|", _

-                FieldInfo:=Array( _

-                                Array(1, 9), _

-                                Array(2, 2), _

-                                Array(3, 1), _

-                                Array(4, 1), _

-                                Array(5, 1), _

-                                Array(6, 1), _

-                                Array(7, 1), _

-                                Array(8, 9), _

-                                Array(9, 9), _

-                                Array(10, 9), _

-                                Array(11, 9), _

-                                Array(12, 9))

-            

-            .Range(DestRangeName).EntireColumn.AutoFit

-            

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(65536, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-            ).NumberFormat = "General"

-            

-            Dim RawData As Range

-            Dim row_idx As Integer

-            

-            Set RawData = .Range(DestRangeName).Offset(0, 1)

-            RawData.Insert Shift:=xlToRight

-            

-            If Not IsIntraday Then

-                Set RawData = RawData.Offset(0, -1)

-                RawData.Value = "18:00"

-                RawData.Cells(1, 1).FormulaR1C1 = "TIME"

-                Set RawData = RawData.Offset(0, -1)

-            Else

-                Set RawData = RawData.Offset(0, -2)

-                RawData.TextToColumns _

-                    Destination:=RawData, _

-                    DataType:=xlDelimited, _

-                    TextQualifier:=xlDoubleQuote, _

-                    ConsecutiveDelimiter:=False, _

-                    Tab:=False, _

-                    Semicolon:=False, _

-                    Comma:=False, _

-                    Space:=True, _

-                    Other:=False, _

-                    OtherChar:="/", _

-                    FieldInfo:=Array( _

-                                    Array(1, 2), _

-                                    Array(2, 2))

-                RawData.Cells(1, 2).FormulaR1C1 = "TIME"

-            End If

-            

-'            Dim end_date As Date

-'            end_date = RawData.Cells(ResultLength, 1).FormulaR1C1

-

-' Delete unused space

-            

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW + ResultLength, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(65536, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-            ).ClearContents

-            

-            Dim i As Integer

-' Delete blank intervals

-            

-            Set RawData = .Range(RAW_DATA_RANGE).Offset(0, 0)

-            row_idx = 0

-            For i = 1 To ResultLength

-                ' skip virtual prices

-                If RawData.Offset(row_idx, CLOSE_IDX).Value > MIN_PRICE_VALUE Then

-                    row_idx = row_idx + 1

-                Else

-                    Set Location = .Range( _

-                            .Cells(row_idx + RAW_DATA_RANGE_ROW, DATE_IDX + RAW_DATA_RANGE_COL), _

-                            .Cells(row_idx + RAW_DATA_RANGE_ROW, PROJECT_IDX + RAW_DATA_RANGE_COL) _

-                    )

-                    Location.Delete xlShiftUp

-                End If

-            Next i

-            

-            ResultLength = GetLinesCount(.Range(RAW_DATA_RANGE))

-            

-            row_idx = ResultLength - 1

-            If row_idx > denWindow Then

-                row_idx = row_idx - denWindow

-                .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-                ).Delete xlShiftUp

-            Else

-                Exit Function

-            End If

-            

-            Dim TmpStr As String

-                        

-            row_idx = GetLinesCount(.Range(RAW_DATA_RANGE))

-            

-            Set RawData = .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx - 1, RAW_DATA_RANGE_COL + DATE_IDX) _

-                )

-            RawData.TextToColumns _

-                Destination:=.Range(RAW_DATA_RANGE).Offset(0, DATE_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:="-", _

-                FieldInfo:=Array( _

-                                Array(1, 2), _

-                                Array(2, 2), _

-                                Array(3, 2))

-            

-            Set Location = .Range(RAW_DATA_RANGE).Offset(0, -1)

-            

-            If IsIntraday Then

-                Set RawData = .Range( _

-                            .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + TIME_IDX), _

-                            .Cells(RAW_DATA_RANGE_ROW + row_idx - 1, RAW_DATA_RANGE_COL + TIME_IDX) _

-                    )

-                RawData.TextToColumns _

-                    Destination:=.Range(RAW_DATA_RANGE).Offset(0, TIME_STAMP_OFFSET), _

-                    DataType:=xlDelimited, _

-                    TextQualifier:=xlDoubleQuote, _

-                    ConsecutiveDelimiter:=False, _

-                    Tab:=False, _

-                    Semicolon:=False, _

-                    Comma:=False, _

-                    Space:=False, _

-                    Other:=True, _

-                    OtherChar:=":", _

-                    FieldInfo:=Array( _

-                                    Array(1, 2), _

-                                    Array(2, 2), _

-                                    Array(3, 2))

-                                    

-                

-                For i = 0 To row_idx - 1

-                    Location.Offset(i, 0) = "'" & _

-                            .Range(RAW_DATA_RANGE).Offset(i, DATE_STAMP_OFFSET + 1).Value _

-                            & "/" & .Range(RAW_DATA_RANGE).Offset(i, DATE_STAMP_OFFSET + 2).Value _

-                            & "-" & .Range(RAW_DATA_RANGE).Offset(i, TIME_STAMP_OFFSET).Value _

-                            & ":" & .Range(RAW_DATA_RANGE).Offset(i, TIME_STAMP_OFFSET + 1).Value

-                Next

-            Else

-                For i = 0 To row_idx - 1

-                    Location.Offset(i, 0) = "'" & _

-                            .Range(RAW_DATA_RANGE).Offset(i, DATE_STAMP_OFFSET + 2).Value _

-                            & "/" & .Range(RAW_DATA_RANGE).Offset(i, DATE_STAMP_OFFSET + 1).Value _

-                            & "/" & .Range(RAW_DATA_RANGE).Offset(i, DATE_STAMP_OFFSET).Value

-                Next

-            End If

-            .Parent.Application.DisplayAlerts = True

-        End With ' .Worksheets(RAW_DATA_SHEET)

-    End With ' wb

-    UpdateHistoryFromWeb = True

-End Function

-

-Private Function GetQryPath(wb As Workbook) As String

-    Dim QryPathStr As String

-    Dim IsIntradai As Boolean

-    Dim DayCount As Integer

-    Const DataFormat As String = "&data_format=BROWSER"

-    With wb.Worksheets(VAR_SHEET)

-        IsIntradai = IsNumeric(.Range("DEN_TIME"))

-        

-        If IsIntradai Then

-        

-            QryPathStr = "URL;http://export.rbc.ru/export/"

-            QryPathStr = QryPathStr & .Range("DEN_SOURCE")

-            QryPathStr = QryPathStr & "." & .Range("DEN_BOARD")

-            QryPathStr = QryPathStr & "/?"

-            

-            QryPathStr = QryPathStr & "tickers=" & .Range("DEN_SYMBOL")

-            QryPathStr = QryPathStr & "&period=" & .Range("DEN_TIME")

-            QryPathStr = QryPathStr & "&virtual=PASS"

-            DayCount = .Range("DEN_HISTORY") * .Range("DEN_TIME") \ 420 + 1

-            QryPathStr = QryPathStr & "&lastdays=" & DayCount

-            QryPathStr = QryPathStr & "&separator=,"

-            QryPathStr = QryPathStr & DataFormat

-            QryPathStr = QryPathStr & "&header=1"

-        Else

-            QryPathStr = "URL;http://export.rbc.ru/cgi-bin/export/query_version/export.cgi?"

-            QryPathStr = QryPathStr & "&sourcename=" & .Range("DEN_SOURCE")

-            QryPathStr = QryPathStr & "." & .Range("DEN_BOARD")

-            QryPathStr = QryPathStr & "&tickers=" & .Range("DEN_SYMBOL")

-            QryPathStr = QryPathStr & "&period=DAILY"

-            QryPathStr = QryPathStr & "&virtual=PASS"

-            QryPathStr = QryPathStr & "&lastdays=" & .Range("DEN_HISTORY") + 1

-            QryPathStr = QryPathStr & "&separator=,"

-            QryPathStr = QryPathStr & DataFormat

-            QryPathStr = QryPathStr & "&header=1"

-        End If

-    .Range("LAST_HIST_QRY") = QryPathStr

-    End With

-    GetQryPath = QryPathStr

-End Function

-

-Sub UpdateTickerList(wb As Workbook)

-    Dim Idx, n As Integer

-    Dim ResultLength As Integer

-    Dim Location As Range

-    Dim QryPathStr As String

-    Dim QueryDataName As String

-    Dim DestRangeArea As String

-    

-    QryPathStr = GetListPath(wb)

-    With wb

-        With .Worksheets(VAR_SHEET)

-            Idx = .Range("IDX_DEN_LIST")

-            Set Location = .Range("TICKER_TABLES").Offset(0, (Idx - 1) * 2)

-             .Range("IDX_DEN_SYMBOL") = 1

-            QueryDataName = Location.Offset(0, 0)

-            'Clear table

-            .Range(Location.Offset(1, 0), Location.Offset(65535 - Location.Row, 1)).ClearContents

-            

-            If Not QryExist(Location.Offset(1, 0), QueryDataName) Then

-                QryCreate Location.Offset(1, 0), QueryDataName, QryPathStr

-            Else

-                QryRefresh Location.Offset(1, 0), QueryDataName, QryPathStr

-            End If

-            

-            With .QueryTables(QueryDataName)

-                DestRangeArea = .ResultRange.Name.RefersTo

-                ResultLength = .ResultRange.count

-            End With

-        

-            .Parent.Application.DisplayAlerts = False

-                

-            .Range(DestRangeArea).TextToColumns _

-                Destination:=.Range(DestRangeArea), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:=":", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 9))

-        ' Sort Data

-            Set Location = .Range(.Range(DestRangeArea).Offset(0, 0), .Range(DestRangeArea).Offset(ResultLength - 1, 1))

-            Location.Sort _

-                Key1:=.Range(DestRangeArea).Offset(0, 0), _

-                Order1:=xlAscending, _

-                Header:=xlNo, _

-                OrderCustom:=1, _

-                MatchCase:=False, _

-                Orientation:=xlTopToBottom

-        End With

-        ' Setup Ticker List

-         With .Worksheets(VAR_SHEET)

-            DestRangeArea = .Name & "!" & .Range(.Range(DestRangeArea).Cells(1, 1), .Range(DestRangeArea).Cells(ResultLength - 1, 1)).Address

-         End With

-        With .Worksheets(FORM_SHEET).Shapes("cbxTikers").ControlFormat

-            .ListFillRange = DestRangeArea

-            .ListIndex = 1

-        End With

-        ' Setup Name List

-         With .Worksheets(VAR_SHEET)

-            DestRangeArea = .Name & "!" & .Range(.Range(DestRangeArea).Cells(1, 1), .Range(DestRangeArea).Cells(ResultLength - 1, 1)).Offset(0, 1).Address

-         End With

-        With .Worksheets(FORM_SHEET).Shapes("cbxSecName").ControlFormat

-            .ListFillRange = DestRangeArea

-            .ListIndex = 1

-        End With

-        .Parent.Application.DisplayAlerts = True

-    End With

-End Sub

-

-Private Function GetListPath(wb As Workbook) As String

-    Dim QryPathStr As String

-    With wb.Worksheets(VAR_SHEET)

-        QryPathStr = "URL;http://export.rbc.ru/cgi-bin/export/tickers.cgi?"

-        QryPathStr = QryPathStr & "&source=" & .Range("DEN_SOURCE")

-        QryPathStr = QryPathStr & "." & .Range("DEN_BOARD")

-        .Range("LAST_DIR_QRY") = QryPathStr

-    End With

-    GetListPath = QryPathStr

-End Function

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    Set MyAppEvents.app = Application

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    If Application.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEL сейчас будут закрыты!", vbOKCancel, "$" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close Savechanges:=False

-            Exit Sub

-        End If

-    End If

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False

-    cmSetStandaloneMode

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment wb:=ThisWorkbook, DesignMode:=False

-        If ThisWorkbook.Saved = False Then

-            ThisWorkbook.Save

-        End If

-    End If

-    Application.Caption = Empty

-    Application.CommandBars("Worksheet Menu Bar").Reset

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-        Dim MaxX, MaxY As Integer

-        With ThisWorkbook.Worksheets(FORM_SHEET)

-            MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-            MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-        End With

-

-        With ThisWorkbook.Application

-            .ScreenUpdating = False

-            .WindowState = xlNormal

-            .Height = MaxY

-            .Width = MaxX

-        End With

-End Sub

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-<<<<<<
-======================
-mReadWrite
->>>>>>
-Attribute VB_Name = "mReadWrite"

-Option Explicit

-

-Public Const GOOD_LINE_STATUS As String = "Ok"

-Public Const BAD_LINE_STATUS As String = "N/A"

-

-Function ReadPricesData(Location As Range, Hist As Integer, dt As Integer, _

-              pPriceData As TPriceData) As Integer

-    'Инициализация типа TPriceData из таблицы типа - 1

-    'kопируются не более чем hist последних строк

-    'aPoint - начало таблицы

-    'первые две строки таблицы идентифицирует данные (строки)

-    Dim n, i As Integer

-    

-    'Определение числа строк таблицы - n

-    n = GetLinesCount(Location)

-    ReadPricesData = n

-    If n < 9 Then             'обработать ошибку !!!

-        GoTo done

-    End If

-    ' число строк определено ()

-    If Hist > (n - 3) \ dt + 1 Then ' коррекция истории

-        Hist = (n - 3) \ dt + 1 '

-    End If

-    Dim t, s As Integer

-    For t = 0 To Hist - 1

-        s = n - t * dt - 1

-        pPriceData.D(Hist - t) = Location.Offset(s, DATE_IDX).Value

-        pPriceData.Tm(Hist - t) = Location.Offset(s, TIME_IDX).Value

-        pPriceData.Opn(Hist - t) = Location.Offset(s, OPEN_IDX).Value

-        pPriceData.Hgh(Hist - t) = Location.Offset(s, HIGH_IDX).Value

-        pPriceData.Lw(Hist - t) = Location.Offset(s, LOW_IDX).Value

-        pPriceData.Cls(Hist - t) = Location.Offset(s, CLOSE_IDX).Value

-        pPriceData.Vl(Hist - t) = Location.Offset(s, VOLUME_IDX).Value

-    Next t

-    ReadPricesData = t + 1

-done:

-End Function

-

-Sub ResultLinesOut(Location As Range, pPD As TPriceData, pDen As TDenmark)

-    Dim n As Integer

-    

-    n = GetLinesCount(Location)

-    With Location

-        .Offset(-1, RESIST_IDX) = "Resistance"

-        .Offset(-1, SUPPORT_IDX) = "Support"

-        .Offset(-1, PROJECT_IDX) = "Project"

-    End With

-    Dim t, count, Idx, loc_idx As Integer

-    count = pPD.tC

-    For t = 0 To count - 1

-        Idx = count - t

-        loc_idx = n - t - 1

-        If pDen.ResistanceLine(Idx) > MIN_PRICE_VALUE Then

-            Location.Offset(loc_idx, RESIST_IDX).Value = pDen.ResistanceLine(Idx)

-        End If

-        If pDen.SupportLine(Idx) > MIN_PRICE_VALUE Then

-            Location.Offset(loc_idx, SUPPORT_IDX).Value = pDen.SupportLine(Idx)

-        End If

-        If Abs(pDen.SignalValue) > 1 Then

-            Location.Offset(loc_idx, PROJECT_IDX).Value = pDen.ProjectPrice

-        End If

-    Next t

-End Sub

-

-Sub Out_Table_1(TheRange As Range, pDen As TDenmark, LastIdx As Integer)

-    

-    

-    ' Col = 2 - не определен !!!

-    ' Status - Col = 0

-    If pDen.ResistancePointCount >= 2 Then

-        TheRange.Offset(0, 0).Value = GOOD_LINE_STATUS

-    Else

-        TheRange.Offset(0, 0).Value = BAD_LINE_STATUS

-    End If

-    If pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(1, 0).Value = GOOD_LINE_STATUS

-    Else

-        TheRange.Offset(1, 0).Value = BAD_LINE_STATUS

-    End If

-    ' -----------------------------------------

-    ' углы наклонов линии сопротивления и поддержки - Col = 1

-    If pDen.ResistancePointCount >= 2 Then

-        TheRange.Offset(0, 1).Value = pDen.ResistanceAngle

-    End If

-    If pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(1, 1).Value = pDen.SupportAngle

-    End If

-    If pDen.ResistancePointCount >= 2 And pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(2, 1).Value = (pDen.ResistanceAngle + pDen.SupportAngle) / 2

-    End If

-    ' -----------------------------------------

-    ' Опорные цены линий денмарка на текущий момент

-    If pDen.ResistancePointCount >= 2 Then

-        TheRange.Offset(0, 2).Value = pDen.ResistanceLine(LastIdx)

-    End If

-    If pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(1, 2).Value = pDen.SupportLine(LastIdx)

-    End If

-    If pDen.ResistancePointCount >= 2 And pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(2, 2).Value = _

-            (pDen.ResistanceLine(LastIdx) + pDen.SupportLine(LastIdx)) / 2

-    End If

-    

-End Sub

-

-Sub Out_Table_2(TheRange As Range, TheComment As Range, pPD As TPriceData, pDen As TDenmark)

-    Const ColorIndexBUY = 5

-    Const ColorIndexSELL = 3

-    Const ColorIndexNOTHINK = 14

-    

-    Dim SignalValue_defined, allert_enable  As Boolean

-    Dim Message As String

-    SignalValue_defined = False

-    allert_enable = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_ALLERT_DLG")

-    Message = "Сигнал об изменении тренда не идентифицирован."

-    If pDen.SignalValue >= 2 Then

-        SignalValue_defined = True

-        With TheRange.Offset(0, 0)

-            .Value = "BUY"

-            .Font.Bold = True

-            .Font.ColorIndex = ColorIndexBUY

-        End With

-        TheRange.Offset(0, 1).Value2 = pPD.D(pPD.tC)

-        TheRange.Offset(0, 2).Value2 = pPD.Tm(pPD.tC)

-        TheRange.Offset(0, 3).Value = pDen.SignalValue - 1

-        TheRange.Offset(0, 4).Value = pDen.ProjectPrice

-        Message = "BUY Signal: возможен прорыв вверх нисходящего тренда с уровнем значимости = " & pDen.SignalValue - 1 & " ! "

-    End If

-    If pDen.SignalValue <= -2 Then

-        SignalValue_defined = True

-        With TheRange.Offset(0, 0)

-            .Value = "SELL"

-            .Font.Bold = True

-            .Font.ColorIndex = ColorIndexSELL

-        End With

-        TheRange.Offset(0, 1).Value2 = pPD.D(pPD.tC)

-        TheRange.Offset(0, 2).Value2 = pPD.Tm(pPD.tC)

-        TheRange.Offset(0, 3).Value = pDen.SignalValue + 1

-        TheRange.Offset(0, 4).Value = pDen.ProjectPrice

-        Message = "SELL Signal: возможен прорыв вниз восходящего тренда с уровнем значимости = " & -(pDen.SignalValue + 1) & "!"

-    End If

-    With TheComment

-        .Value = Message

-        .Font.Bold = True

-        Dim color_idx As Integer

-        If SignalValue_defined Then

-            If pDen.SignalValue > 0 Then

-                .Font.ColorIndex = ColorIndexBUY

-            Else

-                .Font.ColorIndex = ColorIndexSELL

-            End If

-        Else

-            .Font.ColorIndex = ColorIndexNOTHINK

-        End If

-    End With

-    If allert_enable And SignalValue_defined Then

-        MsgBox _

-            Prompt:=Message, _

-            Title:=PROGRAM_NAME, _

-            Buttons:=vbOKOnly + vbInformation

-    End If

-End Sub

-

-Sub Out_Table_3(TheRange As Range, pDen As TDenmark)

-    Dim i As Integer

-    For i = 1 To 3

-        TheRange.Offset(i - 1, 0).Value = pDen.Qualificator(i)

-    Next i

-End Sub

-

-Sub Out_Table_4(TheRange As Range, pPD As TPriceData)

-    Dim LastIdx As Integer

-    LastIdx = pPD.tC

-    With TheRange

-        .Offset(0, 0).Value2 = "'" & pPD.D(LastIdx)

-        .Offset(0, 1).Value2 = "'" & pPD.Tm(LastIdx)

-        .Offset(0, 2) = pPD.Opn(LastIdx)

-        .Offset(0, 3) = pPD.Hgh(LastIdx)

-        .Offset(0, 4) = pPD.Lw(LastIdx)

-        .Offset(0, 5) = pPD.Cls(LastIdx)

-        .Offset(0, 6) = pPD.Cls(LastIdx) - pPD.Cls(LastIdx - 1)

-    End With

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Denmark method bar"

-Public Const common_pwd As Long = 31415926

-

-

-Sub SetEnvironment(wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    With Application

-        .Caption = PROGRAM_NAME

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .GetState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-    End With

-    With wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(FORM_SHEET).Select

-    End With

-    CreateCommandBar theApp:=wb.Application

-End Sub

-

-Sub RestoreEnvironment(wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Application.ScreenUpdating = False

-    With wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                     cWindow.DisplayHeadings = True

-                Next

-            End If

-        Next

-        .Worksheets(FORM_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu (True)

-        End If

-        With mobjAppState

-            .RestoreState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(wb As Workbook)

-    With wb

-        .Application.ScreenUpdating = False

-        

-        With .Worksheets(RAW_DATA_SHEET)

-            .Visible = xlVeryHidden

-            .Protect Password:=common_pwd, userInterfaceOnly:=True, Contents:=False

-        End With

-        With .Worksheets(VAR_SHEET)

-            .Visible = xlVeryHidden

-            .Protect Password:=common_pwd, userInterfaceOnly:=True, Contents:=False

-        End With

-        With .Worksheets(FORM_SHEET)

-            .EnableSelection = xlNoSelection

-            .Protect userInterfaceOnly:=True

-            .Select

-        End With

-        With .Worksheets(CHART_SHEET)

-            .EnableSelection = xlNoSelection

-            .Protect userInterfaceOnly:=True

-        End With

-        .Protect Windows:=True

-        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(wb As Workbook)

-    With wb

-        .Unprotect

-        .Application.ScreenUpdating = False

-        With .Worksheets(RAW_DATA_SHEET)

-            .Visible = xlVeryHidden

-            .Unprotect Password:=common_pwd

-        End With

-        With .Worksheets(VAR_SHEET)

-            .Visible = xlVeryHidden

-            .Unprotect Password:=common_pwd

-        End With

-        With .Worksheets(CHART_SHEET)

-            .Select

-            .Unprotect

-        End With

-        With .Worksheets(FORM_SHEET)

-            .Select

-            .Unprotect

-        End With

-        .Application.ScreenUpdating = True

-        

-    End With

-End Sub

-

-<<<<<<
-======================
-mTypes
->>>>>>
-Attribute VB_Name = "mTypes"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Метод г-на Демарка II"

-Public Const PROGRAM_VERSION As String = "version 4.3 Professional"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-

-Public Const ESTIMATION_DATE As Long = 20010615

-'Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "J27"

-

-Public Const RAW_DATA_SHEET As String = "Raw_data"

-Public Const PRICE_TABLE As String = "B1"

-Public Const RAW_DATA_RANGE As String = "B3"

-Public Const RAW_DATA_RANGE_COL As Integer = 2

-Public Const RAW_DATA_RANGE_ROW As Integer = 3

-

-Public Const VAR_SHEET As String = "Var_s"

-

-Public Const CHART_SHEET As String = "Chart"

-

-Public Const MIN_PRICE_VALUE As Double = 0.000001

-Public Const MAX_PRICE_VALUE As Double = 1000000000

-

-' Fields indexes in RAW_DATA_RANGE

-Public Const DATE_IDX As Integer = 0

-Public Const TIME_IDX As Integer = 1

-Public Const OPEN_IDX As Integer = 2

-Public Const HIGH_IDX As Integer = 3

-Public Const LOW_IDX As Integer = 4

-Public Const CLOSE_IDX As Integer = 5

-Public Const VOLUME_IDX As Integer = 6

-Public Const RESIST_IDX As Integer = 7

-Public Const SUPPORT_IDX As Integer = 8

-Public Const PROJECT_IDX As Integer = 9

-

-Public Const DATE_STAMP_OFFSET = PROJECT_IDX + 1

-Public Const TIME_STAMP_OFFSET = PROJECT_IDX + 4

-Public Const DATE_TIME_STAMP_SIZE = 5

-

-Type TPriceData

-    D() As String      ' календарная дата

-    Tm() As String     ' время

-    Opn() As Double    ' Open

-    Hgh() As Double    ' High

-    Lw() As Double     ' Low

-    Cls() As Double    ' Close

-    Vl() As Double     ' Volume

-    tC As Integer      ' Current time

-End Type

-

-Type TDenmark

-   ResistanceLine() As Double           'Resistance line

-   ResistancePoints() As Integer        'Resistance pivot points

-   ResistancePointCount As Integer      'The number of resistance pivot points

-   ResistanceAngle As Double            'Angle of Declination of ResistanceLine

-   

-   SupportLine() As Double              'Support line

-   SupportPoints() As Integer           'Support pivot points

-   SupportPointsCount As Integer        'The number of support pivot points

-   SupportAngle As Double               ' Angle of Declination of SupportLine

-   

-   SignalParameter     As Integer       ' parameter for SignalValue

-   SignalValue      As Integer          'SignalValue

-   

-   

-   Qualificator(1 To 3) As String       ' qualificators

- 

-   ProjectNumber As Integer             ' номер проекции

-   ProjectPrice  As Double              ' проекция цены

-   

-End Type

-

-

-<<<<<<
-======================
-mCommands
->>>>>>
-Attribute VB_Name = "mCommands"

-Option Explicit

-Dim AppRunEnable As New cEnableRun

-

-

-Sub cmViewChart(Optional SwapPage As Boolean = True)

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("BOOL_CHART_READY") = False

-        If .Range("BOOL_DEMARK_READY") <> True Then

-            If .Range("BOOL_AUTORECALC") = True Then

-                evSubmit_Click

-                If .Range("BOOL_DEMARK_READY") <> True Then

-                    Exit Sub

-                End If

-            Else

-                MsgBox _

-                    "График не может быть построен." & vbCrLf & "Исходные данные не обработаны.", _

-                    vbOKOnly + vbExclamation, _

-                    PROGRAM_NAME

-                Exit Sub

-            End If

-        End If

-    End With

-    With ThisWorkbook.Worksheets(FORM_SHEET)

-        With .Range("TABLE_1")

-            Dim test_lines As Boolean

-            test_lines = StrComp(.Cells(1, 1).Value, GOOD_LINE_STATUS)

-            test_lines = test_lines + StrComp(.Cells(2, 1).Value, GOOD_LINE_STATUS)

-            If test_lines <> 0 Then

-                MsgBox _

-                    Prompt:="График не может быть построен." & vbCrLf & "Опорные точки не определены .", _

-                    Title:=PROGRAM_NAME, _

-                    Buttons:=vbOKOnly + vbExclamation

-                Exit Sub

-            End If

-        End With

-        Draw_Chart Not IsEmpty(.Range("TABLE_2").Cells(1, 1))

-    End With

-    With ThisWorkbook

-        .Worksheets(VAR_SHEET).Range("BOOL_CHART_READY") = True

-        If SwapPage Then

-            .Worksheets(CHART_SHEET).Select

-        End If

-    End With

-End Sub

-

-Sub cmViewForm()

-    With ThisWorkbook

-        .Worksheets(FORM_SHEET).Select

-    End With

-End Sub

-

-Sub cmCloseProgram()

-    Dim ResistanceLine

-    ResistanceLine = MsgBox( _

-        Prompt:="Вы желаете завершить программу?", _

-        Buttons:=vbQuestion + vbYesNo, _

-        Title:=PROGRAM_NAME _

-    )

-    If ResistanceLine = vbYes Then

-       Application.Quit

-    End If

-End Sub

-

-Sub cmAbout()

-    dlgAbout.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlgAbout.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlgAbout.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlgAbout.Show

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-        helppath = "hh.exe " & .Path & "\Demark.chm"

-        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub cmSetStandaloneMode()

-    Application.ScreenUpdating = False

-    ProtectionDisable wb:=ThisWorkbook

-    SetEnvironment wb:=ThisWorkbook

-    ProtectionEnable wb:=ThisWorkbook

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    rp = common_pwd

-    dlgGetPwd.edPwd = ""

-    dlgGetPwd.Show

-    If dlgGetPwd.edPwd = rp Then

-        ProtectionDisable wb:=ThisWorkbook

-        RestoreEnvironment wb:=ThisWorkbook, DesignMode:=True

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmPrint()

-    If MsgBox( _

-            Prompt:="Вы желаете распечатать результат?", _

-            Buttons:=vbYesNo + vbQuestion, _

-            Title:=PROGRAM_NAME) = vbNo _

-    Then

-        Exit Sub

-    End If

-    Dim s_ticker, s_name, s_time As String

-    s_ticker = ThisWorkbook.Worksheets(FORM_SHEET).Range("CALC_TICKER_NAME")

-    s_name = ThisWorkbook.Worksheets(FORM_SHEET).Range("CALC_NAME")

-    s_time = Now

-    Application.ScreenUpdating = False

-    cmViewChart SwapPage:=False

-    Application.ScreenUpdating = False

-    With ThisWorkbook.Worksheets(FORM_SHEET).PageSetup

-        .LeftHeader = s_ticker

-        .CenterHeader = PROGRAM_NAME

-        .RightHeader = s_time

-        .LeftFooter = s_name

-        .CenterFooter = "Page &P of &N"

-        .RightFooter = ""

-        .LeftMargin = Application.InchesToPoints(0.75)

-        .RightMargin = Application.InchesToPoints(0.75)

-        .TopMargin = Application.InchesToPoints(0.78)

-        .BottomMargin = Application.InchesToPoints(0.92)

-        .HeaderMargin = Application.InchesToPoints(0.5)

-        .FooterMargin = Application.InchesToPoints(0.5)

-        .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 = 2

-    End With

-    With ThisWorkbook.Worksheets(CHART_SHEET).PageSetup

-        .LeftHeader = s_ticker

-        .CenterHeader = PROGRAM_NAME

-        .RightHeader = s_time

-        .LeftFooter = s_name

-        .CenterFooter = "Page &P of &N"

-        .RightFooter = ""

-        .LeftMargin = Application.InchesToPoints(0.75)

-        .RightMargin = Application.InchesToPoints(0.75)

-        .TopMargin = Application.InchesToPoints(0.78)

-        .BottomMargin = Application.InchesToPoints(0.92)

-        .HeaderMargin = Application.InchesToPoints(0.5)

-        .FooterMargin = Application.InchesToPoints(0.5)

-        .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 = 2

-    End With

-    Application.ScreenUpdating = False

-    ThisWorkbook.Worksheets(Array("MainForm", "Chart")).PrintOut Copies:=1, Collate:=True

-    cmViewForm

-End Sub

-<<<<<<
-======================
-mDemark
->>>>>>
-Attribute VB_Name = "mDemark"

-Option Explicit

-

-Public Const FORM_SHEET As String = "MainForm"

-

-'Form Ranges

-Public Const FILE_NAME As String = "FILE_NAME"

-Public Const TABLE_1 As String = "TABLE_1"

-Public Const TABLE_2 As String = "TABLE_2"

-Public Const TABLE_3 As String = "TABLE_3"

-Public Const TABLE_4 As String = "TABLE_4"

-Public Const TABLE_COMMENT As String = "TABLE_COMMENT"

-

-'Основной тип данных - стандарт 1

-

-'*********************

-Dim PriceDataArray As TPriceData

-Dim DenmarkDataArray As TDenmark

-

-Dim mobjAppRunEnable As New cEnableRun

-

-Sub ClearResultTables()

-    With ThisWorkbook.Worksheets(FORM_SHEET)

-        .Range(TABLE_1).ClearContents ' таблица-1

-        .Range(TABLE_2).ClearContents ' таблица-2

-        .Range(TABLE_3).ClearContents ' таблица-3

-        .Range(TABLE_COMMENT).Value = "" ' коментарий-3

-        .Range(TABLE_4).ClearContents ' таблица-4

-    End With

-End Sub

-

-Function TDenmark_Calc() As Boolean

-    

-    Dim nWindow As Integer

-    Dim bPrevCloseFilter, bSuccCloseFilter As Boolean

-    

-    TDenmark_Calc = False

-    

-    mobjAppRunEnable.EnableRun ESTIMATION_DATE, Now

-    

-    With ThisWorkbook

-        .Application.ScreenUpdating = False

-'1)    Read User data

-        With .Worksheets(VAR_SHEET)

-            DenmarkDataArray.ProjectNumber = .Range("DEN_PROECT").Value

-            DenmarkDataArray.SignalParameter = .Range("DEN_PARAM").Value

-            nWindow = .Range("DEN_WINDOW").Value

-            bPrevCloseFilter = .Range("BOOL_PREV_CLOSE").Value

-            bSuccCloseFilter = .Range("BOOL_SUCC_CLOSE").Value

-        End With

-

-'2)   Memory allocation

-        allocate_memory PriceDataArray, DenmarkDataArray, nWindow

-

-'3)   Read data

-        Dim TheRange As Range

-        Set TheRange = .Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE)

-        Dim LinesCount As Integer

-        LinesCount = ReadPricesData(Location:=TheRange, Hist:=PriceDataArray.tC, dt:=1, pPriceData:=PriceDataArray)

-        

-        'Init function result

-        TDenmark_Calc = LinesCount >= nWindow

-        

-        If LinesCount >= nWindow Then

-        

-'4)   Calculate metod TDenmarkDataArray

-            DetDenmark PriceDataArray, DenmarkDataArray, bPrevCloseFilter, bSuccCloseFilter

-            If Abs(DenmarkDataArray.SignalValue) > 1 Then  'ценовые ориентиры, если есть сигнал

-                DetProj PriceDataArray, DenmarkDataArray

-            End If

-'5)   Write result

-            Application.ScreenUpdating = False

-    

-'6)    Clear interface tables

-            ClearResultTables

-            

-            ResultLinesOut Location:=TheRange.Offset(2, 0), pPD:=PriceDataArray, pDen:=DenmarkDataArray

-            

-            With .Worksheets(FORM_SHEET)

-                Out_Table_1 TheRange:=.Range(TABLE_1).Cells(1, 1), pDen:=DenmarkDataArray, LastIdx:=PriceDataArray.tC

-                Out_Table_2 _

-                        TheRange:=.Range(TABLE_2).Cells(1, 1), _

-                        TheComment:=.Range("TABLE_COMMENT"), _

-                        pPD:=PriceDataArray, _

-                        pDen:=DenmarkDataArray

-                Out_Table_3 TheRange:=.Range(TABLE_3).Cells(1, 1), pDen:=DenmarkDataArray

-                Out_Table_4 TheRange:=.Range(TABLE_4).Cells(1, 1), pPD:=PriceDataArray

-                With .Range(TABLE_1)

-                    .Font.Name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-                With .Range(TABLE_2)

-                    .Font.Name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-                With .Range(TABLE_3)

-                    .Font.Name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-                With .Range(TABLE_4)

-                    .Font.Name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-            End With

-            .Worksheets(VAR_SHEET).Range("BOOL_DEMARK_READY") = True

-        Else

-            MsgBox _

-                Prompt:="Недостаточна глубина выборки данных." _

-                    & vbCrLf & "Измените параметры запроса и пробуйте снова.", _

-                Buttons:=vbOKOnly + vbExclamation, _

-                Title:=PROGRAM_NAME

-            .Worksheets(VAR_SHEET).Range("BOOL_DEMARK_READY") = False

-            .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False

-        End If

-'7)   Free unused memory

-        free_unused_memory PriceDataArray, DenmarkDataArray

-    End With

-End Function

-

-Sub allocate_memory(pPriceData As TPriceData, pDenmarkData As TDenmark, memsize As Integer)

-'  Память под TDenmark

-    ReDim pDenmarkData.ResistanceLine(1 To memsize)

-    ReDim pDenmarkData.ResistancePoints(1 To memsize)

-    ReDim pDenmarkData.SupportLine(1 To memsize)

-    ReDim pDenmarkData.SupportPoints(1 To memsize)

-   

-' Инициализация данных по ценам

-    pPriceData.tC = memsize

-    ReDim pPriceData.D(1 To memsize)

-    ReDim pPriceData.Tm(1 To memsize)

-    ReDim pPriceData.Opn(1 To memsize)

-    ReDim pPriceData.Hgh(1 To memsize)

-    ReDim pPriceData.Lw(1 To memsize)

-    ReDim pPriceData.Cls(1 To memsize)

-    ReDim pPriceData.Vl(1 To memsize)

-

-End Sub

-

-Sub free_unused_memory(pP As TPriceData, pD As TDenmark)

-'   Free Prices

-    pP.tC = 0

-    Erase pP.D

-    Erase pP.Tm

-    Erase pP.Opn

-    Erase pP.Hgh

-    Erase pP.Lw

-    Erase pP.Cls

-    Erase pP.Vl

-    

-'Free TDenmark

-    Erase pD.ResistanceLine

-    Erase pD.ResistancePoints

-    Erase pD.SupportLine

-    Erase pD.SupportPoints

-End Sub

-

-

-'*****************************************

-Sub DetDenmark(pPriceData As TPriceData, pDenmarkData As TDenmark, ByVal ClosePrev2 As Boolean, ByVal CloseSucc1 As Boolean)

-' определение элементов данных Денмарка (в цифровой форме)

-' на текущий момент времени времени tC

-' ИСХОДНЫЕ ДАННЫЕ:

-' pPriceData  - окно, стандартная форма данных по ценам (определена)

-' ClosePrev2 - H(t) > max{ H(t-1), H(t+1)} и  H(t) > Close(t-2)

-' CloseSucc1 - H(t) > max{ H(t-1), H(t+1)}  и  R(t+1) > Close(t+1)

-' РЕЗУЛЬТАТ:

-' pDenmarkData - элементы данных Денмарка (память выделена, SignalParameter - определен):

-' линии ResistanceLine,SupportLine их наклоны, опорные точки, сигналы к покупке или продаже

-' SignalValue = 0 сигнал отсутствует

-' SignalValue < 0 прорыв восходящего тренда (сигнал продажи)

-' SignalValue > 0 прорыв нисходящего тренда (сигнал покупки)

-' Если pDenmarkData.ResistancePointCount < 2, то элементы ResistanceLine не определяются

-' Если pDenmarkData.SupportPointsCount < 2, то элементы SupportLine не определяются

-

-' начальная установка

-    Const QUALIFICATOR_DISABLE As String = "-"

-    Const QUALIFICATOR_ENABLE As String = "Signal"

-    

-    Dim UpQual(1 To 3) As String

-    Dim DownQual(1 To 3) As String

-    Dim UpSignal, DownSignal As Integer

-    Dim i As Integer

-    

-    pDenmarkData.SignalValue = 0

-    UpSignal = 0

-    DownSignal = 0

-    

-    For i = 1 To 3

-        pDenmarkData.Qualificator(i) = QUALIFICATOR_DISABLE

-        UpQual(i) = QUALIFICATOR_DISABLE

-        DownQual(i) = QUALIFICATOR_DISABLE

-    Next i

-    

-' определение линии поддержки и сопротивления

-    ResLine _

-        pPriceData, _

-        pPriceData.tC, _

-        pDenmarkData.ResistancePointCount, _

-        pDenmarkData.ResistanceLine, _

-        pDenmarkData.ResistancePoints, _

-        ClosePrev2, _

-        CloseSucc1

-        

-    SuppLine _

-        pPriceData, _

-        pPriceData.tC, _

-        pDenmarkData.SupportPointsCount, _

-        pDenmarkData.SupportLine, _

-        pDenmarkData.SupportPoints, _

-        ClosePrev2, _

-        CloseSucc1

-

-        

-        

-    If pDenmarkData.ResistancePointCount >= 2 Then

-        pDenmarkData.ResistanceAngle = 57.29578 * _

-            Atn(pDenmarkData.ResistanceLine(pPriceData.tC) - _

-                pDenmarkData.ResistanceLine(pPriceData.tC - 1))

-    End If

-    If pDenmarkData.SupportPointsCount >= 2 Then

-        pDenmarkData.SupportAngle = 57.29578 * _

-            Atn(pDenmarkData.SupportLine(pPriceData.tC) - _

-                pDenmarkData.SupportLine(pPriceData.tC - 1))

-    End If

-

-' ФОРМИРОВАНИЕ СИГНАЛА ----------------------------------

-    Dim t As Integer

-' 1. случай нисходящего тренда: ResistanceLine определен и ResistanceLine падает *************

-    If pDenmarkData.ResistancePointCount >= 2 And pDenmarkData.ResistanceAngle < 0 Then

-'    необходимое условие прорыва вверх

-        If pDenmarkData.ResistanceLine(pPriceData.tC) < pPriceData.Cls(pPriceData.tC) Then

-            UpSignal = 1

-            For t = pPriceData.tC - pDenmarkData.SignalParameter To pPriceData.tC - 1

-                If pPriceData.Cls(t) > pDenmarkData.ResistanceLine(t) Then

-                    UpSignal = 0

-                    Exit For

-                End If

-            Next t

-        End If

-        If UpSignal = 1 Then

-'       Qualificator-1: close убывает накануне прорыва

-            If pPriceData.Cls(pPriceData.tC - 2) > pPriceData.Cls(pPriceData.tC - 1) Then

-                UpSignal = UpSignal + 1

-                UpQual(1) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-2: open > ResistanceLine в момент прорыва

-            If pPriceData.Opn(pPriceData.tC) > pDenmarkData.ResistanceLine(pPriceData.tC) Then

-                UpSignal = UpSignal + 1

-                UpQual(2) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-3 - demand value < ResistanceLine(tC)

-            If 2 * pPriceData.Cls(pPriceData.tC - 1) - pPriceData.Lw(pPriceData.tC - 1) < pDenmarkData.ResistanceLine(pPriceData.tC) Then

-                UpSignal = UpSignal + 1

-                UpQual(3) = QUALIFICATOR_ENABLE

-            End If

-        End If

-    End If  ' нисходящий тренд обработан ************************************

-

-' 2. случай восходящего тренда: SupportLine определен и SupportLine растет

-    If pDenmarkData.SupportPointsCount >= 2 And pDenmarkData.SupportAngle > 0 Then

-'    ---------------------------------------------

-'    необходимое условие прорыва вниз

-        If pPriceData.Cls(pPriceData.tC) < pDenmarkData.SupportLine(pPriceData.tC) Then

-            DownSignal = -1

-            For t = pPriceData.tC - pDenmarkData.SignalParameter To pPriceData.tC - 1

-                If pPriceData.Cls(t) < pDenmarkData.SupportLine(t) Then

-                    DownSignal = 0

-                    Exit For

-                End If

-            Next t

-        End If

-        If DownSignal = -1 Then

-'       Qualificator-1: Close растет накануне прорыва

-            If pPriceData.Cls(pPriceData.tC - 2) < pPriceData.Cls(pPriceData.tC - 1) Then

-                DownSignal = DownSignal - 1

-                DownQual(1) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-2: Open ниже ResistanceLine в момент прорыва

-            If pPriceData.Opn(pPriceData.tC) < pDenmarkData.SupportLine(pPriceData.tC) Then

-                DownSignal = DownSignal - 1

-                DownQual(2) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-3 - supply value(t-1) > SupportLine(tC)

-            If 2 * pPriceData.Cls(pPriceData.tC - 1) - pPriceData.Hgh(pPriceData.tC - 1) > pDenmarkData.SupportLine(pPriceData.tC) Then

-                DownSignal = DownSignal - 1

-                DownQual(3) = QUALIFICATOR_ENABLE

-            End If

-        End If

-'    ---------------------------------------------

-    End If

-'      Существует преобладание тенденции

-    If Abs(DownSignal) <> UpSignal Then

-        If Abs(DownSignal) > UpSignal Then

-            pDenmarkData.SignalValue = DownSignal

-            For i = 1 To 3

-                pDenmarkData.Qualificator(i) = DownQual(i)

-            Next i

-        Else

-            pDenmarkData.SignalValue = UpSignal

-            For i = 1 To 3

-                pDenmarkData.Qualificator(i) = UpQual(i)

-            Next i

-        End If

-    End If

-End Sub

-

-Sub DetProj(pPriceData As TPriceData, pDenmarkData As TDenmark)

-'Определение проекции при наличии сигнала: |Signal| > 1

-'Услловие применимости |Signal| > 1 !!!

-    Dim pM As Double, t As Integer, Tm As Integer, tL As Integer

-

-    If pDenmarkData.SignalValue >= 2 Then  ' СИГНАЛ ПОКУПКИ

-

-        tL = pDenmarkData.ResistancePoints(pDenmarkData.ResistancePointCount)     ' tR determination

-        If tL = pPriceData.tC Then

-            tL = pDenmarkData.ResistancePoints(pDenmarkData.ResistancePointCount - 1)

-        End If

-

-'  Projections 1,2 --------------------------------------------

-        If pDenmarkData.ProjectNumber >= 1 And pDenmarkData.ProjectNumber <= 2 Then

-'           t* = Arg min {L(t) : t R <= t  <= tb ,  L(t) < ResistanceLine(t)},

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Lw(Tm) ' L(t-1) < ResistanceLine(t-1) for t - break point !

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Lw(t) < pM And pPriceData.Lw(t) < pDenmarkData.ResistanceLine(t) Then

-                    pM = pPriceData.Lw(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            If pDenmarkData.ProjectNumber = 1 Then

-'               P1( tb) = ResistanceLine(tb) + ResistanceLine(t*) - L(t*)

-                pDenmarkData.ProjectPrice = pDenmarkData.ResistanceLine(pPriceData.tC) + pDenmarkData.ResistanceLine(Tm) - pPriceData.Lw(Tm)

-            Else

-                pDenmarkData.ProjectPrice = pDenmarkData.ResistanceLine(pPriceData.tC) + pDenmarkData.ResistanceLine(Tm) - pPriceData.Cls(Tm)

-            End If

-        End If ' pDenmarkData.ProjectNumber >= 1 And pDenmarkData.ProjectNumber <= 2

-   

-'  ----------------------------------------------------------------

-'  Projections 3

-        If pDenmarkData.ProjectNumber = 3 Then

-'           t*  = Arg min { С(t) : t R <= t  <= tb ,  C(t) < ResistanceLine(t)}

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Cls(Tm)

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Cls(t) < pM And pPriceData.Cls(t) < pDenmarkData.ResistanceLine(t) Then

-                    pM = pPriceData.Cls(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            pDenmarkData.ProjectPrice = pDenmarkData.ResistanceLine(pPriceData.tC) + pDenmarkData.ResistanceLine(Tm) - pPriceData.Cls(Tm)

-        End If

-    End If ' pDenmarkData.SignalValue >= 2

-

-'-------------------------------------------------------------------

-'*******************************************************************

-' ПРОЕКЦИЯ ДЛЯ СИГНАЛА ПРОДАЖИ

-    If pDenmarkData.SignalValue <= -2 Then

-        tL = pDenmarkData.SupportPoints(pDenmarkData.SupportPointsCount)  ' tR determination

-        If tL = pPriceData.tC Then

-            tL = pDenmarkData.ResistancePoints(pDenmarkData.SupportPointsCount - 1)

-        End If

-

-'  Projections 1,2 --------------------------------------------

-        If pDenmarkData.ProjectNumber = 1 Or pDenmarkData.ProjectNumber = 2 Then

-'           t* = Arg max {H(t) : t R <= t  <= tb ,  H(t) > SupportLine(t)},

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Hgh(Tm) ' H(t-1) > SupportLine(t-1) for t - break point !

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Hgh(t) > pM And pPriceData.Hgh(t) > pDenmarkData.SupportLine(t) Then

-                    pM = pPriceData.Hgh(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            If pDenmarkData.ProjectNumber = 1 Then

- '              P1( tb) = SupportLine(tb) + SupportLine(t*) - H(t*)

-                pDenmarkData.ProjectPrice = pDenmarkData.SupportLine(pPriceData.tC) + pDenmarkData.SupportLine(Tm) - pPriceData.Hgh(Tm)

-            Else

-'               P2( tb) = SupportLine(tb) + SupportLine(t*) - C(t*)

-                pDenmarkData.ProjectPrice = pDenmarkData.SupportLine(pPriceData.tC) + pDenmarkData.SupportLine(Tm) - pPriceData.Cls(Tm)

-            End If

-        End If

-   

-'  ----------------------------------------------------------------

-'  Projections 3

-        If pDenmarkData.ProjectNumber = 3 Then

-'           t*  = Arg max { С(t) : t R <= t  <= tb ,  C(t) >  SupportLine(t)}

-'           P3( tb) = SupportLine(tb) + SupportLine(t*) - C(t*)

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Cls(Tm)

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pM < pPriceData.Cls(t) And pPriceData.Cls(t) > pDenmarkData.SupportLine(t) Then

-                    pM = pPriceData.Cls(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            pDenmarkData.ProjectPrice = pDenmarkData.SupportLine(pPriceData.tC) + pDenmarkData.SupportLine(Tm) - pPriceData.Cls(Tm)

-        End If

-    End If ' pDenmarkData.SignalValue <= -2

-End Sub

-

-Sub ResLine(pP As TPriceData, tE As Integer, ResistancePointCount As Integer, _

-            ResistanceLine() As Double, s() As Integer, ClosePrev2 As Boolean, CloseSucc1 As Boolean)

-' Определение линии сопротивления по Демарку [1]

-' Основной вариант

-' ИСХОДНЫЕ ДАННЫЕ:

-' High, dom(High) = [1, tE]

-' ClosePrev2 - H(t) > max{ H(t-1), H(t+1)} и  H(t) > Close(t-2)

-' CloseSucc1 - H(t) > max{ H(t-1), H(t+1)}  и  R(t+1) > Close(t+1)

-' РЕЗУЛЬТАТ:

-' 1) линия сопротивления ResistanceLine, dom(ResistanceLine)=[s(1), tE], и

-' 2) s = {s(1), s(2), ..., s(ResistancePointCount)}, s(1) < s(2) < ...< s(ResistancePointCount)

-'   ( s(ResistancePointCount)<= tE )- опорные точки

-' 3) число опорных точек ResistancePointCount.

-' 4) s(1) -  первый момент времени с которого определена SupportLine

-'    то есть dom{Supp} = [s(1), tC]

-' Прим. Если число опорных точек окажется < 2, то линия

-' сопротивления не определяется. В этом случае следует

-' увеличить историю tE !!!

-    Dim t As Integer, i As Integer

-    Dim v As Double

-    Dim IsGoodPoint As Boolean

-  

-'1 определение опорных моментов времени

-    ResistancePointCount = 0

-    For t = 3 To tE - 1

- '      v = max{high(t-1), high(t+1)} < high(t)}

-        v = pP.Hgh(t - 1)

-        If v < pP.Hgh(t + 1) Then

-            v = pP.Hgh(t + 1)

-        End If

-        IsGoodPoint = pP.Hgh(t) > v

-        If IsGoodPoint And ClosePrev2 Then

-            IsGoodPoint = IsGoodPoint And (pP.Cls(t - 2) < pP.Hgh(t))

-        End If

-        

-        If IsGoodPoint Then       'alt.: v >= High(t + 1)

-            s(ResistancePointCount + 1) = t: ResistancePointCount = ResistancePointCount + 1

-        End If

-    Next t

-    

-loop_:

-    

-    If ResistancePointCount < 2 Then

-        GoTo done

-    End If

-

-' 2 определение линии сопротивления

-    ResistanceLine(s(1)) = pP.Hgh(s(1))

-    For i = 2 To ResistancePointCount

-        ResistanceLine(s(i)) = pP.Hgh(s(i))

-        v = (pP.Hgh(s(i)) - pP.Hgh(s(i - 1))) / (s(i) - s(i - 1))

-        For t = s(i - 1) + 1 To s(i) - 1

-            ResistanceLine(t) = pP.Hgh(s(i - 1)) + v * (t - s(i - 1))

-        Next t

-    Next i

-    If s(ResistancePointCount) < tE Then

-        v = (pP.Hgh(s(ResistancePointCount)) - pP.Hgh(s(ResistancePointCount - 1))) / (s(ResistancePointCount) - s(ResistancePointCount - 1))

-        For t = s(ResistancePointCount) + 1 To tE

-            ResistanceLine(t) = pP.Hgh(s(ResistancePointCount - 1)) + v * (t - s(ResistancePointCount - 1))

-        Next t

-    End If

-    If CloseSucc1 Then

-        For t = 1 To ResistancePointCount

-            If ResistanceLine(s(t) + 1) < pP.Cls(s(t) + 1) Then

-                ResistancePointCount = ResistancePointCount - 1

-                ' удалить точку

-                For i = t To ResistancePointCount

-                    s(i) = s(i + 1)

-                Next i

-                s(ResistancePointCount + 1) = 0

-                ' очистить массив линии

-                Dim Lb, Rb As Integer

-                Lb = LBound(ResistanceLine)

-                Rb = UBound(ResistanceLine)

-                Erase ResistanceLine

-                ReDim ResistanceLine(Lb To Rb)

-                GoTo loop_

-            End If

-        Next t

-    End If

-    

-done:

-End Sub

-

-Sub SuppLine(pP As TPriceData, tE As Integer, SupportPointsCount As Integer, _

-               SupportLine() As Double, s() As Integer, ClosePrev2 As Boolean, CloseSucc1 As Boolean)

-' Определение линии поддержки по Демарку [1] (от конца)

-' Исходные данные:

-' Low, dom(Low) = [1, tE]

-' ClosePrev2 - H(t) > max{ H(t-1), H(t+1)} и  H(t) > Close(t-2)

-' CloseSucc1 - H(t) > max{ H(t-1), H(t+1)}  и  R(t+1) > Close(t+1)

-' Результат:

-' 1) линия сопротивления SupportLine, dom(SupportLine)=[s(1), tE],

-' 2) s = {s(1), s(2), ..., s(SupportPointsCount)}, s(1) < s(2) < ...< s(SupportPointsCount) -

-'    опорные точки

-' 3) число опорных точек SupportPointsCount.

-' Прим. Если фактическое число опорных точек окажется < 2, то линия

-' поддержки не определяется.

-    Dim t As Integer, i As Integer

-    Dim v As Double

-    Dim IsGoodPoint As Boolean

-    

-'1 определение опорных моментов времени

-     SupportPointsCount = 0

-    For t = 3 To tE - 1

-'       v = min{Low(t-1), Low(t+1)} > Low(t)

-        v = pP.Lw(t - 1)

-        If v > pP.Lw(t + 1) Then

-            v = pP.Lw(t + 1)

-        End If

-        

-        IsGoodPoint = pP.Lw(t) < v

-        

-        If IsGoodPoint And ClosePrev2 Then

-            IsGoodPoint = IsGoodPoint And (pP.Cls(t - 2) > pP.Lw(t))

-        End If

-        

-        If IsGoodPoint Then     'alt.: v >= High(t + 1)

-            s(SupportPointsCount + 1) = t: SupportPointsCount = SupportPointsCount + 1

-        End If

-    Next t

-

-loop_:

-    If SupportPointsCount < 2 Then

-        GoTo done

-    End If

-' 2 определение линии поддержки

-    

-    SupportLine(s(1)) = pP.Lw(s(1))

-    For i = 2 To SupportPointsCount

-        SupportLine(s(i)) = pP.Lw(s(i))

-        v = (pP.Lw(s(i)) - pP.Lw(s(i - 1))) / (s(i) - s(i - 1))

-        For t = s(i - 1) + 1 To s(i) - 1

-            SupportLine(t) = pP.Lw(s(i - 1)) + v * (t - s(i - 1))

-        Next t

-    Next i

-    If s(1) < tE Then

-        v = (pP.Lw(s(SupportPointsCount)) - pP.Lw(s(SupportPointsCount - 1))) / (s(SupportPointsCount) - s(SupportPointsCount - 1))

-        For t = s(SupportPointsCount) + 1 To tE

-            SupportLine(t) = pP.Lw(s(SupportPointsCount - 1)) + v * (t - s(SupportPointsCount - 1))

-        Next t

-    End If

-    If CloseSucc1 Then

-        For t = 1 To SupportPointsCount

-            If SupportLine(s(t) + 1) > pP.Cls(s(t) + 1) Then

-                SupportPointsCount = SupportPointsCount - 1

-                ' удалить точку

-                For i = t To SupportPointsCount

-                    s(i) = s(i + 1)

-                Next i

-                s(SupportPointsCount + 1) = 0

-                ' очистить массив линии

-                Dim Lb, Rb As Integer

-                Lb = LBound(SupportLine)

-                Rb = UBound(SupportLine)

-                Erase SupportLine

-                ReDim SupportLine(Lb To Rb)

-                GoTo loop_

-            End If

-        Next t

-    End If

-done:

-End Sub

-

-<<<<<<
-======================
-mChart
->>>>>>
-Attribute VB_Name = "mChart"

-Option Explicit

-

-Const CHART_NAME As String = "PriceChart"

-

-Sub Draw_Chart(SignalDefined As Boolean)

-

-    Dim n As Integer

-    Dim theChart As Chart

-    Dim ChartDataAria, szLastNumber As String

-    Dim MinYScale As Double

-    

-    

-    With ThisWorkbook

-' Checking data

-' Disable screen out

-        .Application.Cursor = xlWait

-        .Application.ScreenUpdating = False

-' Create series range

-        n = GetLinesCount(Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE))

-        szLastNumber = n + 1

-        If SignalDefined Then

-            ChartDataAria = "A2:A" & szLastNumber _

-                        & ",D2:D" & szLastNumber _

-                        & ",G2:G" & szLastNumber _

-                        & ",I2:K" & szLastNumber

-        Else

-            ChartDataAria = "A2:A" & szLastNumber _

-                        & ",D2:D" & szLastNumber _

-                        & ",G2:G" & szLastNumber _

-                        & ",I2:J" & szLastNumber

-        End If

-        MinYScale = GetMinValue(.Worksheets(RAW_DATA_SHEET).Range(ChartDataAria))

-' Find and delete old chart

-        .Worksheets(CHART_SHEET).Unprotect

-        Dim WindowWidth, WindowHeight As Integer

-        With .Worksheets(CHART_SHEET)

-            WindowWidth = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-            WindowHeight = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-        End With

-        

-        

-        With .Worksheets(CHART_SHEET).ChartObjects

-            .Delete

-            With .Add(5, 5, WindowWidth - 10, WindowHeight - 10)

-                .SendToBack

-                Set theChart = .Chart

-            End With

-' Create a chart

-        End With

-        With theChart

-            .ChartType = xlLine

-            .SetSourceData Source:=Sheets(RAW_DATA_SHEET).Range( _

-                    ChartDataAria), PlotBy:=xlColumns

-'                   .Location Where:=xlLocationAsObject, Name:=CHART_SHEET

-            .HasTitle = True

-            With .ChartTitle

-                .Text = ThisWorkbook.Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE).Value

-                With .Font

-                    .Size = 8

-                    .Bold = True

-                End With

-            End With

-            .HasLegend = True

-            With .Legend

-                .Position = xlTop

-                With .Font

-                    .Name = "Arial"

-                    .Size = 8

-                End With

-            End With

-            .HasDataTable = False

-            With .Axes(xlCategory)

-                .HasMajorGridlines = True

-                .HasMinorGridlines = False

-                .TickLabels.Orientation = xlUpward

-                With .MajorGridlines.Border

-                    .ColorIndex = 48

-                    .Weight = xlHairline

-                    .LineStyle = xlDot

-                End With

-                .CrossesAt = 1

-                .TickLabelSpacing = 1

-                .TickMarkSpacing = 1

-                .AxisBetweenCategories = False

-                .ReversePlotOrder = False

-                .TickLabels.AutoScaleFont = True

-                With .TickLabels.Font

-                    .Name = "Arial"

-                    .Size = 8

-                End With

-            End With

-            With .Axes(xlValue)

-                .HasMajorGridlines = True

-                .HasMinorGridlines = False

-                With .MajorGridlines.Border

-                    .ColorIndex = 48

-                    .Weight = xlHairline

-                    .LineStyle = xlDot

-                End With

-                .MinimumScale = MinYScale

-                .MaximumScaleIsAuto = True

-                .MinorUnitIsAuto = True

-                .MajorUnitIsAuto = True

-                .Crosses = xlCustom

-                .CrossesAt = MinYScale

-                .ReversePlotOrder = False

-                .ScaleType = xlLinear

-                .TickLabels.AutoScaleFont = True

-                With .TickLabels.Font

-                    .Name = "Arial"

-                    .Size = 9

-                End With

-            End With

-            .ChartTitle.Top = 5

-            .ChartTitle.Left = 5

-            With .Legend

-                .Top = 5

-                .Fill.OneColorGradient _

-                    Style:=msoGradientHorizontal, _

-                    Variant:=3, _

-                    Degree:=0.303913939116503

-                .Fill.Visible = True

-                .Fill.ForeColor.SchemeColor = 71

-            End With

-            .PlotArea.Left = 10

-            .PlotArea.Top = .Legend.Top + .Legend.Height + 5

-            .PlotArea.Width = .ChartArea.Width - 20

-            .PlotArea.Height = .ChartArea.Height - .PlotArea.Top

-            

-' Tune OPEN line

-            With .SeriesCollection(1)

-                .Border.LineStyle = xlNone

-                .MarkerBackgroundColorIndex = xlNone

-                .MarkerForegroundColorIndex = 1

-                .MarkerStyle = xlPlus

-                .Smooth = False

-                .MarkerSize = 9

-                .Shadow = False

-            End With

-' Tune CLOSE line

-            With .SeriesCollection(2)

-                .Border.ColorIndex = 10

-                .Border.Weight = xlMedium

-                .Border.LineStyle = xlContinuous

-            End With

-' Tune RESISTANCE line

-            With .SeriesCollection(3)

-                .Border.ColorIndex = 3

-                .Border.Weight = xlThin

-                .Border.LineStyle = xlContinuous

-            End With

-' Tune SUUPORT line

-            With .SeriesCollection(4)

-                .Border.ColorIndex = 25

-                .Border.Weight = xlThin

-                .Border.LineStyle = xlContinuous

-            End With

-            If SignalDefined Then

-                With .SeriesCollection(5)

-                    .Border.ColorIndex = 6

-                    .Border.Weight = xlThin

-                    .Border.LineStyle = xlDot

-                End With

-            End If

-        End With

-        .Application.Cursor = xlDefault

-        With .Worksheets(CHART_SHEET)

-            .Select

-            .Protect userInterfaceOnly:=True

-        End With

-    End With

-End Sub

-

-Function GetMinValue(DataRange As Range) As Double

-    Dim Cell As Range

-    Dim MinValue, MaxValue, RangeValue, CorrectValue, Mult As Double

-    MinValue = MAX_PRICE_VALUE

-    MaxValue = MIN_PRICE_VALUE

-    For Each Cell In DataRange

-        If Not IsEmpty(Cell) And IsNumeric(Cell) Then

-            If Cell > MIN_PRICE_VALUE Then

-                If Cell < MinValue Then

-                    MinValue = Cell

-                End If

-                If Cell > MaxValue Then

-                    MaxValue = Cell

-                End If

-            End If

-        End If

-    Next

-    RangeValue = MaxValue - MinValue

-    If RangeValue < 0 Then

-        MinValue = 0

-    Else

-        CorrectValue = RangeValue / 4

-        Mult = MIN_PRICE_VALUE

-        While MinValue - Int(MinValue * Mult) / Mult > CorrectValue

-            Mult = Mult * 10

-        Wend

-        MinValue = Int(MinValue * Mult) / Mult

-    End If

-    GetMinValue = MinValue

-End Function

-

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub GetState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.Name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars("Worksheet Menu Bar").Visible = False

-End Sub

-

-

-Public Sub RestoreState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars("Worksheet Menu Bar").Visible = True

-End Sub

-

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{029959BC-3504-4E6C-9EE2-769DD246AFF4}{24215672-3013-4BC6-A108-879F096F56E2}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-

-Private Sub CommandButton1_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-mWebQeury
->>>>>>
-Attribute VB_Name = "mWebQeury"

-Option Explicit

-

-Public Const Qry_DELETE_ALL As String = "Qry_DELETE_ALL"

-Public Const Qry_PATH_NO_CHANGE As String = "Qry_PATH_NO_CHANGE"

-

-

-Sub QryCreate(QryRange As Range, QryName As String, QryPath As String, Optional RefreshBkgnd = False)

-    Dim WebQuery As QueryTable

-    QryDelete QryRange:=QryRange, QryName:=QryName

-    

-    Set WebQuery = QryRange.Worksheet.QueryTables.Add( _

-            Connection:=QryPath, _

-            Destination:=QryRange)

-    

-    With WebQuery

-        .FieldNames = False

-        .Name = QryName

-        .RefreshStyle = xlOverwriteCells

-        .RowNumbers = False

-        .FillAdjacentFormulas = False

-        .RefreshOnFileOpen = False

-        .HasAutoFormat = False

-        .BackgroundQuery = False

-        .TablesOnlyFromHTML = False

-        .Refresh BackgroundQuery:=RefreshBkgnd

-        .SavePassword = False

-        .SaveData = True

-    End With

-End Sub

-

-Function QryRefresh(QryRange As Range, QryName As String, Optional QryPath As String = Qry_PATH_NO_CHANGE, Optional Background As Boolean = False) As Boolean

-    Dim qry_result As Boolean

-    qry_result = False

-    If QryExist(QryRange, QryName) Then

-        With QryRange.Worksheet.QueryTables(QryName)

-            If QryPath <> Qry_PATH_NO_CHANGE Then

-                .Connection = QryPath

-            End If

-            .Refresh BackgroundQuery:=Background

-            qry_result = True

-        End With

-    End If

-    QryRefresh = qry_result

-End Function

-

-Sub QryDelete(QryRange As Range, Optional QryName As String = Qry_DELETE_ALL)

-    Dim WebQuery As QueryTable

-    For Each WebQuery In QryRange.Worksheet.QueryTables

-        If QryName = Qry_DELETE_ALL Or WebQuery.Name = QryName Then

-            WebQuery.Delete

-        End If

-    Next

-End Sub

-

-Function QryExist(QryRange As Range, QryName As String) As Boolean

-    Dim WebQuery As QueryTable

-    For Each WebQuery In QryRange.Worksheet.QueryTables

-        If WebQuery.Name = QryName Then

-            QryExist = True

-            Exit For

-        End If

-    Next

-End Function

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Sub CreateCommandBar(theApp As Application)

-Attribute CreateCommandBar.VB_ProcData.VB_Invoke_Func = "R\n14"

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible + msoBarNoCustomize + msoBarNoMove + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Print"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 4

-                        .OnAction = "cmPrint"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Contents"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 49

-                        .OnAction = "cmHelpContents"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible + msoBarNoCustomize + msoBarNoMove + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(Flag As Boolean)

-    If Flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars("Worksheet Menu Bar")

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        cmHelpContents

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mTool
->>>>>>
-Attribute VB_Name = "mTool"

-Option Explicit

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub tool_delete_all_tables()

-    QryDelete ThisWorkbook.Worksheets(RAW_DATA_SHEET).Range("A1")

-End Sub

-

-Sub tool_delete_all_charts(theSheet As Worksheet)

-    Dim theChart As Chart

-    For Each theChart In theSheet

-        theChart.Unprotect

-        theChart.Delete

-    Next

-End Sub

-

-Sub DateTimeTest()

-    Dim the_date

-    Dim the_time

-    the_date = DateValue(Now)

-    the_time = TimeValue(Now)

-End Sub

-

-

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{E22E292C-EF77-43F5-95D9-E9040592C04E}{0F23FD26-4F1A-4496-8297-1B6D21944441}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-

-

-Private Sub App_WorkbookOpen(ByVal wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If Application.Workbooks.count > 1 Then

-        wbname = wb.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKCancel, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            wb.Close Savechanges:=False

-        End If

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-mDataCommands
->>>>>>
-Attribute VB_Name = "mDataCommands"

-Option Explicit

-

-Sub evFileOpen()

-    Dim fileToOpen As String

-    Dim wb As Workbook

-    Dim Result As Integer

-

-    Set wb = ThisWorkbook

-    With wb

-        If .Worksheets(VAR_SHEET).Range("DEN_SOURCE") <> "file" Then

-            .Worksheets(VAR_SHEET).Range("IDX_DEN_LIST") = 6

-            evGroupChange

-        End If

-        If .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False Or .Worksheets(VAR_SHEET).Range("BOOL_LOAD_DATA") = True Then

-                fileToOpen = .Application.GetOpenFilename( _

-                                  "Text Files (*.txt), *.txt, Data Files (*.csv), *.csv")

-        End If

-          

-        If fileToOpen <> "False" Then

-            .Worksheets(FORM_SHEET).Range(FILE_NAME) = fileToOpen

-            Result = UpdateHistoryFromFile(wb, fileToOpen)

-            .Worksheets(VAR_SHEET).Range("LAST_FILE_QRY") = fileToOpen

-            .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False

-            .Worksheets(VAR_SHEET).Range("BOOL_DEMARK_READY") = False

-            

-            ClearResultTables

-        

-            Select Case Result

-            Case FUNCRES_FILE_OK

-                sbCalcFile

-            Case FUNCRES_FILE_VERY_SMALL

-                .Worksheets(FORM_SHEET).Range("CALC_TICKER_NAME") = MSG_FILE_VERY_SMALL

-                MsgBox MSG_FILE_VERY_SMALL, vbOKOnly, PROGRAM_NAME

-            Case FUNCRES_FILE_INVALID_FORMAT

-                .Worksheets(FORM_SHEET).Range("CALC_TICKER_NAME") = MSG_FILE_INVALID_FORMAT

-                MsgBox MSG_FILE_INVALID_FORMAT, vbOKOnly, PROGRAM_NAME

-            End Select

-'            .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False

-        End If

-    End With 'wb

-End Sub

-

-Sub sbCalcFile()

-    Dim wb As Workbook

-    Dim ticker As String

-    

-    Set wb = ThisWorkbook

-    With wb

-        ClearResultTables

-        

-        .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = True

-        If TDenmark_Calc Then

-            ticker = .Worksheets(RAW_DATA_SHEET).Range("B1")

-            Worksheets(FORM_SHEET).Range("CALC_TICKER_NAME") = ticker

-        End If

-    End With 'wb

-End Sub

-

-Sub sbCalcWeb()

-    Dim wb As Workbook

-    Dim ticker As String

-    Dim Period As String

-    

-    Set wb = ThisWorkbook

-    With wb

-        ticker = .Worksheets(VAR_SHEET).Range("DEN_SYMBOL")

-        Period = .Worksheets(VAR_SHEET).Range("DEN_TIME")

-        If .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False Then

-            MsgBox _

-                Prompt:="Недостаточна глубина выборки данных." _

-                    & vbCrLf & "Измените параметры запроса и пробуйте снова.", _

-                Buttons:=vbOKOnly + vbExclamation, _

-                Title:=PROGRAM_NAME

-            

-            ClearResultTables

-            

-            With .Worksheets(FORM_SHEET)

-                .Range("CALC_TICKER_NAME") = ticker & ", Period=" & Period

-                .Range("FILE_NAME") = ""

-                .Range(TABLE_COMMENT).Value = "Недостаточно данных"

-            End With

-        Else

-            If TDenmark_Calc Then

-                With .Worksheets(FORM_SHEET)

-                    .Range("CALC_TICKER_NAME") = ticker & ", Period=" & Period

-                    .Range("FILE_NAME") = ""

-                End With

-            End If

-        End If

-    End With

-End Sub

-

-

-Sub evSubmit_Click()

-

-    Application.Cursor = xlWait

-    Dim wb As Workbook

-    Set wb = ThisWorkbook

-    With wb

-        With .Worksheets(VAR_SHEET)

-            If .Range("BOOL_DATA_READY") = False Or .Range("BOOL_LOAD_DATA") = True Then

-                If .Range("BOOL_FILE_DATA") = False Then

-                    .Range("BOOL_DATA_READY") = UpdateHistoryFromWeb(wb)

-                Else

-                    evFileOpen

-                    Application.Cursor = xlDefault

-                    Exit Sub

-                End If

-            End If

-            .Range("BOOL_DEMARK_READY") = False

-            If .Range("BOOL_FILE_DATA") = False Then

-                sbCalcWeb

-            Else

-                sbCalcFile

-            End If

-        End With

-    End With

-    Application.Cursor = xlDefault

-End Sub

-

-Sub evTicker_Change()

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("IDX_DEN_SECNAME") = .Range("IDX_DEN_SYMBOL")

-    End With

-    evHistory_Change

-End Sub

-

-Sub evSecName_Change()

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("IDX_DEN_SYMBOL") = .Range("IDX_DEN_SECNAME")

-    End With

-    evHistory_Change

-End Sub

-

-Sub evLastInterval_Change()

-    MsgBox "Не работает в этой версии"

-End Sub

-

-Sub evHistory_Change()

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("BOOL_DATA_READY") = False

-    End With

-End Sub

-

-Sub evGroupChange()

-    Dim GroupIdx, LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange As String

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        GroupIdx = .Range("IDX_DEN_LIST")

-        .Range("IDX_DEN_SYMBOL") = 1

-        NewRangeOffsetCol = (GroupIdx - 1) * 2

-        LinesCount = GetLinesCount(.Range("TICKER_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .Name & "!" & .Range(.Range("TICKER_TABLES").Offset(1, NewRangeOffsetCol), .Range("TICKER_TABLES").Offset(LinesCount, NewRangeOffsetCol)).Address

-        ThisWorkbook.Worksheets(FORM_SHEET).Shapes("cbxTikers").ControlFormat.ListFillRange = NewCbxRange

-        NewRangeOffsetCol = NewRangeOffsetCol + 1

-        NewCbxRange = .Name & "!" & .Range(.Range("TICKER_TABLES").Offset(1, NewRangeOffsetCol), .Range("TICKER_TABLES").Offset(LinesCount, NewRangeOffsetCol)).Address

-        ThisWorkbook.Worksheets(FORM_SHEET).Shapes("cbxSecName").ControlFormat.ListFillRange = NewCbxRange

-    End With

-    evTicker_Change

-End Sub

-

-Sub evUpdateTickerList()

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_FILE_DATA") = False Then

-        UpdateTickerList ThisWorkbook

-        evHistory_Change

-    End If

-End Sub

-

-Sub evParamChange()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DEMARK_READY") = False

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_AUTORECALC") = True Then

-        evSubmit_Click

-    End If

-End Sub

-

-<<<<<<
-======================
-mGetFileData
->>>>>>
-Attribute VB_Name = "mGetFileData"

-Option Explicit

-

-Dim mobjAppRunEnable As New cEnableRun

-

-Public Const MAX_LOAD_DATA_LINES As Integer = 16000

-

-Public Const MSG_FILE_VERY_SMALL As String = "В файле недостаточно данных"

-Public Const MSG_FILE_INVALID_FORMAT As String = "Неверный формат файла"

-

-Public Const FUNCRES_FILE_OK As Integer = 0

-Public Const FUNCRES_FILE_VERY_SMALL As Integer = -1

-Public Const FUNCRES_FILE_INVALID_FORMAT As Integer = -2

-

-Function UpdateHistoryFromFile(wb As Workbook, fileToOpen As String) As Integer

-    Dim DestRangeName As String

-    Dim ResultLength As Integer

-    Dim Location As Range

-    Dim denWindow As Integer

-    Dim IsIntraday As Boolean

-    Dim CalcNextTime As Boolean

-        

-    Dim SingleFileLine As String

-    Dim FileHandler As Integer

-    Dim i, j, row_idx As Integer

-    

-    UpdateHistoryFromFile = FUNCRES_FILE_INVALID_FORMAT

-    With wb

-        .Application.ScreenUpdating = False

-        With .Worksheets(VAR_SHEET)

-            CalcNextTime = .Range("BOOL_NEXT_TIME")

-            denWindow = .Range("DEN_WINDOW") + 1

-            If CalcNextTime Then

-                denWindow = denWindow + 1

-            End If

-            IsIntraday = True

-        End With

-        With .Worksheets(RAW_DATA_SHEET)

-            'Clear table include temp area

-            .Parent.Application.DisplayAlerts = False

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW - 1, RAW_DATA_RANGE_COL - 1), _

-                .Cells(65535, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-            ).ClearContents

-            Set Location = .Range(RAW_DATA_RANGE).Offset(-1, 0)

-            

-            ' Reading data from file

-            FileHandler = FreeFile

-            row_idx = 0

-            Open fileToOpen For Input As #FileHandler

-            Do While Not EOF(FileHandler) And row_idx < MAX_LOAD_DATA_LINES

-                Line Input #FileHandler, SingleFileLine

-                .Range(PRICE_TABLE).Offset(row_idx, 0) = SingleFileLine

-                row_idx = row_idx + 1

-            Loop

-            Close #FileHandler

-            

-            ' Parsing data

-            DestRangeName = "=" & RAW_DATA_SHEET & "!$B$1:$B" & row_idx

-            ResultLength = row_idx

-            

-            .Range(DestRangeName).TextToColumns _

-                Destination:=.Range(DestRangeName), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=True, _

-                Semicolon:=True, _

-                Comma:=True, _

-                Space:=False, _

-                Other:=False, _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 1), _

-                                Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1))

-            

-            .Parent.Application.DisplayAlerts = True

-            Dim CurrentDate As String

-            Dim RawData As Range

-            

-            Set RawData = .Range(RAW_DATA_RANGE)

-            

-            If Not CheckFileFormat(RawData.Offset(-1, 0)) Then

-                UpdateHistoryFromFile = FUNCRES_FILE_INVALID_FORMAT

-                Exit Function

-            End If

-            

-            row_idx = 0

-            With RawData

-                CurrentDate = .Value

-                For i = 1 To ResultLength

-                    If Not IsIntraday And CurrentDate = .Offset(i, DATE_IDX).Value Then

-                        ' skip virtual prices

-                        If (.Offset(i, VOLUME_IDX) > MIN_PRICE_VALUE) Then

-                            If .Offset(row_idx, HIGH_IDX).Value < .Offset(i, HIGH_IDX).Value Then

-                                .Offset(row_idx, HIGH_IDX).Value = .Offset(i, HIGH_IDX).Value

-                            End If

-                            If .Offset(row_idx, LOW_IDX).Value > .Offset(i, LOW_IDX).Value Then

-                                .Offset(row_idx, LOW_IDX).Value = .Offset(i, LOW_IDX).Value

-                            End If

-                            .Offset(row_idx, VOLUME_IDX).Value = _

-                                .Offset(row_idx, VOLUME_IDX).Value + .Offset(i, VOLUME_IDX).Value

-                            .Offset(row_idx, TIME_IDX).Value = .Offset(i, TIME_IDX).Value

-                            .Offset(row_idx, CLOSE_IDX).Value = .Offset(i, CLOSE_IDX).Value

-                        End If

-                    Else

-                        ' skip virtual prices

-                        If (.Offset(row_idx, VOLUME_IDX) > MIN_PRICE_VALUE) Then

-                            row_idx = row_idx + 1

-                        End If

-                        For j = DATE_IDX To VOLUME_IDX

-                            .Offset(row_idx, j) = .Offset(i, j)

-                        Next j

-                        CurrentDate = .Offset(i, DATE_IDX)

-                    End If

-                Next i

-            End With ' RawData

-            ' Clear unused Cells

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(65536, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-            ).ClearContents

-            

-            If row_idx > denWindow Then

-                row_idx = row_idx - denWindow

-                .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-                ).Delete xlShiftUp

-            Else

-                UpdateHistoryFromFile = FUNCRES_FILE_VERY_SMALL

-                Exit Function

-            End If

-            

-            row_idx = denWindow + 1

-            

-            Set Location = .Range( _

-                .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_IDX) _

-            )

-            

-            Location.TextToColumns _

-                Destination:=Location.Offset(0, DATE_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:="/", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2))

-            

-            Location.Offset(0, TIME_IDX).TextToColumns _

-                Destination:=Location.Offset(0, TIME_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:=":", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2))

-            

-            ' Check estimation date

-            

-            Dim end_date, end_time As Date

-            Dim year, month, day As Integer

-            Dim hour, minute As Integer

-            Dim next_time_exist As Boolean

-            

-            year = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 3)

-            month = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 2)

-            day = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 1)

-            hour = Location.Cells(denWindow - 1, TIME_STAMP_OFFSET + 1)

-            minute = Location.Cells(denWindow - 1, TIME_STAMP_OFFSET + 2)

-            

-            next_time_exist = day + month + year <> 0

-            

-            If next_time_exist Then

-                end_date = DateSerial(year, month, day)

-                end_time = TimeSerial(hour, minute, 0)

-                mobjAppRunEnable.EnableRun ESTIMATION_DATE, end_date

-            End If

-             

-            row_idx = 0

-            Dim temp_str As String

-                    

-            If IsIntraday Then

-                Do While IsEmpty(Location.Cells(1 + row_idx, 1 + DATE_IDX)) = False

-                       temp_str = Location.Cells(1 + row_idx, 1 + PROJECT_IDX + 1)

-                       temp_str = temp_str & "/"

-                       temp_str = temp_str & Location.Cells(1 + row_idx, 1 + PROJECT_IDX + 2)

-                       temp_str = temp_str & "-"

-                       temp_str = temp_str & Location.Cells(1 + row_idx, 1 + TIME_IDX)

-                       Location.Cells(1 + row_idx, DATE_IDX) = temp_str

-                       row_idx = row_idx + 1

-                Loop

-                row_idx = row_idx - 1

-                Dim condition As Boolean

-                condition = Not CalcNextTime And next_time_exist And end_date = DateValue(Now) And end_time > TimeValue(Now)

-                If condition Then

-                    .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL - 1), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-                    ).Delete xlShiftUp

-                End If

-            End If

-        End With ' .Worksheets(RAW_DATA_SHEET)

-    End With ' wb

-    UpdateHistoryFromFile = FUNCRES_FILE_OK

-End Function

-

-Function CheckFileFormat(HeaderString As Range) As Boolean

-    With HeaderString

-        CheckFileFormat = _

-            .Offset(0, DATE_IDX) = "Date" And _

-            .Offset(0, TIME_IDX) = "Time" And _

-            .Offset(0, OPEN_IDX) = "Open" And _

-            .Offset(0, CLOSE_IDX) = "Close" And _

-            .Offset(0, LOW_IDX) = "Low" And _

-            .Offset(0, HIGH_IDX) = "High" And _

-            .Offset(0, VOLUME_IDX) = "Volume"

-    End With

-End Function

-<<<<<<
-Project Name : 'Denmark_method'
-Quirk - duff tag length======================
-MGetWebData
->>>>>>
-Attribute VB_Name = "MGetWebData"

-Option Explicit

-

-Dim mobjAppRunEnable As New cEnableRun

-

-Const QueryDataName As String = "ExternalDenmarkData"

-

-Function UpdateHistoryFromWeb(wb As Workbook) As Boolean

-    Dim DestRangeName As String

-    Dim ResultLength As Integer

-    Dim QryPathStr As String

-    Dim Location As Range

-    Dim denWindow As Integer

-    Dim IsIntraday As Boolean

-    Dim CalcNextTime As Boolean

-        

-    UpdateHistoryFromWeb = False

-    QryPathStr = GetQryPath(wb)

-    With wb

-        .Application.ScreenUpdating = False

-        With .Worksheets(VAR_SHEET)

-            DestRangeName = .Range("DEN_SYMBOL")

-            CalcNextTime = .Range("BOOL_NEXT_TIME")

-            denWindow = .Range("DEN_WINDOW")

-            If CalcNextTime Then

-                denWindow = denWindow + 1

-            End If

-            IsIntraday = IsNumeric(.Range("DEN_TIME"))

-        End With

-        With .Worksheets(RAW_DATA_SHEET)

-            .Range(PRICE_TABLE) = DestRangeName

-            'Clear table and temp area

-            With .Range( _

-                .Cells(RAW_DATA_RANGE_ROW - 1, RAW_DATA_RANGE_COL - 1), _

-                .Cells(65535, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE))

-                .ClearContents

-                .NumberFormat = "General"

-            End With

-            

-            Set Location = .Range(RAW_DATA_RANGE).Offset(-1, 0)

-            If Not QryExist(Location, QueryDataName) Then

-                QryCreate Location, QueryDataName, QryPathStr

-            Else

-                QryRefresh Location, QueryDataName, QryPathStr

-            End If

-            With Location.Worksheet.QueryTables(QueryDataName)

-                DestRangeName = .ResultRange.Name.RefersTo

-                ResultLength = .ResultRange.count

-            End With

-    

-'            .Parent.Application.DisplayAlerts = False

-    

-            If ResultLength < denWindow Then

-                Exit Function

-            End If

-            

-            .Range(DestRangeName).TextToColumns _

-                Destination:=Range(DestRangeName), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=True, _

-                Space:=False, _

-                Other:=False, _

-                OtherChar:="|", _

-                FieldInfo:=Array( _

-                                Array(1, xlSkipColumn), _

-                                Array(2, xlTextFormat), _

-                                Array(3, xlGeneralFormat), _

-                                Array(4, xlGeneralFormat), _

-                                Array(5, xlGeneralFormat), _

-                                Array(6, xlGeneralFormat), _

-                                Array(7, xlGeneralFormat), _

-                                Array(8, xlSkipColumn), _

-                                Array(9, xlSkipColumn), _

-                                Array(10, xlSkipColumn), _

-                                Array(11, xlSkipColumn), _

-                                Array(12, xlSkipColumn))

-            

-            .Range(DestRangeName).EntireColumn.AutoFit

-            

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(65536, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-            ).NumberFormat = "General"

-            

-            Dim RawData As Range

-            Dim row_idx As Integer

-            

-            Set RawData = .Range(DestRangeName).Offset(0, 1)

-            RawData.Insert Shift:=xlToRight

-            

-            If Not IsIntraday Then

-                Set RawData = RawData.Offset(0, -1)

-                RawData.Value = "18:00"

-                RawData.Cells(1, 1).FormulaR1C1 = "TIME"

-                Set RawData = RawData.Offset(0, -1)

-            Else

-                Set RawData = RawData.Offset(0, -2)

-                RawData.TextToColumns _

-                    Destination:=RawData, _

-                    DataType:=xlDelimited, _

-                    TextQualifier:=xlDoubleQuote, _

-                    ConsecutiveDelimiter:=False, _

-                    Tab:=False, _

-                    Semicolon:=False, _

-                    Comma:=False, _

-                    Space:=True, _

-                    Other:=False, _

-                    OtherChar:="/", _

-                    FieldInfo:=Array( _

-                                    Array(1, xlTextFormat), _

-                                    Array(2, xlTextFormat))

-                RawData.Cells(1, 2).FormulaR1C1 = "TIME"

-            End If

-            

-'            Dim end_date As Date

-'            end_date = RawData.Cells(ResultLength, 1).FormulaR1C1

-

-' Delete unused space

-            

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW + ResultLength, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(65536, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-            ).ClearContents

-            

-            Dim i As Integer

-' Delete blank intervals

-            

-            Set RawData = .Range(RAW_DATA_RANGE).Offset(0, 0)

-            row_idx = 0

-            For i = 1 To ResultLength

-                ' skip virtual prices

-                If RawData.Offset(row_idx, CLOSE_IDX).Value > MIN_PRICE_VALUE Then

-                    row_idx = row_idx + 1

-                Else

-                    Set Location = .Range( _

-                            .Cells(row_idx + RAW_DATA_RANGE_ROW, DATE_IDX + RAW_DATA_RANGE_COL), _

-                            .Cells(row_idx + RAW_DATA_RANGE_ROW, PROJECT_IDX + RAW_DATA_RANGE_COL) _

-                    )

-                    Location.Delete xlShiftUp

-                End If

-            Next i

-            

-            ResultLength = GetLinesCount(.Range(RAW_DATA_RANGE))

-            

-            row_idx = ResultLength - 1

-            If row_idx > denWindow Then

-                row_idx = row_idx - denWindow

-                .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-                ).Delete xlShiftUp

-            Else

-                Exit Function

-            End If

-            

-            Dim TmpStr As String

-                        

-            row_idx = GetLinesCount(.Range(RAW_DATA_RANGE))

-            

-            Set RawData = .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx - 1, RAW_DATA_RANGE_COL + DATE_IDX) _

-                )

-            RawData.TextToColumns _

-                Destination:=.Range(RAW_DATA_RANGE).Offset(0, DATE_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:="-", _

-                FieldInfo:=Array( _

-                                Array(1, xlTextFormat), _

-                                Array(2, xlTextFormat), _

-                                Array(3, xlTextFormat))

-            

-            Set Location = .Range(RAW_DATA_RANGE).Offset(0, -1)

-            

-            If IsIntraday Then

-                Set RawData = .Range( _

-                            .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + TIME_IDX), _

-                            .Cells(RAW_DATA_RANGE_ROW + row_idx - 1, RAW_DATA_RANGE_COL + TIME_IDX) _

-                    )

-                RawData.TextToColumns _

-                    Destination:=.Range(RAW_DATA_RANGE).Offset(0, TIME_STAMP_OFFSET), _

-                    DataType:=xlDelimited, _

-                    TextQualifier:=xlDoubleQuote, _

-                    ConsecutiveDelimiter:=False, _

-                    Tab:=False, _

-                    Semicolon:=False, _

-                    Comma:=False, _

-                    Space:=False, _

-                    Other:=True, _

-                    OtherChar:=":", _

-                    FieldInfo:=Array( _

-                                    Array(1, xlTextFormat), _

-                                    Array(2, xlTextFormat), _

-                                    Array(3, xlTextFormat))

-                                    

-                

-                For i = 0 To row_idx - 1

-                    Location.Offset(i, 0) = "'" & _

-                            .Range(RAW_DATA_RANGE).Offset(i, DATE_STAMP_OFFSET + 1).Value _

-                            & "/" & .Range(RAW_DATA_RANGE).Offset(i, DATE_STAMP_OFFSET + 2).Value _

-                            & "-" & .Range(RAW_DATA_RANGE).Offset(i, TIME_STAMP_OFFSET).Value _

-                            & ":" & .Range(RAW_DATA_RANGE).Offset(i, TIME_STAMP_OFFSET + 1).Value

-                Next

-            Else

-                For i = 0 To row_idx - 1

-                    Location.Offset(i, 0) = "'" & _

-                            .Range(RAW_DATA_RANGE).Offset(i, DATE_STAMP_OFFSET + 2).Value _

-                            & "/" & .Range(RAW_DATA_RANGE).Offset(i, DATE_STAMP_OFFSET + 1).Value _

-                            & "/" & .Range(RAW_DATA_RANGE).Offset(i, DATE_STAMP_OFFSET).Value

-                Next

-            End If

-            .Parent.Application.DisplayAlerts = True

-        End With ' .Worksheets(RAW_DATA_SHEET)

-    End With ' wb

-    UpdateHistoryFromWeb = True

-End Function

-

-Private Function GetQryPath(wb As Workbook) As String

-    Dim QryPathStr As String

-    Dim IsIntradai As Boolean

-    Dim DayCount As Integer

-    Const DataFormat As String = "&data_format=BROWSER"

-    With wb.Worksheets(VAR_SHEET)

-        IsIntradai = IsNumeric(.Range("DEN_TIME"))

-        

-        If IsIntradai Then

-        

-            QryPathStr = "URL;http://export.rbc.ru/export/"

-            QryPathStr = QryPathStr & .Range("DEN_SOURCE")

-            QryPathStr = QryPathStr & "." & .Range("DEN_BOARD")

-            QryPathStr = QryPathStr & "/?"

-            

-            QryPathStr = QryPathStr & "tickers=" & .Range("DEN_SYMBOL")

-            QryPathStr = QryPathStr & "&period=" & .Range("DEN_TIME")

-            QryPathStr = QryPathStr & "&virtual=PASS"

-            DayCount = .Range("DEN_HISTORY") * .Range("DEN_TIME") \ 420 + 1

-            QryPathStr = QryPathStr & "&lastdays=" & DayCount

-            QryPathStr = QryPathStr & "&separator=,"

-            QryPathStr = QryPathStr & DataFormat

-            QryPathStr = QryPathStr & "&header=1"

-        Else

-            QryPathStr = "URL;http://export.rbc.ru/cgi-bin/export/query_version/export.cgi?"

-            QryPathStr = QryPathStr & "&sourcename=" & .Range("DEN_SOURCE")

-            QryPathStr = QryPathStr & "." & .Range("DEN_BOARD")

-            QryPathStr = QryPathStr & "&tickers=" & .Range("DEN_SYMBOL")

-            QryPathStr = QryPathStr & "&period=DAILY"

-            QryPathStr = QryPathStr & "&virtual=PASS"

-            QryPathStr = QryPathStr & "&lastdays=" & .Range("DEN_HISTORY") + 1

-            QryPathStr = QryPathStr & "&separator=,"

-            QryPathStr = QryPathStr & DataFormat

-            QryPathStr = QryPathStr & "&header=1"

-        End If

-    .Range("LAST_HIST_QRY") = QryPathStr

-    End With

-    GetQryPath = QryPathStr

-End Function

-

-Sub UpdateTickerList(wb As Workbook)

-    Dim Idx, n As Integer

-    Dim ResultLength As Integer

-    Dim Location As Range

-    Dim QryPathStr As String

-    Dim QueryDataName As String

-    Dim DestRangeArea As String

-    

-    QryPathStr = GetListPath(wb)

-    With wb

-        With .Worksheets(VAR_SHEET)

-            Idx = .Range("IDX_DEN_LIST")

-            Set Location = .Range("TICKER_TABLES").Offset(0, (Idx - 1) * 2)

-             .Range("IDX_DEN_SYMBOL") = 1

-            QueryDataName = Location.Offset(0, 0)

-            'Clear table

-            .Range(Location.Offset(1, 0), Location.Offset(65535 - Location.Row, 1)).ClearContents

-            

-            If Not QryExist(Location.Offset(1, 0), QueryDataName) Then

-                QryCreate Location.Offset(1, 0), QueryDataName, QryPathStr

-            Else

-                QryRefresh Location.Offset(1, 0), QueryDataName, QryPathStr

-            End If

-            

-            With .QueryTables(QueryDataName)

-                DestRangeArea = .ResultRange.Name.RefersTo

-                ResultLength = .ResultRange.count

-            End With

-        

-            .Parent.Application.DisplayAlerts = False

-                

-            .Range(DestRangeArea).TextToColumns _

-                Destination:=.Range(DestRangeArea), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:=":", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 9))

-        ' Sort Data

-            Set Location = .Range(.Range(DestRangeArea).Offset(0, 0), .Range(DestRangeArea).Offset(ResultLength - 1, 1))

-            Location.Sort _

-                Key1:=.Range(DestRangeArea).Offset(0, 0), _

-                Order1:=xlAscending, _

-                Header:=xlNo, _

-                OrderCustom:=1, _

-                MatchCase:=False, _

-                Orientation:=xlTopToBottom

-        End With

-        ' Setup Ticker List

-         With .Worksheets(VAR_SHEET)

-            DestRangeArea = .Name & "!" & .Range(.Range(DestRangeArea).Cells(1, 1), .Range(DestRangeArea).Cells(ResultLength - 1, 1)).Address

-         End With

-        With .Worksheets(FORM_SHEET).Shapes("cbxTikers").ControlFormat

-            .ListFillRange = DestRangeArea

-            .ListIndex = 1

-        End With

-        ' Setup Name List

-         With .Worksheets(VAR_SHEET)

-            DestRangeArea = .Name & "!" & .Range(.Range(DestRangeArea).Cells(1, 1), .Range(DestRangeArea).Cells(ResultLength - 1, 1)).Offset(0, 1).Address

-         End With

-        With .Worksheets(FORM_SHEET).Shapes("cbxSecName").ControlFormat

-            .ListFillRange = DestRangeArea

-            .ListIndex = 1

-        End With

-        .Parent.Application.DisplayAlerts = True

-    End With

-End Sub

-

-Private Function GetListPath(wb As Workbook) As String

-    Dim QryPathStr As String

-    With wb.Worksheets(VAR_SHEET)

-        QryPathStr = "URL;http://export.rbc.ru/cgi-bin/export/tickers.cgi?"

-        QryPathStr = QryPathStr & "&source=" & .Range("DEN_SOURCE")

-        QryPathStr = QryPathStr & "." & .Range("DEN_BOARD")

-        .Range("LAST_DIR_QRY") = QryPathStr

-    End With

-    GetListPath = QryPathStr

-End Function

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    Set MyAppEvents.app = Application

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    If Application.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEL сейчас будут закрыты!", vbOKCancel, "$" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close Savechanges:=False

-            Exit Sub

-        End If

-    End If

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False

-    cmSetStandaloneMode

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment wb:=ThisWorkbook, DesignMode:=False

-        If ThisWorkbook.Saved = False Then

-            ThisWorkbook.Save

-        End If

-    End If

-    Application.Caption = Empty

-    Application.CommandBars("Worksheet Menu Bar").Reset

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-        Dim MaxX, MaxY As Integer

-        With ThisWorkbook.Worksheets(FORM_SHEET)

-            MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-            MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-        End With

-

-        With ThisWorkbook.Application

-            .ScreenUpdating = False

-            .WindowState = xlNormal

-            .Height = MaxY

-            .Width = MaxX

-        End With

-End Sub

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mReadWrite
->>>>>>
-Attribute VB_Name = "mReadWrite"

-Option Explicit

-

-Public Const GOOD_LINE_STATUS As String = "Ok"

-Public Const BAD_LINE_STATUS As String = "N/A"

-

-Function ReadPricesData(Location As Range, Hist As Integer, dt As Integer, _

-              pPriceData As TPriceData) As Integer

-    'Инициализация типа TPriceData из таблицы типа - 1

-    'kопируются не более чем hist последних строк

-    'aPoint - начало таблицы

-    'первые две строки таблицы идентифицирует данные (строки)

-    Dim n, i As Integer

-    

-    'Определение числа строк таблицы - n

-    n = GetLinesCount(Location)

-    ReadPricesData = n

-    If n < 9 Then             'обработать ошибку !!!

-        GoTo done

-    End If

-    ' число строк определено ()

-    If Hist > (n - 3) \ dt + 1 Then ' коррекция истории

-        Hist = (n - 3) \ dt + 1 '

-    End If

-    Dim t, s As Integer

-    For t = 0 To Hist - 1

-        s = n - t * dt - 1

-        pPriceData.D(Hist - t) = Location.Offset(s, DATE_IDX).Value

-        pPriceData.Tm(Hist - t) = Location.Offset(s, TIME_IDX).Value

-        pPriceData.Opn(Hist - t) = Location.Offset(s, OPEN_IDX).Value

-        pPriceData.Hgh(Hist - t) = Location.Offset(s, HIGH_IDX).Value

-        pPriceData.Lw(Hist - t) = Location.Offset(s, LOW_IDX).Value

-        pPriceData.Cls(Hist - t) = Location.Offset(s, CLOSE_IDX).Value

-        pPriceData.Vl(Hist - t) = Location.Offset(s, VOLUME_IDX).Value

-    Next t

-    ReadPricesData = t + 1

-done:

-End Function

-

-Sub ResultLinesOut(Location As Range, pPD As TPriceData, pDen As TDenmark)

-    Dim n As Integer

-    

-    n = GetLinesCount(Location)

-    With Location

-        .Offset(-1, RESIST_IDX) = "Resistance"

-        .Offset(-1, SUPPORT_IDX) = "Support"

-        .Offset(-1, PROJECT_IDX) = "Project"

-    End With

-    Dim t, count, Idx, loc_idx As Integer

-    count = pPD.tC

-    For t = 0 To count - 1

-        Idx = count - t

-        loc_idx = n - t - 1

-        If pDen.ResistanceLine(Idx) > MIN_PRICE_VALUE Then

-            Location.Offset(loc_idx, RESIST_IDX).Value = pDen.ResistanceLine(Idx)

-        End If

-        If pDen.SupportLine(Idx) > MIN_PRICE_VALUE Then

-            Location.Offset(loc_idx, SUPPORT_IDX).Value = pDen.SupportLine(Idx)

-        End If

-        If Abs(pDen.SignalValue) > 1 Then

-            Location.Offset(loc_idx, PROJECT_IDX).Value = pDen.ProjectPrice

-        End If

-    Next t

-End Sub

-

-Sub Out_Table_1(TheRange As Range, pDen As TDenmark, LastIdx As Integer)

-    

-    

-    ' Col = 2 - не определен !!!

-    ' Status - Col = 0

-    If pDen.ResistancePointCount >= 2 Then

-        TheRange.Offset(0, 0).Value = GOOD_LINE_STATUS

-    Else

-        TheRange.Offset(0, 0).Value = BAD_LINE_STATUS

-    End If

-    If pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(1, 0).Value = GOOD_LINE_STATUS

-    Else

-        TheRange.Offset(1, 0).Value = BAD_LINE_STATUS

-    End If

-    ' -----------------------------------------

-    ' углы наклонов линии сопротивления и поддержки - Col = 1

-    If pDen.ResistancePointCount >= 2 Then

-        TheRange.Offset(0, 1).Value = pDen.ResistanceAngle

-    End If

-    If pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(1, 1).Value = pDen.SupportAngle

-    End If

-    If pDen.ResistancePointCount >= 2 And pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(2, 1).Value = (pDen.ResistanceAngle + pDen.SupportAngle) / 2

-    End If

-    ' -----------------------------------------

-    ' Опорные цены линий денмарка на текущий момент

-    If pDen.ResistancePointCount >= 2 Then

-        TheRange.Offset(0, 2).Value = pDen.ResistanceLine(LastIdx)

-    End If

-    If pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(1, 2).Value = pDen.SupportLine(LastIdx)

-    End If

-    If pDen.ResistancePointCount >= 2 And pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(2, 2).Value = _

-            (pDen.ResistanceLine(LastIdx) + pDen.SupportLine(LastIdx)) / 2

-    End If

-    

-End Sub

-

-Sub Out_Table_2(TheRange As Range, TheComment As Range, pPD As TPriceData, pDen As TDenmark)

-    Const ColorIndexBUY = 5

-    Const ColorIndexSELL = 3

-    Const ColorIndexNOTHINK = 14

-    

-    Dim SignalValue_defined, allert_enable  As Boolean

-    Dim Message As String

-    SignalValue_defined = False

-    allert_enable = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_ALLERT_DLG")

-    Message = "Сигнал об изменении тренда не идентифицирован."

-    If pDen.SignalValue >= 2 Then

-        SignalValue_defined = True

-        With TheRange.Offset(0, 0)

-            .Value = "BUY"

-            .Font.Bold = True

-            .Font.ColorIndex = ColorIndexBUY

-        End With

-        TheRange.Offset(0, 1).Value2 = pPD.D(pPD.tC)

-        TheRange.Offset(0, 2).Value2 = pPD.Tm(pPD.tC)

-        TheRange.Offset(0, 3).Value = pDen.SignalValue - 1

-        TheRange.Offset(0, 4).Value = pDen.ProjectPrice

-        Message = "BUY Signal: возможен прорыв вверх нисходящего тренда с уровнем значимости = " & pDen.SignalValue - 1 & " ! "

-    End If

-    If pDen.SignalValue <= -2 Then

-        SignalValue_defined = True

-        With TheRange.Offset(0, 0)

-            .Value = "SELL"

-            .Font.Bold = True

-            .Font.ColorIndex = ColorIndexSELL

-        End With

-        TheRange.Offset(0, 1).Value2 = pPD.D(pPD.tC)

-        TheRange.Offset(0, 2).Value2 = pPD.Tm(pPD.tC)

-        TheRange.Offset(0, 3).Value = pDen.SignalValue + 1

-        TheRange.Offset(0, 4).Value = pDen.ProjectPrice

-        Message = "SELL Signal: возможен прорыв вниз восходящего тренда с уровнем значимости = " & -(pDen.SignalValue + 1) & "!"

-    End If

-    With TheComment

-        .Value = Message

-        .Font.Bold = True

-        Dim color_idx As Integer

-        If SignalValue_defined Then

-            If pDen.SignalValue > 0 Then

-                .Font.ColorIndex = ColorIndexBUY

-            Else

-                .Font.ColorIndex = ColorIndexSELL

-            End If

-        Else

-            .Font.ColorIndex = ColorIndexNOTHINK

-        End If

-    End With

-    If allert_enable And SignalValue_defined Then

-        MsgBox _

-            Prompt:=Message, _

-            Title:=PROGRAM_NAME, _

-            Buttons:=vbOKOnly + vbInformation

-    End If

-End Sub

-

-Sub Out_Table_3(TheRange As Range, pDen As TDenmark)

-    Dim i As Integer

-    For i = 1 To 3

-        TheRange.Offset(i - 1, 0).Value = pDen.Qualificator(i)

-    Next i

-End Sub

-

-Sub Out_Table_4(TheRange As Range, pPD As TPriceData)

-    Dim LastIdx As Integer

-    LastIdx = pPD.tC

-    With TheRange

-        .Offset(0, 0).Value2 = "'" & pPD.D(LastIdx)

-        .Offset(0, 1).Value2 = "'" & pPD.Tm(LastIdx)

-        .Offset(0, 2) = pPD.Opn(LastIdx)

-        .Offset(0, 3) = pPD.Hgh(LastIdx)

-        .Offset(0, 4) = pPD.Lw(LastIdx)

-        .Offset(0, 5) = pPD.Cls(LastIdx)

-        .Offset(0, 6) = pPD.Cls(LastIdx) - pPD.Cls(LastIdx - 1)

-    End With

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Denmark method bar"

-Public Const common_pwd As Long = 31415926

-

-

-Sub SetEnvironment(wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    With Application

-        .Caption = PROGRAM_NAME

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .GetState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-    End With

-    With wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(FORM_SHEET).Select

-    End With

-    CreateCommandBar theApp:=wb.Application

-End Sub

-

-Sub RestoreEnvironment(wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Application.ScreenUpdating = False

-    With wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                     cWindow.DisplayHeadings = True

-                Next

-            End If

-        Next

-        .Worksheets(FORM_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu (True)

-        End If

-        With mobjAppState

-            .RestoreState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(wb As Workbook)

-    With wb

-        .Application.ScreenUpdating = False

-        

-        With .Worksheets(RAW_DATA_SHEET)

-            .Visible = xlVeryHidden

-            .Protect Password:=common_pwd, userInterfaceOnly:=True, Contents:=False

-        End With

-        With .Worksheets(VAR_SHEET)

-            .Visible = xlVeryHidden

-            .Protect Password:=common_pwd, userInterfaceOnly:=True, Contents:=False

-        End With

-        With .Worksheets(FORM_SHEET)

-            .EnableSelection = xlNoSelection

-            .Protect userInterfaceOnly:=True

-            .Select

-        End With

-        With .Worksheets(CHART_SHEET)

-            .EnableSelection = xlNoSelection

-            .Protect userInterfaceOnly:=True

-        End With

-        .Protect Windows:=True

-        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(wb As Workbook)

-    With wb

-        .Unprotect

-        .Application.ScreenUpdating = False

-        With .Worksheets(RAW_DATA_SHEET)

-            .Visible = xlVeryHidden

-            .Unprotect Password:=common_pwd

-        End With

-        With .Worksheets(VAR_SHEET)

-            .Visible = xlVeryHidden

-            .Unprotect Password:=common_pwd

-        End With

-        With .Worksheets(CHART_SHEET)

-            .Select

-            .Unprotect

-        End With

-        With .Worksheets(FORM_SHEET)

-            .Select

-            .Unprotect

-        End With

-        .Application.ScreenUpdating = True

-        

-    End With

-End Sub

-

-<<<<<<
-======================
-mTypes
->>>>>>
-Attribute VB_Name = "mTypes"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Метод г-на Демарка II"

-Public Const PROGRAM_VERSION As String = "version 4.1 Professional"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-

-Public Const ESTIMATION_DATE As Long = 20010915

-'Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "J27"

-

-Public Const RAW_DATA_SHEET As String = "Raw_data"

-Public Const PRICE_TABLE As String = "B1"

-Public Const RAW_DATA_RANGE As String = "B3"

-Public Const RAW_DATA_RANGE_COL As Integer = 2

-Public Const RAW_DATA_RANGE_ROW As Integer = 3

-

-Public Const VAR_SHEET As String = "Var_s"

-

-Public Const CHART_SHEET As String = "Chart"

-

-Public Const MIN_PRICE_VALUE As Double = 0.000001

-Public Const MAX_PRICE_VALUE As Double = 1000000000

-

-' Fields indexes in RAW_DATA_RANGE

-Public Const DATE_IDX As Integer = 0

-Public Const TIME_IDX As Integer = 1

-Public Const OPEN_IDX As Integer = 2

-Public Const HIGH_IDX As Integer = 3

-Public Const LOW_IDX As Integer = 4

-Public Const CLOSE_IDX As Integer = 5

-Public Const VOLUME_IDX As Integer = 6

-Public Const RESIST_IDX As Integer = 7

-Public Const SUPPORT_IDX As Integer = 8

-Public Const PROJECT_IDX As Integer = 9

-

-Public Const DATE_STAMP_OFFSET = PROJECT_IDX + 1

-Public Const TIME_STAMP_OFFSET = PROJECT_IDX + 4

-Public Const DATE_TIME_STAMP_SIZE = 5

-

-Type TPriceData

-    D() As String      ' календарная дата

-    Tm() As String     ' время

-    Opn() As Double    ' Open

-    Hgh() As Double    ' High

-    Lw() As Double     ' Low

-    Cls() As Double    ' Close

-    Vl() As Double     ' Volume

-    tC As Integer      ' Current time

-End Type

-

-Type TDenmark

-   ResistanceLine() As Double           'Resistance line

-   ResistancePoints() As Integer        'Resistance pivot points

-   ResistancePointCount As Integer      'The number of resistance pivot points

-   ResistanceAngle As Double            'Angle of Declination of ResistanceLine

-   

-   SupportLine() As Double              'Support line

-   SupportPoints() As Integer           'Support pivot points

-   SupportPointsCount As Integer        'The number of support pivot points

-   SupportAngle As Double               ' Angle of Declination of SupportLine

-   

-   SignalParameter     As Integer       ' parameter for SignalValue

-   SignalValue      As Integer          'SignalValue

-   

-   

-   Qualificator(1 To 3) As String       ' qualificators

- 

-   ProjectNumber As Integer             ' номер проекции

-   ProjectPrice  As Double              ' проекция цены

-   

-End Type

-

-

-<<<<<<
-======================
-mCommands
->>>>>>
-Attribute VB_Name = "mCommands"

-Option Explicit

-Dim AppRunEnable As New cEnableRun

-

-Sub evParamChange()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DEMARK_READY") = False

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_AUTORECALC") = True Then

-        evSubmit_Click

-    End If

-End Sub

-

-Sub cmViewChart(Optional SwapPage As Boolean = True)

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("BOOL_CHART_READY") = False

-        If .Range("BOOL_DEMARK_READY") <> True Then

-            If .Range("BOOL_AUTORECALC") = True Then

-                evSubmit_Click

-                If .Range("BOOL_DEMARK_READY") <> True Then

-                    Exit Sub

-                End If

-            Else

-                MsgBox _

-                    "График не может быть построен." & vbCrLf & "Исходные данные не обработаны.", _

-                    vbOKOnly + vbExclamation, _

-                    PROGRAM_NAME

-                Exit Sub

-            End If

-        End If

-    End With

-    With ThisWorkbook.Worksheets(FORM_SHEET)

-        With .Range("TABLE_1")

-            Dim test_lines As Boolean

-            test_lines = StrComp(.Cells(1, 1).Value, GOOD_LINE_STATUS)

-            test_lines = test_lines + StrComp(.Cells(2, 1).Value, GOOD_LINE_STATUS)

-            If test_lines <> 0 Then

-                MsgBox _

-                    Prompt:="График не может быть построен." & vbCrLf & "Опорные точки не определены .", _

-                    Title:=PROGRAM_NAME, _

-                    Buttons:=vbOKOnly + vbExclamation

-                Exit Sub

-            End If

-        End With

-        Draw_Chart Not IsEmpty(.Range("TABLE_2").Cells(1, 1))

-    End With

-    With ThisWorkbook

-        .Worksheets(VAR_SHEET).Range("BOOL_CHART_READY") = True

-        If SwapPage Then

-            .Worksheets(CHART_SHEET).Select

-        End If

-    End With

-End Sub

-

-Sub cmViewForm()

-    With ThisWorkbook

-        .Worksheets(FORM_SHEET).Select

-    End With

-End Sub

-

-Sub cmCloseProgram()

-    Dim ResistanceLine

-    ResistanceLine = MsgBox( _

-        Prompt:="Вы желаете завершить программу?", _

-        Buttons:=vbQuestion + vbYesNo, _

-        Title:=PROGRAM_NAME _

-    )

-    If ResistanceLine = vbYes Then

-       Application.Quit

-    End If

-End Sub

-

-Sub cmAbout()

-    dlgAbout.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlgAbout.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlgAbout.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlgAbout.Show

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-        helppath = "hh.exe " & .Path & "\Demark.chm"

-        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub cmSetStandaloneMode()

-    Application.ScreenUpdating = False

-    ProtectionDisable wb:=ThisWorkbook

-    SetEnvironment wb:=ThisWorkbook

-    ProtectionEnable wb:=ThisWorkbook

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    rp = common_pwd

-    dlgGetPwd.edPwd = ""

-    dlgGetPwd.Show

-    If dlgGetPwd.edPwd = rp Then

-        ProtectionDisable wb:=ThisWorkbook

-        RestoreEnvironment wb:=ThisWorkbook, DesignMode:=True

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmPrint()

-    If MsgBox( _

-            Prompt:="Вы желаете распечатать результат?", _

-            Buttons:=vbYesNo + vbQuestion, _

-            Title:=PROGRAM_NAME) = vbNo _

-    Then

-        Exit Sub

-    End If

-    Dim s_ticker, s_name, s_time As String

-    s_ticker = ThisWorkbook.Worksheets(FORM_SHEET).Range("CALC_TICKER_NAME")

-    s_name = ThisWorkbook.Worksheets(FORM_SHEET).Range("CALC_NAME")

-    s_time = Now

-    Application.ScreenUpdating = False

-    cmViewChart SwapPage:=False

-    Application.ScreenUpdating = False

-    With ThisWorkbook.Worksheets(FORM_SHEET).PageSetup

-        .LeftHeader = s_ticker

-        .CenterHeader = PROGRAM_NAME

-        .RightHeader = s_time

-        .LeftFooter = s_name

-        .CenterFooter = "Page &P of &N"

-        .RightFooter = ""

-        .LeftMargin = Application.InchesToPoints(0.75)

-        .RightMargin = Application.InchesToPoints(0.75)

-        .TopMargin = Application.InchesToPoints(0.78)

-        .BottomMargin = Application.InchesToPoints(0.92)

-        .HeaderMargin = Application.InchesToPoints(0.5)

-        .FooterMargin = Application.InchesToPoints(0.5)

-        .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 = 2

-    End With

-    With ThisWorkbook.Worksheets(CHART_SHEET).PageSetup

-        .LeftHeader = s_ticker

-        .CenterHeader = PROGRAM_NAME

-        .RightHeader = s_time

-        .LeftFooter = s_name

-        .CenterFooter = "Page &P of &N"

-        .RightFooter = ""

-        .LeftMargin = Application.InchesToPoints(0.75)

-        .RightMargin = Application.InchesToPoints(0.75)

-        .TopMargin = Application.InchesToPoints(0.78)

-        .BottomMargin = Application.InchesToPoints(0.92)

-        .HeaderMargin = Application.InchesToPoints(0.5)

-        .FooterMargin = Application.InchesToPoints(0.5)

-        .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 = 2

-    End With

-    Application.ScreenUpdating = False

-    ThisWorkbook.Worksheets(Array("MainForm", "Chart")).PrintOut Copies:=1, Collate:=True

-    cmViewForm

-End Sub

-<<<<<<
-======================
-mDemark
->>>>>>
-Attribute VB_Name = "mDemark"

-Option Explicit

-

-Public Const FORM_SHEET As String = "MainForm"

-

-'Form Ranges

-Public Const FILE_NAME As String = "FILE_NAME"

-Public Const TABLE_1 As String = "TABLE_1"

-Public Const TABLE_2 As String = "TABLE_2"

-Public Const TABLE_3 As String = "TABLE_3"

-Public Const TABLE_4 As String = "TABLE_4"

-Public Const TABLE_COMMENT As String = "TABLE_COMMENT"

-

-'Основной тип данных - стандарт 1

-

-'*********************

-Dim PriceDataArray As TPriceData

-Dim DenmarkDataArray As TDenmark

-

-Dim mobjAppRunEnable As New cEnableRun

-

-Sub ClearResultTables()

-    With ThisWorkbook.Worksheets(FORM_SHEET)

-        .Range(TABLE_1).ClearContents ' таблица-1

-        .Range(TABLE_2).ClearContents ' таблица-2

-        .Range(TABLE_3).ClearContents ' таблица-3

-        .Range(TABLE_COMMENT).Value = "" ' коментарий-3

-        .Range(TABLE_4).ClearContents ' таблица-4

-    End With

-End Sub

-

-Function TDenmark_Calc() As Boolean

-    

-    Dim nWindow As Integer

-    Dim bPrevCloseFilter, bSuccCloseFilter As Boolean

-    

-    TDenmark_Calc = False

-    

-    mobjAppRunEnable.EnableRun ESTIMATION_DATE, Now

-    

-    With ThisWorkbook

-        .Application.ScreenUpdating = False

-'1)    Read User data

-        With .Worksheets(VAR_SHEET)

-            DenmarkDataArray.ProjectNumber = .Range("DEN_PROECT").Value

-            DenmarkDataArray.SignalParameter = .Range("DEN_PARAM").Value

-            nWindow = .Range("DEN_WINDOW").Value

-            bPrevCloseFilter = .Range("BOOL_PREV_CLOSE").Value

-            bSuccCloseFilter = .Range("BOOL_SUCC_CLOSE").Value

-        End With

-

-'2)   Memory allocation

-        allocate_memory PriceDataArray, DenmarkDataArray, nWindow

-

-'3)   Read data

-        Dim TheRange As Range

-        Set TheRange = .Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE)

-        Dim LinesCount As Integer

-        LinesCount = ReadPricesData(Location:=TheRange, Hist:=PriceDataArray.tC, dt:=1, pPriceData:=PriceDataArray)

-        

-        'Init function result

-        TDenmark_Calc = LinesCount >= nWindow

-        

-        If LinesCount >= nWindow Then

-        

-'4)   Calculate metod TDenmarkDataArray

-            DetDenmark PriceDataArray, DenmarkDataArray, bPrevCloseFilter, bSuccCloseFilter

-            If Abs(DenmarkDataArray.SignalValue) > 1 Then  'ценовые ориентиры, если есть сигнал

-                DetProj PriceDataArray, DenmarkDataArray

-            End If

-'5)   Write result

-            Application.ScreenUpdating = False

-    

-'6)    Clear interface tables

-            ClearResultTables

-            

-            ResultLinesOut Location:=TheRange.Offset(2, 0), pPD:=PriceDataArray, pDen:=DenmarkDataArray

-            

-            With .Worksheets(FORM_SHEET)

-                Out_Table_1 TheRange:=.Range(TABLE_1).Cells(1, 1), pDen:=DenmarkDataArray, LastIdx:=PriceDataArray.tC

-                Out_Table_2 _

-                        TheRange:=.Range(TABLE_2).Cells(1, 1), _

-                        TheComment:=.Range("TABLE_COMMENT"), _

-                        pPD:=PriceDataArray, _

-                        pDen:=DenmarkDataArray

-                Out_Table_3 TheRange:=.Range(TABLE_3).Cells(1, 1), pDen:=DenmarkDataArray

-                Out_Table_4 TheRange:=.Range(TABLE_4).Cells(1, 1), pPD:=PriceDataArray

-                With .Range(TABLE_1)

-                    .Font.Name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-                With .Range(TABLE_2)

-                    .Font.Name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-                With .Range(TABLE_3)

-                    .Font.Name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-                With .Range(TABLE_4)

-                    .Font.Name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-            End With

-            .Worksheets(VAR_SHEET).Range("BOOL_DEMARK_READY") = True

-        Else

-            MsgBox _

-                Prompt:="Недостаточна глубина выборки данных." _

-                    & vbCrLf & "Измените параметры запроса и пробуйте снова.", _

-                Buttons:=vbOKOnly + vbExclamation, _

-                Title:=PROGRAM_NAME

-            .Worksheets(VAR_SHEET).Range("BOOL_DEMARK_READY") = False

-            .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False

-        End If

-'7)   Free unused memory

-        free_unused_memory PriceDataArray, DenmarkDataArray

-    End With

-End Function

-

-Sub allocate_memory(pPriceData As TPriceData, pDenmarkData As TDenmark, memsize As Integer)

-'  Память под TDenmark

-    ReDim pDenmarkData.ResistanceLine(1 To memsize)

-    ReDim pDenmarkData.ResistancePoints(1 To memsize)

-    ReDim pDenmarkData.SupportLine(1 To memsize)

-    ReDim pDenmarkData.SupportPoints(1 To memsize)

-   

-' Инициализация данных по ценам

-    pPriceData.tC = memsize

-    ReDim pPriceData.D(1 To memsize)

-    ReDim pPriceData.Tm(1 To memsize)

-    ReDim pPriceData.Opn(1 To memsize)

-    ReDim pPriceData.Hgh(1 To memsize)

-    ReDim pPriceData.Lw(1 To memsize)

-    ReDim pPriceData.Cls(1 To memsize)

-    ReDim pPriceData.Vl(1 To memsize)

-

-End Sub

-

-Sub free_unused_memory(pP As TPriceData, pD As TDenmark)

-'   Free Prices

-    pP.tC = 0

-    Erase pP.D

-    Erase pP.Tm

-    Erase pP.Opn

-    Erase pP.Hgh

-    Erase pP.Lw

-    Erase pP.Cls

-    Erase pP.Vl

-    

-'Free TDenmark

-    Erase pD.ResistanceLine

-    Erase pD.ResistancePoints

-    Erase pD.SupportLine

-    Erase pD.SupportPoints

-End Sub

-

-

-'*****************************************

-Sub DetDenmark(pPriceData As TPriceData, pDenmarkData As TDenmark, ByVal ClosePrev2 As Boolean, ByVal CloseSucc1 As Boolean)

-' определение элементов данных Денмарка (в цифровой форме)

-' на текущий момент времени времени tC

-' ИСХОДНЫЕ ДАННЫЕ:

-' pPriceData  - окно, стандартная форма данных по ценам (определена)

-' ClosePrev2 - H(t) > max{ H(t-1), H(t+1)} и  H(t) > Close(t-2)

-' CloseSucc1 - H(t) > max{ H(t-1), H(t+1)}  и  R(t+1) > Close(t+1)

-' РЕЗУЛЬТАТ:

-' pDenmarkData - элементы данных Денмарка (память выделена, SignalParameter - определен):

-' линии ResistanceLine,SupportLine их наклоны, опорные точки, сигналы к покупке или продаже

-' SignalValue = 0 сигнал отсутствует

-' SignalValue < 0 прорыв восходящего тренда (сигнал продажи)

-' SignalValue > 0 прорыв нисходящего тренда (сигнал покупки)

-' Если pDenmarkData.ResistancePointCount < 2, то элементы ResistanceLine не определяются

-' Если pDenmarkData.SupportPointsCount < 2, то элементы SupportLine не определяются

-

-' начальная установка

-    Const QUALIFICATOR_DISABLE As String = "-"

-    Const QUALIFICATOR_ENABLE As String = "Signal"

-    

-    Dim UpQual(1 To 3) As String

-    Dim DownQual(1 To 3) As String

-    Dim UpSignal, DownSignal As Integer

-    Dim i As Integer

-    

-    pDenmarkData.SignalValue = 0

-    UpSignal = 0

-    DownSignal = 0

-    

-    For i = 1 To 3

-        pDenmarkData.Qualificator(i) = QUALIFICATOR_DISABLE

-        UpQual(i) = QUALIFICATOR_DISABLE

-        DownQual(i) = QUALIFICATOR_DISABLE

-    Next i

-    

-' определение линии поддержки и сопротивления

-    ResLine _

-        pPriceData, _

-        pPriceData.tC, _

-        pDenmarkData.ResistancePointCount, _

-        pDenmarkData.ResistanceLine, _

-        pDenmarkData.ResistancePoints, _

-        ClosePrev2, _

-        CloseSucc1

-        

-    SuppLine _

-        pPriceData, _

-        pPriceData.tC, _

-        pDenmarkData.SupportPointsCount, _

-        pDenmarkData.SupportLine, _

-        pDenmarkData.SupportPoints, _

-        ClosePrev2, _

-        CloseSucc1

-

-        

-        

-    If pDenmarkData.ResistancePointCount >= 2 Then

-        pDenmarkData.ResistanceAngle = 57.29578 * _

-            Atn(pDenmarkData.ResistanceLine(pPriceData.tC) - _

-                pDenmarkData.ResistanceLine(pPriceData.tC - 1))

-    End If

-    If pDenmarkData.SupportPointsCount >= 2 Then

-        pDenmarkData.SupportAngle = 57.29578 * _

-            Atn(pDenmarkData.SupportLine(pPriceData.tC) - _

-                pDenmarkData.SupportLine(pPriceData.tC - 1))

-    End If

-

-' ФОРМИРОВАНИЕ СИГНАЛА ----------------------------------

-    Dim t As Integer

-' 1. случай нисходящего тренда: ResistanceLine определен и ResistanceLine падает *************

-    If pDenmarkData.ResistancePointCount >= 2 And pDenmarkData.ResistanceAngle < 0 Then

-'    необходимое условие прорыва вверх

-        If pDenmarkData.ResistanceLine(pPriceData.tC) < pPriceData.Cls(pPriceData.tC) Then

-            UpSignal = 1

-            For t = pPriceData.tC - pDenmarkData.SignalParameter To pPriceData.tC - 1

-                If pPriceData.Cls(t) > pDenmarkData.ResistanceLine(t) Then

-                    UpSignal = 0

-                    Exit For

-                End If

-            Next t

-        End If

-        If UpSignal = 1 Then

-'       Qualificator-1: close убывает накануне прорыва

-            If pPriceData.Cls(pPriceData.tC - 2) > pPriceData.Cls(pPriceData.tC - 1) Then

-                UpSignal = UpSignal + 1

-                UpQual(1) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-2: open > ResistanceLine в момент прорыва

-            If pPriceData.Opn(pPriceData.tC) > pDenmarkData.ResistanceLine(pPriceData.tC) Then

-                UpSignal = UpSignal + 1

-                UpQual(2) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-3 - demand value < ResistanceLine(tC)

-            If 2 * pPriceData.Cls(pPriceData.tC - 1) - pPriceData.Lw(pPriceData.tC - 1) < pDenmarkData.ResistanceLine(pPriceData.tC) Then

-                UpSignal = UpSignal + 1

-                UpQual(3) = QUALIFICATOR_ENABLE

-            End If

-        End If

-    End If  ' нисходящий тренд обработан ************************************

-

-' 2. случай восходящего тренда: SupportLine определен и SupportLine растет

-    If pDenmarkData.SupportPointsCount >= 2 And pDenmarkData.SupportAngle > 0 Then

-'    ---------------------------------------------

-'    необходимое условие прорыва вниз

-        If pPriceData.Cls(pPriceData.tC) < pDenmarkData.SupportLine(pPriceData.tC) Then

-            DownSignal = -1

-            For t = pPriceData.tC - pDenmarkData.SignalParameter To pPriceData.tC - 1

-                If pPriceData.Cls(t) < pDenmarkData.SupportLine(t) Then

-                    DownSignal = 0

-                    Exit For

-                End If

-            Next t

-        End If

-        If DownSignal = -1 Then

-'       Qualificator-1: Close растет накануне прорыва

-            If pPriceData.Cls(pPriceData.tC - 2) < pPriceData.Cls(pPriceData.tC - 1) Then

-                DownSignal = DownSignal - 1

-                DownQual(1) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-2: Open ниже ResistanceLine в момент прорыва

-            If pPriceData.Opn(pPriceData.tC) < pDenmarkData.SupportLine(pPriceData.tC) Then

-                DownSignal = DownSignal - 1

-                DownQual(2) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-3 - supply value(t-1) > SupportLine(tC)

-            If 2 * pPriceData.Cls(pPriceData.tC - 1) - pPriceData.Hgh(pPriceData.tC - 1) > pDenmarkData.SupportLine(pPriceData.tC) Then

-                DownSignal = DownSignal - 1

-                DownQual(3) = QUALIFICATOR_ENABLE

-            End If

-        End If

-'    ---------------------------------------------

-    End If

-'      Существует преобладание тенденции

-    If Abs(DownSignal) <> UpSignal Then

-        If Abs(DownSignal) > UpSignal Then

-            pDenmarkData.SignalValue = DownSignal

-            For i = 1 To 3

-                pDenmarkData.Qualificator(i) = DownQual(i)

-            Next i

-        Else

-            pDenmarkData.SignalValue = UpSignal

-            For i = 1 To 3

-                pDenmarkData.Qualificator(i) = UpQual(i)

-            Next i

-        End If

-    End If

-End Sub

-

-Sub DetProj(pPriceData As TPriceData, pDenmarkData As TDenmark)

-'Определение проекции при наличии сигнала: |Signal| > 1

-'Услловие применимости |Signal| > 1 !!!

-    Dim pM As Double, t As Integer, Tm As Integer, tL As Integer

-

-    If pDenmarkData.SignalValue >= 2 Then  ' СИГНАЛ ПОКУПКИ

-

-        tL = pDenmarkData.ResistancePoints(pDenmarkData.ResistancePointCount)     ' tR determination

-        If tL = pPriceData.tC Then

-            tL = pDenmarkData.ResistancePoints(pDenmarkData.ResistancePointCount - 1)

-        End If

-

-'  Projections 1,2 --------------------------------------------

-        If pDenmarkData.ProjectNumber >= 1 And pDenmarkData.ProjectNumber <= 2 Then

-'           t* = Arg min {L(t) : t R <= t  <= tb ,  L(t) < ResistanceLine(t)},

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Lw(Tm) ' L(t-1) < ResistanceLine(t-1) for t - break point !

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Lw(t) < pM And pPriceData.Lw(t) < pDenmarkData.ResistanceLine(t) Then

-                    pM = pPriceData.Lw(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            If pDenmarkData.ProjectNumber = 1 Then

-'               P1( tb) = ResistanceLine(tb) + ResistanceLine(t*) - L(t*)

-                pDenmarkData.ProjectPrice = pDenmarkData.ResistanceLine(pPriceData.tC) + pDenmarkData.ResistanceLine(Tm) - pPriceData.Lw(Tm)

-            Else

-                pDenmarkData.ProjectPrice = pDenmarkData.ResistanceLine(pPriceData.tC) + pDenmarkData.ResistanceLine(Tm) - pPriceData.Cls(Tm)

-            End If

-        End If ' pDenmarkData.ProjectNumber >= 1 And pDenmarkData.ProjectNumber <= 2

-   

-'  ----------------------------------------------------------------

-'  Projections 3

-        If pDenmarkData.ProjectNumber = 3 Then

-'           t*  = Arg min { С(t) : t R <= t  <= tb ,  C(t) < ResistanceLine(t)}

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Cls(Tm)

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Cls(t) < pM And pPriceData.Cls(t) < pDenmarkData.ResistanceLine(t) Then

-                    pM = pPriceData.Cls(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            pDenmarkData.ProjectPrice = pDenmarkData.ResistanceLine(pPriceData.tC) + pDenmarkData.ResistanceLine(Tm) - pPriceData.Cls(Tm)

-        End If

-    End If ' pDenmarkData.SignalValue >= 2

-

-'-------------------------------------------------------------------

-'*******************************************************************

-' ПРОЕКЦИЯ ДЛЯ СИГНАЛА ПРОДАЖИ

-    If pDenmarkData.SignalValue <= -2 Then

-        tL = pDenmarkData.SupportPoints(pDenmarkData.SupportPointsCount)  ' tR determination

-        If tL = pPriceData.tC Then

-            tL = pDenmarkData.ResistancePoints(pDenmarkData.SupportPointsCount - 1)

-        End If

-

-'  Projections 1,2 --------------------------------------------

-        If pDenmarkData.ProjectNumber = 1 Or pDenmarkData.ProjectNumber = 2 Then

-'           t* = Arg max {H(t) : t R <= t  <= tb ,  H(t) > SupportLine(t)},

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Hgh(Tm) ' H(t-1) > SupportLine(t-1) for t - break point !

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Hgh(t) > pM And pPriceData.Hgh(t) > pDenmarkData.SupportLine(t) Then

-                    pM = pPriceData.Hgh(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            If pDenmarkData.ProjectNumber = 1 Then

- '              P1( tb) = SupportLine(tb) + SupportLine(t*) - H(t*)

-                pDenmarkData.ProjectPrice = pDenmarkData.SupportLine(pPriceData.tC) + pDenmarkData.SupportLine(Tm) - pPriceData.Hgh(Tm)

-            Else

-'               P2( tb) = SupportLine(tb) + SupportLine(t*) - C(t*)

-                pDenmarkData.ProjectPrice = pDenmarkData.SupportLine(pPriceData.tC) + pDenmarkData.SupportLine(Tm) - pPriceData.Cls(Tm)

-            End If

-        End If

-   

-'  ----------------------------------------------------------------

-'  Projections 3

-        If pDenmarkData.ProjectNumber = 3 Then

-'           t*  = Arg max { С(t) : t R <= t  <= tb ,  C(t) >  SupportLine(t)}

-'           P3( tb) = SupportLine(tb) + SupportLine(t*) - C(t*)

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Cls(Tm)

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pM < pPriceData.Cls(t) And pPriceData.Cls(t) > pDenmarkData.SupportLine(t) Then

-                    pM = pPriceData.Cls(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            pDenmarkData.ProjectPrice = pDenmarkData.SupportLine(pPriceData.tC) + pDenmarkData.SupportLine(Tm) - pPriceData.Cls(Tm)

-        End If

-    End If ' pDenmarkData.SignalValue <= -2

-End Sub

-

-Sub ResLine(pP As TPriceData, tE As Integer, ResistancePointCount As Integer, _

-            ResistanceLine() As Double, s() As Integer, ClosePrev2 As Boolean, CloseSucc1 As Boolean)

-' Определение линии сопротивления по Демарку [1]

-' Основной вариант

-' ИСХОДНЫЕ ДАННЫЕ:

-' High, dom(High) = [1, tE]

-' ClosePrev2 - H(t) > max{ H(t-1), H(t+1)} и  H(t) > Close(t-2)

-' CloseSucc1 - H(t) > max{ H(t-1), H(t+1)}  и  R(t+1) > Close(t+1)

-' РЕЗУЛЬТАТ:

-' 1) линия сопротивления ResistanceLine, dom(ResistanceLine)=[s(1), tE], и

-' 2) s = {s(1), s(2), ..., s(ResistancePointCount)}, s(1) < s(2) < ...< s(ResistancePointCount)

-'   ( s(ResistancePointCount)<= tE )- опорные точки

-' 3) число опорных точек ResistancePointCount.

-' 4) s(1) -  первый момент времени с которого определена SupportLine

-'    то есть dom{Supp} = [s(1), tC]

-' Прим. Если число опорных точек окажется < 2, то линия

-' сопротивления не определяется. В этом случае следует

-' увеличить историю tE !!!

-    Dim t As Integer, i As Integer

-    Dim v As Double

-    Dim IsGoodPoint As Boolean

-  

-'1 определение опорных моментов времени

-    ResistancePointCount = 0

-    For t = 3 To tE - 1

- '      v = max{high(t-1), high(t+1)} < high(t)}

-        v = pP.Hgh(t - 1)

-        If v < pP.Hgh(t + 1) Then

-            v = pP.Hgh(t + 1)

-        End If

-        IsGoodPoint = pP.Hgh(t) > v

-        If IsGoodPoint And ClosePrev2 Then

-            IsGoodPoint = IsGoodPoint And (pP.Cls(t - 2) < pP.Hgh(t))

-        End If

-        

-        If IsGoodPoint Then       'alt.: v >= High(t + 1)

-            s(ResistancePointCount + 1) = t: ResistancePointCount = ResistancePointCount + 1

-        End If

-    Next t

-    

-loop_:

-    

-    If ResistancePointCount < 2 Then

-        GoTo done

-    End If

-

-' 2 определение линии сопротивления

-    ResistanceLine(s(1)) = pP.Hgh(s(1))

-    For i = 2 To ResistancePointCount

-        ResistanceLine(s(i)) = pP.Hgh(s(i))

-        v = (pP.Hgh(s(i)) - pP.Hgh(s(i - 1))) / (s(i) - s(i - 1))

-        For t = s(i - 1) + 1 To s(i) - 1

-            ResistanceLine(t) = pP.Hgh(s(i - 1)) + v * (t - s(i - 1))

-        Next t

-    Next i

-    If s(ResistancePointCount) < tE Then

-        v = (pP.Hgh(s(ResistancePointCount)) - pP.Hgh(s(ResistancePointCount - 1))) / (s(ResistancePointCount) - s(ResistancePointCount - 1))

-        For t = s(ResistancePointCount) + 1 To tE

-            ResistanceLine(t) = pP.Hgh(s(ResistancePointCount - 1)) + v * (t - s(ResistancePointCount - 1))

-        Next t

-    End If

-    If CloseSucc1 Then

-        For t = 1 To ResistancePointCount

-            If ResistanceLine(s(t) + 1) < pP.Cls(s(t) + 1) Then

-                ResistancePointCount = ResistancePointCount - 1

-                ' удалить точку

-                For i = t To ResistancePointCount

-                    s(i) = s(i + 1)

-                Next i

-                s(ResistancePointCount + 1) = 0

-                ' очистить массив линии

-                Dim Lb, Rb As Integer

-                Lb = LBound(ResistanceLine)

-                Rb = UBound(ResistanceLine)

-                Erase ResistanceLine

-                ReDim ResistanceLine(Lb To Rb)

-                GoTo loop_

-            End If

-        Next t

-    End If

-    

-done:

-End Sub

-

-Sub SuppLine(pP As TPriceData, tE As Integer, SupportPointsCount As Integer, _

-               SupportLine() As Double, s() As Integer, ClosePrev2 As Boolean, CloseSucc1 As Boolean)

-' Определение линии поддержки по Демарку [1] (от конца)

-' Исходные данные:

-' Low, dom(Low) = [1, tE]

-' ClosePrev2 - H(t) > max{ H(t-1), H(t+1)} и  H(t) > Close(t-2)

-' CloseSucc1 - H(t) > max{ H(t-1), H(t+1)}  и  R(t+1) > Close(t+1)

-' Результат:

-' 1) линия сопротивления SupportLine, dom(SupportLine)=[s(1), tE],

-' 2) s = {s(1), s(2), ..., s(SupportPointsCount)}, s(1) < s(2) < ...< s(SupportPointsCount) -

-'    опорные точки

-' 3) число опорных точек SupportPointsCount.

-' Прим. Если фактическое число опорных точек окажется < 2, то линия

-' поддержки не определяется.

-    Dim t As Integer, i As Integer

-    Dim v As Double

-    Dim IsGoodPoint As Boolean

-    

-'1 определение опорных моментов времени

-     SupportPointsCount = 0

-    For t = 3 To tE - 1

-'       v = min{Low(t-1), Low(t+1)} > Low(t)

-        v = pP.Lw(t - 1)

-        If v > pP.Lw(t + 1) Then

-            v = pP.Lw(t + 1)

-        End If

-        

-        IsGoodPoint = pP.Lw(t) < v

-        

-        If IsGoodPoint And ClosePrev2 Then

-            IsGoodPoint = IsGoodPoint And (pP.Cls(t - 2) > pP.Lw(t))

-        End If

-        

-        If IsGoodPoint Then     'alt.: v >= High(t + 1)

-            s(SupportPointsCount + 1) = t: SupportPointsCount = SupportPointsCount + 1

-        End If

-    Next t

-

-loop_:

-    If SupportPointsCount < 2 Then

-        GoTo done

-    End If

-' 2 определение линии поддержки

-    

-    SupportLine(s(1)) = pP.Lw(s(1))

-    For i = 2 To SupportPointsCount

-        SupportLine(s(i)) = pP.Lw(s(i))

-        v = (pP.Lw(s(i)) - pP.Lw(s(i - 1))) / (s(i) - s(i - 1))

-        For t = s(i - 1) + 1 To s(i) - 1

-            SupportLine(t) = pP.Lw(s(i - 1)) + v * (t - s(i - 1))

-        Next t

-    Next i

-    If s(1) < tE Then

-        v = (pP.Lw(s(SupportPointsCount)) - pP.Lw(s(SupportPointsCount - 1))) / (s(SupportPointsCount) - s(SupportPointsCount - 1))

-        For t = s(SupportPointsCount) + 1 To tE

-            SupportLine(t) = pP.Lw(s(SupportPointsCount - 1)) + v * (t - s(SupportPointsCount - 1))

-        Next t

-    End If

-    If CloseSucc1 Then

-        For t = 1 To SupportPointsCount

-            If SupportLine(s(t) + 1) > pP.Cls(s(t) + 1) Then

-                SupportPointsCount = SupportPointsCount - 1

-                ' удалить точку

-                For i = t To SupportPointsCount

-                    s(i) = s(i + 1)

-                Next i

-                s(SupportPointsCount + 1) = 0

-                ' очистить массив линии

-                Dim Lb, Rb As Integer

-                Lb = LBound(SupportLine)

-                Rb = UBound(SupportLine)

-                Erase SupportLine

-                ReDim SupportLine(Lb To Rb)

-                GoTo loop_

-            End If

-        Next t

-    End If

-done:

-End Sub

-

-<<<<<<
-======================
-mChart
->>>>>>
-Attribute VB_Name = "mChart"

-Option Explicit

-

-Const CHART_NAME As String = "PriceChart"

-

-Sub Draw_Chart(SignalDefined As Boolean)

-

-    Dim n As Integer

-    Dim theChart As Chart

-    Dim ChartDataAria, szLastNumber As String

-    Dim MinYScale As Double

-    

-    

-    With ThisWorkbook

-' Checking data

-' Disable screen out

-        .Application.Cursor = xlWait

-        .Application.ScreenUpdating = False

-' Create series range

-        n = GetLinesCount(Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE))

-        szLastNumber = n + 1

-        If SignalDefined Then

-            ChartDataAria = "A2:A" & szLastNumber _

-                        & ",D2:D" & szLastNumber _

-                        & ",G2:G" & szLastNumber _

-                        & ",I2:K" & szLastNumber

-        Else

-            ChartDataAria = "A2:A" & szLastNumber _

-                        & ",D2:D" & szLastNumber _

-                        & ",G2:G" & szLastNumber _

-                        & ",I2:J" & szLastNumber

-        End If

-        MinYScale = GetMinValue(.Worksheets(RAW_DATA_SHEET).Range(ChartDataAria))

-' Find and delete old chart

-        .Worksheets(CHART_SHEET).Unprotect

-        Dim WindowWidth, WindowHeight As Integer

-        With .Worksheets(CHART_SHEET)

-            WindowWidth = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-            WindowHeight = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-        End With

-        

-        

-        With .Worksheets(CHART_SHEET).ChartObjects

-            .Delete

-            With .Add(5, 5, WindowWidth - 10, WindowHeight - 10)

-                .SendToBack

-                Set theChart = .Chart

-            End With

-' Create a chart

-        End With

-        With theChart

-            .ChartType = xlLine

-            .SetSourceData Source:=Sheets(RAW_DATA_SHEET).Range( _

-                    ChartDataAria), PlotBy:=xlColumns

-'                   .Location Where:=xlLocationAsObject, Name:=CHART_SHEET

-            .HasTitle = True

-            With .ChartTitle

-                .Text = ThisWorkbook.Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE).Value

-                With .Font

-                    .Size = 8

-                    .Bold = True

-                End With

-            End With

-            .HasLegend = True

-            With .Legend

-                .Position = xlTop

-                With .Font

-                    .Name = "Arial"

-                    .Size = 8

-                End With

-            End With

-            .HasDataTable = False

-            With .Axes(xlCategory)

-                .HasMajorGridlines = True

-                .HasMinorGridlines = False

-                .TickLabels.Orientation = xlUpward

-                With .MajorGridlines.Border

-                    .ColorIndex = 48

-                    .Weight = xlHairline

-                    .LineStyle = xlDot

-                End With

-                .CrossesAt = 1

-                .TickLabelSpacing = 1

-                .TickMarkSpacing = 1

-                .AxisBetweenCategories = False

-                .ReversePlotOrder = False

-                .TickLabels.AutoScaleFont = True

-                With .TickLabels.Font

-                    .Name = "Arial"

-                    .Size = 8

-                End With

-            End With

-            With .Axes(xlValue)

-                .HasMajorGridlines = True

-                .HasMinorGridlines = False

-                With .MajorGridlines.Border

-                    .ColorIndex = 48

-                    .Weight = xlHairline

-                    .LineStyle = xlDot

-                End With

-                .MinimumScale = MinYScale

-                .MaximumScaleIsAuto = True

-                .MinorUnitIsAuto = True

-                .MajorUnitIsAuto = True

-                .Crosses = xlCustom

-                .CrossesAt = MinYScale

-                .ReversePlotOrder = False

-                .ScaleType = xlLinear

-                .TickLabels.AutoScaleFont = True

-                With .TickLabels.Font

-                    .Name = "Arial"

-                    .Size = 9

-                End With

-            End With

-            .ChartTitle.Top = 5

-            .ChartTitle.Left = 5

-            With .Legend

-                .Top = 5

-                .Fill.OneColorGradient _

-                    Style:=msoGradientHorizontal, _

-                    Variant:=3, _

-                    Degree:=0.303913939116503

-                .Fill.Visible = True

-                .Fill.ForeColor.SchemeColor = 71

-            End With

-            .PlotArea.Left = 10

-            .PlotArea.Top = .Legend.Top + .Legend.Height + 5

-            .PlotArea.Width = .ChartArea.Width - 20

-            .PlotArea.Height = .ChartArea.Height - .PlotArea.Top

-            

-' Tune OPEN line

-            With .SeriesCollection(1)

-                .Border.LineStyle = xlNone

-                .MarkerBackgroundColorIndex = xlNone

-                .MarkerForegroundColorIndex = 1

-                .MarkerStyle = xlPlus

-                .Smooth = False

-                .MarkerSize = 9

-                .Shadow = False

-            End With

-' Tune CLOSE line

-            With .SeriesCollection(2)

-                .Border.ColorIndex = 10

-                .Border.Weight = xlMedium

-                .Border.LineStyle = xlContinuous

-            End With

-' Tune RESISTANCE line

-            With .SeriesCollection(3)

-                .Border.ColorIndex = 3

-                .Border.Weight = xlThin

-                .Border.LineStyle = xlContinuous

-            End With

-' Tune SUUPORT line

-            With .SeriesCollection(4)

-                .Border.ColorIndex = 25

-                .Border.Weight = xlThin

-                .Border.LineStyle = xlContinuous

-            End With

-            If SignalDefined Then

-                With .SeriesCollection(5)

-                    .Border.ColorIndex = 6

-                    .Border.Weight = xlThin

-                    .Border.LineStyle = xlDot

-                End With

-            End If

-        End With

-        .Application.Cursor = xlDefault

-        With .Worksheets(CHART_SHEET)

-            .Select

-            .Protect userInterfaceOnly:=True

-        End With

-    End With

-End Sub

-

-Function GetMinValue(DataRange As Range) As Double

-    Dim Cell As Range

-    Dim MinValue, MaxValue, RangeValue, CorrectValue, Mult As Double

-    MinValue = MAX_PRICE_VALUE

-    MaxValue = MIN_PRICE_VALUE

-    For Each Cell In DataRange

-        If Not IsEmpty(Cell) And IsNumeric(Cell) Then

-            If Cell > MIN_PRICE_VALUE Then

-                If Cell < MinValue Then

-                    MinValue = Cell

-                End If

-                If Cell > MaxValue Then

-                    MaxValue = Cell

-                End If

-            End If

-        End If

-    Next

-    RangeValue = MaxValue - MinValue

-    If RangeValue < 0 Then

-        MinValue = 0

-    Else

-        CorrectValue = RangeValue / 4

-        Mult = MIN_PRICE_VALUE

-        While MinValue - Int(MinValue * Mult) / Mult > CorrectValue

-            Mult = Mult * 10

-        Wend

-        MinValue = Int(MinValue * Mult) / Mult

-    End If

-    GetMinValue = MinValue

-End Function

-

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub GetState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.Name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars("Worksheet Menu Bar").Visible = False

-End Sub

-

-

-Public Sub RestoreState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars("Worksheet Menu Bar").Visible = True

-End Sub

-

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{F2CF310F-F99B-428A-9EA4-35CA19429F9D}{CECE7A6F-1D1D-47DF-AE0E-E6EAFC692914}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Private Sub CommandButton1_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-mWebQeury
->>>>>>
-Attribute VB_Name = "mWebQeury"

-Option Explicit

-

-Public Const Qry_DELETE_ALL As String = "Qry_DELETE_ALL"

-Public Const Qry_PATH_NO_CHANGE As String = "Qry_PATH_NO_CHANGE"

-

-

-Sub QryCreate(QryRange As Range, QryName As String, QryPath As String, Optional RefreshBkgnd = False)

-    Dim WebQuery As QueryTable

-    QryDelete QryRange:=QryRange, QryName:=QryName

-    

-    Set WebQuery = QryRange.Worksheet.QueryTables.Add( _

-            Connection:=QryPath, _

-            Destination:=QryRange)

-    

-    With WebQuery

-        .FieldNames = False

-        .Name = QryName

-        .RefreshStyle = xlOverwriteCells

-        .RowNumbers = False

-        .FillAdjacentFormulas = False

-        .RefreshOnFileOpen = False

-        .HasAutoFormat = False

-        .BackgroundQuery = False

-        .TablesOnlyFromHTML = False

-        .Refresh BackgroundQuery:=RefreshBkgnd

-        .SavePassword = False

-        .SaveData = True

-    End With

-End Sub

-

-Function QryRefresh(QryRange As Range, QryName As String, Optional QryPath As String = Qry_PATH_NO_CHANGE, Optional Background As Boolean = False) As Boolean

-    Dim qry_result As Boolean

-    qry_result = False

-    If QryExist(QryRange, QryName) Then

-        With QryRange.Worksheet.QueryTables(QryName)

-            If QryPath <> Qry_PATH_NO_CHANGE Then

-                .Connection = QryPath

-            End If

-            .Refresh BackgroundQuery:=Background

-            qry_result = True

-        End With

-    End If

-    QryRefresh = qry_result

-End Function

-

-Sub QryDelete(QryRange As Range, Optional QryName As String = Qry_DELETE_ALL)

-    Dim WebQuery As QueryTable

-    For Each WebQuery In QryRange.Worksheet.QueryTables

-        If QryName = Qry_DELETE_ALL Or WebQuery.Name = QryName Then

-            WebQuery.Delete

-        End If

-    Next

-End Sub

-

-Function QryExist(QryRange As Range, QryName As String) As Boolean

-    Dim WebQuery As QueryTable

-    For Each WebQuery In QryRange.Worksheet.QueryTables

-        If WebQuery.Name = QryName Then

-            QryExist = True

-            Exit For

-        End If

-    Next

-End Function

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Sub CreateCommandBar(theApp As Application)

-Attribute CreateCommandBar.VB_ProcData.VB_Invoke_Func = "R\n14"

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible + msoBarNoCustomize + msoBarNoMove + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Print"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 4

-                        .OnAction = "cmPrint"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Contents"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 49

-                        .OnAction = "cmHelpContents"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible + msoBarNoCustomize + msoBarNoMove + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(Flag As Boolean)

-    If Flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars("Worksheet Menu Bar")

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        cmHelpContents

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mTool
->>>>>>
-Attribute VB_Name = "mTool"

-Option Explicit

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub tool_delete_all_tables()

-    QryDelete ThisWorkbook.Worksheets(RAW_DATA_SHEET).Range("A1")

-End Sub

-

-Sub tool_delete_all_charts(theSheet As Worksheet)

-    Dim theChart As Chart

-    For Each theChart In theSheet

-        theChart.Unprotect

-        theChart.Delete

-    Next

-End Sub

-

-Sub DateTimeTest()

-    Dim the_date

-    Dim the_time

-    the_date = DateValue(Now)

-    the_time = TimeValue(Now)

-End Sub

-

-

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{57513C6C-49E1-468C-B487-CCDA83083AF1}{4BF9D9B0-BBEB-400E-B2EF-800B8C4C6694}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-

-Private Sub App_WorkbookOpen(ByVal wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If Application.Workbooks.count > 1 Then

-        wbname = wb.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKCancel, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            wb.Close Savechanges:=False

-        End If

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-mDataCommands
->>>>>>
-Attribute VB_Name = "mDataCommands"

-Option Explicit

-

-Sub evFileOpen()

-    Dim fileToOpen As String

-    Dim wb As Workbook

-    Dim ticker As String

-    Dim Result As Integer

-

-    fileToOpen = Application.GetOpenFilename("Text Files (*.txt), *.txt, Data Files (*.csv), *.csv")

-    Set wb = ThisWorkbook

-    With wb

-        If fileToOpen <> "False" Then

-            If .Worksheets(VAR_SHEET).Range("BOOL_AUTORECALC") = True Then

-                .Worksheets(VAR_SHEET).Range("BOOL_AUTORECALC") = False

-            End If

-            .Worksheets(FORM_SHEET).Range(FILE_NAME) = fileToOpen

-            Result = UpdateHistoryFromFile(wb, fileToOpen)

-            .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False

-            .Worksheets(VAR_SHEET).Range("BOOL_DEMARK_READY") = False

-            

-            ClearResultTables

-            

-            Select Case Result

-                Case FUNCRES_FILE_OK

-                    .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = True

-                    If TDenmark_Calc Then

-                        With .Worksheets(RAW_DATA_SHEET)

-                            ticker = .Range("B1")

-                        End With

-                        With .Worksheets(FORM_SHEET)

-                            .Range("CALC_TICKER_NAME") = ticker

-                        End With

-                    End If

-                Case FUNCRES_FILE_VERY_SMALL

-                    .Worksheets(FORM_SHEET).Range("CALC_TICKER_NAME") = MSG_FILE_VERY_SMALL

-                    MsgBox MSG_FILE_VERY_SMALL, vbOKOnly, PROGRAM_NAME

-                Case FUNCRES_FILE_INVALID_FORMAT

-                    .Worksheets(FORM_SHEET).Range("CALC_TICKER_NAME") = MSG_FILE_INVALID_FORMAT

-                    MsgBox MSG_FILE_INVALID_FORMAT, vbOKOnly, PROGRAM_NAME

-                End Select

-            .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False

-        End If

-    End With 'wb

-End Sub

-

-Sub evSubmit_Click()

-    Dim ticker As String

-    Dim Period As String

-

-    Application.Cursor = xlWait

-    Dim wb As Workbook

-    Set wb = ThisWorkbook

-    With wb

-        With .Worksheets(VAR_SHEET)

-            ticker = .Range("DEN_SYMBOL")

-            Period = .Range("DEN_TIME")

-            If .Range("BOOL_DATA_READY") = False Or .Range("BOOL_LOAD_DATA") = True Then

-                .Range("BOOL_DATA_READY") = UpdateHistoryFromWeb(wb)

-            End If

-            .Range("BOOL_DEMARK_READY") = False

-        End With

-        If .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False Then

-            MsgBox _

-                Prompt:="Недостаточна глубина выборки данных." _

-                    & vbCrLf & "Измените параметры запроса и пробуйте снова.", _

-                Buttons:=vbOKOnly + vbExclamation, _

-                Title:=PROGRAM_NAME

-            

-            ClearResultTables

-            

-            With .Worksheets(FORM_SHEET)

-                .Range("CALC_TICKER_NAME") = ticker & ", Period=" & Period

-                .Range("FILE_NAME") = ""

-                .Range(TABLE_COMMENT).Value = "Недостаточно данных"

-            End With

-        Else

-            If TDenmark_Calc Then

-                With .Worksheets(FORM_SHEET)

-                    .Range("CALC_TICKER_NAME") = ticker & ", Period=" & Period

-                    .Range("FILE_NAME") = ""

-                End With

-            End If

-        End If

-    End With

-    Application.Cursor = xlDefault

-End Sub

-

-Sub evTicker_Change()

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("IDX_DEN_SECNAME") = .Range("IDX_DEN_SYMBOL")

-    End With

-    evHistory_Change

-End Sub

-

-Sub evSecName_Change()

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("IDX_DEN_SYMBOL") = .Range("IDX_DEN_SECNAME")

-    End With

-    evHistory_Change

-End Sub

-

-Sub evLastInterval_Change()

-    MsgBox "Не работает в этой версии"

-End Sub

-

-Sub evHistory_Change()

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("BOOL_DATA_READY") = False

-    End With

-End Sub

-

-Sub evGroupChange()

-    Dim GroupIdx, LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange As String

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        GroupIdx = .Range("IDX_DEN_LIST")

-        .Range("IDX_DEN_SYMBOL") = 1

-        NewRangeOffsetCol = (GroupIdx - 1) * 2

-        LinesCount = GetLinesCount(.Range("TICKER_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .Name & "!" & .Range(.Range("TICKER_TABLES").Offset(1, NewRangeOffsetCol), .Range("TICKER_TABLES").Offset(LinesCount, NewRangeOffsetCol)).Address

-        ThisWorkbook.Worksheets(FORM_SHEET).Shapes("cbxTikers").ControlFormat.ListFillRange = NewCbxRange

-        NewRangeOffsetCol = NewRangeOffsetCol + 1

-        NewCbxRange = .Name & "!" & .Range(.Range("TICKER_TABLES").Offset(1, NewRangeOffsetCol), .Range("TICKER_TABLES").Offset(LinesCount, NewRangeOffsetCol)).Address

-        ThisWorkbook.Worksheets(FORM_SHEET).Shapes("cbxSecName").ControlFormat.ListFillRange = NewCbxRange

-    End With

-    evTicker_Change

-End Sub

-

-Sub evUpdateTickerList()

-    UpdateTickerList ThisWorkbook

-    evHistory_Change

-End Sub

-<<<<<<
-======================
-mGetFileData
->>>>>>
-Attribute VB_Name = "mGetFileData"

-Option Explicit

-

-Dim mobjAppRunEnable As New cEnableRun

-

-Public Const MAX_LOAD_DATA_LINES As Integer = 16000

-

-Public Const MSG_FILE_VERY_SMALL As String = "В файле недостаточно данных"

-Public Const MSG_FILE_INVALID_FORMAT As String = "Неверный формат файла"

-

-Public Const FUNCRES_FILE_OK As Integer = 0

-Public Const FUNCRES_FILE_VERY_SMALL As Integer = -1

-Public Const FUNCRES_FILE_INVALID_FORMAT As Integer = -2

-

-Function UpdateHistoryFromFile(wb As Workbook, fileToOpen As String) As Integer

-    Dim DestRangeName As String

-    Dim ResultLength As Integer

-    Dim Location As Range

-    Dim denWindow As Integer

-    Dim IsIntraday As Boolean

-    Dim CalcNextTime As Boolean

-        

-    Dim SingleFileLine As String

-    Dim FileHandler As Integer

-    Dim i, j, row_idx As Integer

-    

-    UpdateHistoryFromFile = FUNCRES_FILE_INVALID_FORMAT

-    With wb

-        .Application.ScreenUpdating = False

-        With .Worksheets(VAR_SHEET)

-            CalcNextTime = .Range("BOOL_NEXT_TIME")

-            denWindow = .Range("DEN_WINDOW") + 1

-            If CalcNextTime Then

-                denWindow = denWindow + 1

-            End If

-            IsIntraday = True

-        End With

-        With .Worksheets(RAW_DATA_SHEET)

-            'Clear table include temp area

-            .Parent.Application.DisplayAlerts = False

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW - 1, RAW_DATA_RANGE_COL - 1), _

-                .Cells(65535, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-            ).ClearContents

-            Set Location = .Range(RAW_DATA_RANGE).Offset(-1, 0)

-            

-            ' Reading data from file

-            FileHandler = FreeFile

-            row_idx = 0

-            Open fileToOpen For Input As #FileHandler

-            Do While Not EOF(FileHandler) And row_idx < MAX_LOAD_DATA_LINES

-                Line Input #FileHandler, SingleFileLine

-                .Range(PRICE_TABLE).Offset(row_idx, 0) = SingleFileLine

-                row_idx = row_idx + 1

-            Loop

-            Close #FileHandler

-            

-            ' Parsing data

-            DestRangeName = "=" & RAW_DATA_SHEET & "!$B$1:$B" & row_idx

-            ResultLength = row_idx

-            

-            .Range(DestRangeName).TextToColumns _

-                Destination:=.Range(DestRangeName), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=True, _

-                Semicolon:=True, _

-                Comma:=True, _

-                Space:=False, _

-                Other:=False, _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 1), _

-                                Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1))

-            

-            .Parent.Application.DisplayAlerts = True

-            Dim CurrentDate As String

-            Dim RawData As Range

-            

-            Set RawData = .Range(RAW_DATA_RANGE)

-            

-            If Not CheckFileFormat(RawData.Offset(-1, 0)) Then

-                UpdateHistoryFromFile = FUNCRES_FILE_INVALID_FORMAT

-                Exit Function

-            End If

-            

-            row_idx = 0

-            With RawData

-                CurrentDate = .Value

-                For i = 1 To ResultLength

-                    If Not IsIntraday And CurrentDate = .Offset(i, DATE_IDX).Value Then

-                        ' skip virtual prices

-                        If (.Offset(i, VOLUME_IDX) > MIN_PRICE_VALUE) Then

-                            If .Offset(row_idx, HIGH_IDX).Value < .Offset(i, HIGH_IDX).Value Then

-                                .Offset(row_idx, HIGH_IDX).Value = .Offset(i, HIGH_IDX).Value

-                            End If

-                            If .Offset(row_idx, LOW_IDX).Value > .Offset(i, LOW_IDX).Value Then

-                                .Offset(row_idx, LOW_IDX).Value = .Offset(i, LOW_IDX).Value

-                            End If

-                            .Offset(row_idx, VOLUME_IDX).Value = _

-                                .Offset(row_idx, VOLUME_IDX).Value + .Offset(i, VOLUME_IDX).Value

-                            .Offset(row_idx, TIME_IDX).Value = .Offset(i, TIME_IDX).Value

-                            .Offset(row_idx, CLOSE_IDX).Value = .Offset(i, CLOSE_IDX).Value

-                        End If

-                    Else

-                        ' skip virtual prices

-                        If (.Offset(row_idx, VOLUME_IDX) > MIN_PRICE_VALUE) Then

-                            row_idx = row_idx + 1

-                        End If

-                        For j = DATE_IDX To VOLUME_IDX

-                            .Offset(row_idx, j) = .Offset(i, j)

-                        Next j

-                        CurrentDate = .Offset(i, DATE_IDX)

-                    End If

-                Next i

-            End With ' RawData

-            ' Clear unused Cells

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(65536, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-            ).ClearContents

-            

-            If row_idx > denWindow Then

-                row_idx = row_idx - denWindow

-                .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-                ).Delete xlShiftUp

-            Else

-                UpdateHistoryFromFile = FUNCRES_FILE_VERY_SMALL

-                Exit Function

-            End If

-            

-            row_idx = denWindow + 1

-            

-            Set Location = .Range( _

-                .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_IDX) _

-            )

-            

-            Location.TextToColumns _

-                Destination:=Location.Offset(0, DATE_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:="/", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2))

-            

-            Location.Offset(0, TIME_IDX).TextToColumns _

-                Destination:=Location.Offset(0, TIME_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:=":", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2))

-            

-            ' Check estimation date

-            

-            Dim end_date, end_time As Date

-            Dim year, month, day As Integer

-            Dim hour, minute As Integer

-            Dim next_time_exist As Boolean

-            

-            year = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 3)

-            month = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 2)

-            day = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 1)

-            hour = Location.Cells(denWindow - 1, TIME_STAMP_OFFSET + 1)

-            minute = Location.Cells(denWindow - 1, TIME_STAMP_OFFSET + 2)

-            

-            next_time_exist = day + month + year <> 0

-            

-            If next_time_exist Then

-                end_date = DateSerial(year, month, day)

-                end_time = TimeSerial(hour, minute, 0)

-                mobjAppRunEnable.EnableRun ESTIMATION_DATE, end_date

-            End If

-             

-            row_idx = 0

-            Dim temp_str As String

-                    

-            If IsIntraday Then

-                Do While IsEmpty(Location.Cells(1 + row_idx, 1 + DATE_IDX)) = False

-                       temp_str = Location.Cells(1 + row_idx, 1 + PROJECT_IDX + 1)

-                       temp_str = temp_str & "/"

-                       temp_str = temp_str & Location.Cells(1 + row_idx, 1 + PROJECT_IDX + 2)

-                       temp_str = temp_str & "-"

-                       temp_str = temp_str & Location.Cells(1 + row_idx, 1 + TIME_IDX)

-                       Location.Cells(1 + row_idx, DATE_IDX) = temp_str

-                       row_idx = row_idx + 1

-                Loop

-                row_idx = row_idx - 1

-                Dim condition As Boolean

-                condition = Not CalcNextTime And next_time_exist And end_date = DateValue(Now) And end_time > TimeValue(Now)

-                If condition Then

-                    .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL - 1), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-                    ).Delete xlShiftUp

-                End If

-            End If

-        End With ' .Worksheets(RAW_DATA_SHEET)

-    End With ' wb

-    UpdateHistoryFromFile = FUNCRES_FILE_OK

-End Function

-

-Function CheckFileFormat(HeaderString As Range) As Boolean

-    With HeaderString

-        CheckFileFormat = _

-            .Offset(0, DATE_IDX) = "Date" And _

-            .Offset(0, TIME_IDX) = "Time" And _

-            .Offset(0, OPEN_IDX) = "Open" And _

-            .Offset(0, CLOSE_IDX) = "Close" And _

-            .Offset(0, LOW_IDX) = "Low" And _

-            .Offset(0, HIGH_IDX) = "High" And _

-            .Offset(0, VOLUME_IDX) = "Volume"

-    End With

-End Function

-<<<<<<
-Project Name : 'Denmark_method'
-Quirk - duff tag length======================
-MGetWebData
->>>>>>
-Attribute VB_Name = "MGetWebData"

-Option Explicit

-

-Dim mobjAppRunEnable As New cEnableRun

-

-Const QueryDataName As String = "ExternalDenmarkData"

-

-Function UpdateHistoryFromWeb(Wb As Workbook) As Boolean

-    Dim DestRangeName As String

-    Dim ResultLength As Integer

-    Dim QryPathStr As String

-    Dim Location As Range

-    Dim denWindow As Integer

-    Dim IsIntraday As Boolean

-    Dim CalcNextTime As Boolean

-        

-    UpdateHistoryFromWeb = False

-    QryPathStr = GetQryPath(Wb)

-    With Wb

-        .Application.ScreenUpdating = False

-        With .Worksheets(VAR_SHEET)

-            DestRangeName = .Range("DEN_SYMBOL")

-            CalcNextTime = .Range("BOOL_NEXT_TIME")

-            denWindow = .Range("DEN_WINDOW") + 1

-            If CalcNextTime Then

-                denWindow = denWindow + 1

-            End If

-            IsIntraday = IsNumeric(.Range("DEN_TIME"))

-        End With

-        With .Worksheets(RAW_DATA_SHEET)

-            .Range(PRICE_TABLE) = DestRangeName

-            'Clear table include temp area

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW - 1, RAW_DATA_RANGE_COL - 1), _

-                .Cells(65535, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-            ).ClearContents

-            Set Location = .Range(RAW_DATA_RANGE).Offset(-1, 0)

-            If Not QryExist(Location, QueryDataName) Then

-                QryCreate Location, QueryDataName, QryPathStr

-            Else

-                QryRefresh Location, QueryDataName, QryPathStr

-            End If

-            With Location.Worksheet.QueryTables(QueryDataName)

-                DestRangeName = .ResultRange.name.RefersTo

-                ResultLength = .ResultRange.count

-            End With

-    

-    '        .Parent.Application.DisplayAlerts = False

-            

-            .Range(DestRangeName).TextToColumns _

-                Destination:=.Range(DestRangeName), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=True, _

-                Semicolon:=True, _

-                Comma:=True, _

-                Space:=False, _

-                Other:=False, _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 1), _

-                                Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1))

-            

-    '        .Parent.Application.DisplayAlerts = True

-            Dim i, j, row_idx As Integer

-            Dim CurrentDate As String

-            Dim RawData As Range

-            

-            Set RawData = .Range(RAW_DATA_RANGE)

-            row_idx = 0

-            With RawData

-                CurrentDate = .Value

-                For i = 1 To ResultLength

-                    If Not IsIntraday And CurrentDate = .Offset(i, DATE_IDX).Value Then

-                        ' skip virtual prices

-                        If (.Offset(i, VOLUME_IDX) > MIN_PRICE_VALUE) Then

-                            If .Offset(row_idx, HIGH_IDX).Value < .Offset(i, HIGH_IDX).Value Then

-                                .Offset(row_idx, HIGH_IDX).Value = .Offset(i, HIGH_IDX).Value

-                            End If

-                            If .Offset(row_idx, LOW_IDX).Value > .Offset(i, LOW_IDX).Value Then

-                                .Offset(row_idx, LOW_IDX).Value = .Offset(i, LOW_IDX).Value

-                            End If

-                            .Offset(row_idx, VOLUME_IDX).Value = _

-                                .Offset(row_idx, VOLUME_IDX).Value + .Offset(i, VOLUME_IDX).Value

-                            .Offset(row_idx, TIME_IDX).Value = .Offset(i, TIME_IDX).Value

-                            .Offset(row_idx, CLOSE_IDX).Value = .Offset(i, CLOSE_IDX).Value

-                        End If

-                    Else

-                        ' skip virtual prices

-                        If (.Offset(row_idx, VOLUME_IDX) > MIN_PRICE_VALUE) Then

-                            row_idx = row_idx + 1

-                        End If

-                        For j = DATE_IDX To VOLUME_IDX

-                            .Offset(row_idx, j) = .Offset(i, j)

-                        Next j

-                        CurrentDate = .Offset(i, DATE_IDX)

-                    End If

-                Next i

-            End With ' RawData

-            ' Clear unused Cells

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(65536, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-            ).ClearContents

-            

-            If row_idx > denWindow Then

-                row_idx = row_idx - denWindow

-                .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-                ).delete xlShiftUp

-            Else

-                Exit Function

-            End If

-            

-            row_idx = denWindow + 1

-            

-            Set Location = .Range( _

-                .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_IDX) _

-            )

-            

-            Location.TextToColumns _

-                Destination:=Location.Offset(0, DATE_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:="/", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2))

-            

-            Location.Offset(0, TIME_IDX).TextToColumns _

-                Destination:=Location.Offset(0, TIME_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:=":", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2))

-            

-            ' Check estimation date

-            

-            Dim end_date, end_time As Date

-            Dim year, month, day As Integer

-            Dim hour, minute As Integer

-            Dim next_time_exist As Boolean

-            

-            year = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 3)

-            month = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 2)

-            day = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 1)

-            hour = Location.Cells(denWindow - 1, TIME_STAMP_OFFSET + 1)

-            minute = Location.Cells(denWindow - 1, TIME_STAMP_OFFSET + 2)

-            

-            next_time_exist = day + month + year <> 0

-            

-            If next_time_exist Then

-                end_date = DateSerial(year, month, day)

-                end_time = TimeSerial(hour, minute, 0)

-                mobjAppRunEnable.EnableRun ESTIMATION_DATE, end_date

-            End If

-             

-            row_idx = 0

-            Dim temp_str As String

-                    

-            If IsIntraday Then

-                Do While IsEmpty(Location.Cells(1 + row_idx, 1 + DATE_IDX)) = False

-                       temp_str = Location.Cells(1 + row_idx, 1 + PROJECT_IDX + 1)

-                       temp_str = temp_str & "/"

-                       temp_str = temp_str & Location.Cells(1 + row_idx, 1 + PROJECT_IDX + 2)

-                       temp_str = temp_str & "-"

-                       temp_str = temp_str & Location.Cells(1 + row_idx, 1 + TIME_IDX)

-                       Location.Cells(1 + row_idx, DATE_IDX) = temp_str

-                       row_idx = row_idx + 1

-                Loop

-                row_idx = row_idx - 1

-                Dim condition As Boolean

-                condition = Not CalcNextTime And next_time_exist And end_date = DateValue(Now) And end_time > TimeValue(Now)

-                If condition Then

-                    .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL - 1), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-                    ).delete xlShiftUp

-                End If

-            Else

-                Do While IsEmpty(Location.Cells(1 + row_idx, 1 + DATE_IDX)) = False

-                       temp_str = "'" & Location.Cells(1 + row_idx, 1)

-                       Location.Cells(1 + row_idx, DATE_IDX) = temp_str

-                       row_idx = row_idx + 1

-                Loop

-                row_idx = row_idx - 1

-                condition = Not CalcNextTime And next_time_exist And end_date = DateValue(Now) And TimeValue(Now) < TimeSerial(18, 0, 0)

-                If condition Then

-                    .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL - 1), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-                    ).delete xlShiftUp

-                End If

-            End If

-        End With ' .Worksheets(RAW_DATA_SHEET)

-    End With ' wb

-    UpdateHistoryFromWeb = True

-End Function

-

-Private Function GetQryPath(Wb As Workbook) As String

-    Dim QryPathStr As String

-    Dim IsIntradai As Boolean

-    Dim DayCount As Integer

-    With Wb.Worksheets(VAR_SHEET)

-        QryPathStr = "URL;http://online.rbc.ru/cgi-bin/online/nph-single.cgi?"

-        QryPathStr = QryPathStr & "ticker=" & .Range("DEN_SYMBOL")

-        QryPathStr = QryPathStr & "&source=" & .Range("DEN_SOURCE")

-        QryPathStr = QryPathStr & "&board=" & .Range("DEN_BOARD")

-        IsIntradai = IsNumeric(.Range("DEN_TIME"))

-        If IsIntradai Then

-            QryPathStr = QryPathStr & "&period=" & .Range("DEN_TIME")

-        Else

-            QryPathStr = QryPathStr & "&period=60"

-        End If

-        QryPathStr = QryPathStr & "&oh=11&ch=18"

-        QryPathStr = QryPathStr & "&separator=%2C"

-        QryPathStr = QryPathStr & "&vmode=Ignore&vtype=BA2"

-        QryPathStr = QryPathStr & "&format=Excel"

-        

-        If IsIntradai Then

-            DayCount = .Range("DEN_HISTORY") * .Range("DEN_TIME") \ 420 + 1 + .Range("DEN_HISTORY")

-        Else

-            DayCount = .Range("DEN_HISTORY")

-        End If

-        QryPathStr = QryPathStr & "&daysback=" & DayCount

-'        .Range("LAST_HIST_QRY") = QryPathStr

-    End With

-    GetQryPath = QryPathStr

-    

-End Function

-

-Sub UpdateTickerList(Wb As Workbook)

-    Dim Idx, n As Integer

-    Dim ResultLength As Integer

-    Dim Location As Range

-    Dim QryPathStr As String

-    Dim QueryDataName As String

-    Dim DestRangeArea As String

-    

-    QryPathStr = GetListPath(Wb)

-    With Wb

-        With .Worksheets(VAR_SHEET)

-            Idx = .Range("IDX_DEN_LIST")

-            Set Location = .Range("TICKER_TABLES").Offset(0, (Idx - 1) * 2)

-             .Range("IDX_DEN_SYMBOL") = 1

-            QueryDataName = Location.Offset(0, 0)

-            'Clear table

-            .Range(Location.Offset(1, 0), Location.Offset(65535 - Location.Row, 1)).ClearContents

-            

-            If Not QryExist(Location.Offset(1, 0), QueryDataName) Then

-                QryCreate Location.Offset(1, 0), QueryDataName, QryPathStr

-            Else

-                QryRefresh Location.Offset(1, 0), QueryDataName, QryPathStr

-            End If

-            ' Remove header

-            ' Find [DATA]

-            n = 0

-            Do While Location.Offset(n, 0) <> "[DATA]"

-                n = n + 1

-            Loop

-            .Range(Location.Offset(1, 0), Location.Offset(n, 1)).delete Shift:=xlUp

-            With .QueryTables(QueryDataName)

-                DestRangeArea = .ResultRange.name.RefersTo

-                ResultLength = .ResultRange.count

-            End With

-        

-        '        .Parent.Application.DisplayAlerts = False

-                

-            .Range(DestRangeArea).TextToColumns _

-                Destination:=.Range(DestRangeArea), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=True, _

-                Semicolon:=True, _

-                Comma:=True, _

-                Space:=False, _

-                Other:=False, _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 9))

-        ' Sort Data

-            Set Location = .Range(.Range(DestRangeArea).Offset(0, 0), .Range(DestRangeArea).Offset(ResultLength - 1, 1))

-            Location.Sort _

-                Key1:=.Range(DestRangeArea).Offset(0, 0), _

-                Order1:=xlAscending, _

-                Header:=xlNo, _

-                OrderCustom:=1, _

-                MatchCase:=False, _

-                Orientation:=xlTopToBottom

-        End With

-        ' Setup Ticker List

-         With .Worksheets(VAR_SHEET)

-            DestRangeArea = .name & "!" & .Range(.Range(DestRangeArea).Cells(1, 1), .Range(DestRangeArea).Cells(ResultLength - 1, 1)).Address

-         End With

-        With .Worksheets(FORM_SHEET).Shapes("cbxTikers").ControlFormat

-            .ListFillRange = DestRangeArea

-            .ListIndex = 1

-        End With

-        ' Setup Name List

-         With .Worksheets(VAR_SHEET)

-            DestRangeArea = .name & "!" & .Range(.Range(DestRangeArea).Cells(1, 1), .Range(DestRangeArea).Cells(ResultLength - 1, 1)).Offset(0, 1).Address

-         End With

-        With .Worksheets(FORM_SHEET).Shapes("cbxSecName").ControlFormat

-            .ListFillRange = DestRangeArea

-            .ListIndex = 1

-        End With

-    End With

-End Sub

-

-Private Function GetListPath(Wb As Workbook) As String

-    Dim QryPathStr As String

-    With Wb.Worksheets(VAR_SHEET)

-        QryPathStr = "URL;http://online.rbc.ru/cgi-bin/names.cgi?"

-        QryPathStr = QryPathStr & "&source=" & .Range("DEN_SOURCE")

-        QryPathStr = QryPathStr & "&board=" & .Range("DEN_BOARD")

-        QryPathStr = QryPathStr & "&category=STOCKS"

-        '.Range("LAST_DIR_QRY") = QryPathStr

-    End With

-    GetListPath = QryPathStr

-End Function

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    Set MyAppEvents.app = Application

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    If Application.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEL сейчас будут закрыты!", vbOKCancel, "$" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close Savechanges:=False

-            Exit Sub

-        End If

-    End If

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False

-    cmSetStandaloneMode

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-        If ThisWorkbook.Saved = False Then

-            ThisWorkbook.Save

-        End If

-    End If

-    Application.Caption = Empty

-    Application.CommandBars("Worksheet Menu Bar").Reset

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-        Dim MaxX, MaxY As Integer

-        With ThisWorkbook.Worksheets(FORM_SHEET)

-            MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-            MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-        End With

-

-        With ThisWorkbook.Application

-            .ScreenUpdating = False

-            .WindowState = xlNormal

-            .Height = MaxY

-            .Width = MaxX

-        End With

-End Sub

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mReadWrite
->>>>>>
-Attribute VB_Name = "mReadWrite"

-Option Explicit

-

-Public Const GOOD_LINE_STATUS As String = "Ok"

-Public Const BAD_LINE_STATUS As String = "N/A"

-

-Function ReadPricesData(Location As Range, Hist As Integer, dt As Integer, _

-              pPriceData As TPriceData) As Integer

-    'Инициализация типа TPriceData из таблицы типа - 1

-    'kопируются не более чем hist последних строк

-    'aPoint - начало таблицы

-    'первые две строки таблицы идентифицирует данные (строки)

-    Dim n, i As Integer

-    

-    'Определение числа строк таблицы - n

-    n = GetLinesCount(Location)

-    ReadPricesData = n

-    If n < 9 Then             'обработать ошибку !!!

-        GoTo done

-    End If

-    ' число строк определено ()

-    If Hist > (n - 3) \ dt + 1 Then ' коррекция истории

-        Hist = (n - 3) \ dt + 1 '

-    End If

-    Dim t, s As Integer

-    For t = 0 To Hist - 1

-        s = n - t * dt - 1

-        pPriceData.D(Hist - t) = Location.Offset(s, DATE_IDX).Value

-        pPriceData.Tm(Hist - t) = Location.Offset(s, TIME_IDX).Value

-        pPriceData.Opn(Hist - t) = Location.Offset(s, OPEN_IDX).Value

-        pPriceData.Hgh(Hist - t) = Location.Offset(s, HIGH_IDX).Value

-        pPriceData.Lw(Hist - t) = Location.Offset(s, LOW_IDX).Value

-        pPriceData.Cls(Hist - t) = Location.Offset(s, CLOSE_IDX).Value

-        pPriceData.Vl(Hist - t) = Location.Offset(s, VOLUME_IDX).Value

-    Next t

-    ReadPricesData = t + 1

-done:

-End Function

-

-Sub ResultLinesOut(Location As Range, pPD As TPriceData, pDen As TDenmark)

-    Dim n As Integer

-    

-    n = GetLinesCount(Location)

-    With Location

-        .Offset(-1, RESIST_IDX) = "Resistance"

-        .Offset(-1, SUPPORT_IDX) = "Support"

-        .Offset(-1, PROJECT_IDX) = "Project"

-    End With

-    Dim t, count, Idx, loc_idx As Integer

-    count = pPD.tC

-    For t = 0 To count - 1

-        Idx = count - t

-        loc_idx = n - t - 1

-        If pDen.ResistanceLine(Idx) > MIN_PRICE_VALUE Then

-            Location.Offset(loc_idx, RESIST_IDX).Value = pDen.ResistanceLine(Idx)

-        End If

-        If pDen.SupportLine(Idx) > MIN_PRICE_VALUE Then

-            Location.Offset(loc_idx, SUPPORT_IDX).Value = pDen.SupportLine(Idx)

-        End If

-        If Abs(pDen.SignalValue) > 1 Then

-            Location.Offset(loc_idx, PROJECT_IDX).Value = pDen.ProjectPrice

-        End If

-    Next t

-End Sub

-

-Sub Out_Table_1(TheRange As Range, pDen As TDenmark, LastIdx As Integer)

-    

-    

-    ' Col = 2 - не определен !!!

-    ' Status - Col = 0

-    If pDen.ResistancePointCount >= 2 Then

-        TheRange.Offset(0, 0).Value = GOOD_LINE_STATUS

-    Else

-        TheRange.Offset(0, 0).Value = BAD_LINE_STATUS

-    End If

-    If pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(1, 0).Value = GOOD_LINE_STATUS

-    Else

-        TheRange.Offset(1, 0).Value = BAD_LINE_STATUS

-    End If

-    ' -----------------------------------------

-    ' углы наклонов линии сопротивления и поддержки - Col = 1

-    If pDen.ResistancePointCount >= 2 Then

-        TheRange.Offset(0, 1).Value = pDen.ResistanceAngle

-    End If

-    If pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(1, 1).Value = pDen.SupportAngle

-    End If

-    If pDen.ResistancePointCount >= 2 And pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(2, 1).Value = (pDen.ResistanceAngle + pDen.SupportAngle) / 2

-    End If

-    ' -----------------------------------------

-    ' Опорные цены линий денмарка на текущий момент

-    If pDen.ResistancePointCount >= 2 Then

-        TheRange.Offset(0, 2).Value = pDen.ResistanceLine(LastIdx)

-    End If

-    If pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(1, 2).Value = pDen.SupportLine(LastIdx)

-    End If

-    If pDen.ResistancePointCount >= 2 And pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(2, 2).Value = _

-            (pDen.ResistanceLine(LastIdx) + pDen.SupportLine(LastIdx)) / 2

-    End If

-    

-End Sub

-

-Sub Out_Table_2(TheRange As Range, TheComment As Range, pPD As TPriceData, pDen As TDenmark)

-    Const ColorIndexBUY = 5

-    Const ColorIndexSELL = 3

-    Const ColorIndexNOTHINK = 14

-    

-    Dim SignalValue_defined, allert_enable  As Boolean

-    Dim Message As String

-    SignalValue_defined = False

-    allert_enable = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_ALLERT_DLG")

-    Message = "Сигнал об изменении тренда не идентифицирован."

-    If pDen.SignalValue >= 2 Then

-        SignalValue_defined = True

-        With TheRange.Offset(0, 0)

-            .Value = "BUY"

-            .Font.Bold = True

-            .Font.ColorIndex = ColorIndexBUY

-        End With

-        TheRange.Offset(0, 1).Value2 = pPD.D(pPD.tC)

-        TheRange.Offset(0, 2).Value2 = pPD.Tm(pPD.tC)

-        TheRange.Offset(0, 3).Value = pDen.SignalValue - 1

-        TheRange.Offset(0, 4).Value = pDen.ProjectPrice

-        Message = "BUY Signal: возможен прорыв вверх нисходящего тренда с уровнем значимости = " & pDen.SignalValue - 1 & " ! "

-    End If

-    If pDen.SignalValue <= -2 Then

-        SignalValue_defined = True

-        With TheRange.Offset(0, 0)

-            .Value = "SELL"

-            .Font.Bold = True

-            .Font.ColorIndex = ColorIndexSELL

-        End With

-        TheRange.Offset(0, 1).Value2 = pPD.D(pPD.tC)

-        TheRange.Offset(0, 2).Value2 = pPD.Tm(pPD.tC)

-        TheRange.Offset(0, 3).Value = pDen.SignalValue + 1

-        TheRange.Offset(0, 4).Value = pDen.ProjectPrice

-        Message = "SELL Signal: возможен прорыв вниз восходящего тренда с уровнем значимости = " & -(pDen.SignalValue + 1) & "!"

-    End If

-    With TheComment

-        .Value = Message

-        .Font.Bold = True

-        Dim color_idx As Integer

-        If SignalValue_defined Then

-            If pDen.SignalValue > 0 Then

-                .Font.ColorIndex = ColorIndexBUY

-            Else

-                .Font.ColorIndex = ColorIndexSELL

-            End If

-        Else

-            .Font.ColorIndex = ColorIndexNOTHINK

-        End If

-    End With

-    If allert_enable And SignalValue_defined Then

-        MsgBox _

-            Prompt:=Message, _

-            Title:=PROGRAM_NAME, _

-            Buttons:=vbOKOnly + vbInformation

-    End If

-End Sub

-

-Sub Out_Table_3(TheRange As Range, pDen As TDenmark)

-    Dim i As Integer

-    For i = 1 To 3

-        TheRange.Offset(i - 1, 0).Value = pDen.Qualificator(i)

-    Next i

-End Sub

-

-Sub Out_Table_4(TheRange As Range, pPD As TPriceData)

-    Dim LastIdx As Integer

-    LastIdx = pPD.tC

-    With TheRange

-        .Offset(0, 0).Value2 = "'" & pPD.D(LastIdx)

-        .Offset(0, 1).Value2 = "'" & pPD.Tm(LastIdx)

-        .Offset(0, 2) = pPD.Opn(LastIdx)

-        .Offset(0, 3) = pPD.Hgh(LastIdx)

-        .Offset(0, 4) = pPD.Lw(LastIdx)

-        .Offset(0, 5) = pPD.Cls(LastIdx)

-        .Offset(0, 6) = pPD.Cls(LastIdx) - pPD.Cls(LastIdx - 1)

-    End With

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Denmark method bar"

-Public Const common_pwd As Long = 31415926

-

-

-Sub SetEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    With Application

-        .Caption = PROGRAM_NAME

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .GetState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(FORM_SHEET).Select

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                     cWindow.DisplayHeadings = True

-                Next

-            End If

-        Next

-        .Worksheets(FORM_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu (True)

-        End If

-        With mobjAppState

-            .RestoreState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        

-        With .Worksheets(RAW_DATA_SHEET)

-            .Visible = xlVeryHidden

-            .Protect Password:=common_pwd, userInterfaceOnly:=True, Contents:=False

-        End With

-        With .Worksheets(VAR_SHEET)

-            .Visible = xlVeryHidden

-            .Protect Password:=common_pwd, userInterfaceOnly:=True, Contents:=False

-        End With

-        With .Worksheets(FORM_SHEET)

-            .EnableSelection = xlNoSelection

-            .Protect userInterfaceOnly:=True

-            .Select

-        End With

-        With .Worksheets(CHART_SHEET)

-            .EnableSelection = xlNoSelection

-            .Protect userInterfaceOnly:=True

-        End With

-        .Protect Windows:=True

-        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-        .Application.ScreenUpdating = False

-        With .Worksheets(RAW_DATA_SHEET)

-            .Visible = xlVeryHidden

-            .Unprotect Password:=common_pwd

-        End With

-        With .Worksheets(VAR_SHEET)

-            .Visible = xlVeryHidden

-            .Unprotect Password:=common_pwd

-        End With

-        With .Worksheets(CHART_SHEET)

-            .Select

-            .Unprotect

-        End With

-        With .Worksheets(FORM_SHEET)

-            .Select

-            .Unprotect

-        End With

-        .Application.ScreenUpdating = True

-        

-    End With

-End Sub

-

-<<<<<<
-======================
-mTypes
->>>>>>
-Attribute VB_Name = "mTypes"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Метод г-на Демарка"

-Public Const PROGRAM_VERSION As String = "version 3.0 Professional"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-

-'Public Const ESTIMATION_DATE As Long = 19980915

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "J27"

-

-Public Const RAW_DATA_SHEET As String = "Raw_data"

-Public Const PRICE_TABLE As String = "B1"

-Public Const RAW_DATA_RANGE As String = "B3"

-Public Const RAW_DATA_RANGE_COL As Integer = 2

-Public Const RAW_DATA_RANGE_ROW As Integer = 3

-

-Public Const VAR_SHEET As String = "Var_s"

-

-Public Const CHART_SHEET As String = "Chart"

-

-Public Const MIN_PRICE_VALUE As Double = 0.000001

-Public Const MAX_PRICE_VALUE As Double = 1000000000

-

-' Fields indexes in RAW_DATA_RANGE

-Public Const DATE_IDX As Integer = 0

-Public Const TIME_IDX As Integer = 1

-Public Const OPEN_IDX As Integer = 2

-Public Const CLOSE_IDX As Integer = 3

-Public Const LOW_IDX As Integer = 4

-Public Const HIGH_IDX As Integer = 5

-Public Const VOLUME_IDX As Integer = 6

-Public Const RESIST_IDX As Integer = 7

-Public Const SUPPORT_IDX As Integer = 8

-Public Const PROJECT_IDX As Integer = 9

-

-Public Const DATE_STAMP_OFFSET = PROJECT_IDX + 1

-Public Const TIME_STAMP_OFFSET = PROJECT_IDX + 4

-Public Const DATE_TIME_STAMP_SIZE = 5

-

-Type TPriceData

-    D() As String      ' календарная дата

-    Tm() As String     ' время

-    Opn() As Double    ' Open

-    Hgh() As Double    ' High

-    Lw() As Double     ' Low

-    Cls() As Double    ' Close

-    Vl() As Double     ' Volume

-    tC As Integer      ' Current time

-End Type

-

-Type TDenmark

-   ResistanceLine() As Double           'Resistance line

-   ResistancePoints() As Integer        'Resistance pivot points

-   ResistancePointCount As Integer      'The number of resistance pivot points

-   ResistanceAngle As Double            'Angle of Declination of ResistanceLine

-   

-   SupportLine() As Double              'Support line

-   SupportPoints() As Integer           'Support pivot points

-   SupportPointsCount As Integer        'The number of support pivot points

-   SupportAngle As Double               ' Angle of Declination of SupportLine

-   

-   SignalParameter     As Integer       ' parameter for SignalValue

-   SignalValue      As Integer          'SignalValue

-   

-   

-   Qualificator(1 To 3) As String       ' qualificators

- 

-   ProjectNumber As Integer             ' номер проекции

-   ProjectPrice  As Double              ' проекция цены

-   

-End Type

-

-

-<<<<<<
-======================
-mCommands
->>>>>>
-Attribute VB_Name = "mCommands"

-Option Explicit

-Dim AppRunEnable As New cEnableRun

-

-Sub evParamChange()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DEMARK_READY") = False

-End Sub

-

-Sub cmViewChart(Optional SwapPage As Boolean = True)

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("BOOL_CHART_READY") = False

-        If .Range("BOOL_DEMARK_READY") <> True Then

-            If .Range("BOOL_AUTORECALC") = True Then

-                evSubmit_Click

-                If .Range("BOOL_DEMARK_READY") <> True Then

-                    Exit Sub

-                End If

-            Else

-                MsgBox _

-                    "График не может быть построен." & vbCrLf & "Исходные данные не обработаны.", _

-                    vbOKOnly + vbExclamation, _

-                    PROGRAM_NAME

-                Exit Sub

-            End If

-        End If

-    End With

-    With ThisWorkbook.Worksheets(FORM_SHEET)

-        With .Range("TABLE_1")

-            Dim test_lines As Boolean

-            test_lines = StrComp(.Cells(1, 1).Value, GOOD_LINE_STATUS)

-            test_lines = test_lines + StrComp(.Cells(2, 1).Value, GOOD_LINE_STATUS)

-            If test_lines <> 0 Then

-                MsgBox _

-                    Prompt:="График не может быть построен." & vbCrLf & "Опорные точки не определены .", _

-                    Title:=PROGRAM_NAME, _

-                    Buttons:=vbOKOnly + vbExclamation

-                Exit Sub

-            End If

-        End With

-        Draw_Chart Not IsEmpty(.Range("TABLE_2").Cells(1, 1))

-    End With

-    With ThisWorkbook

-        .Worksheets(VAR_SHEET).Range("BOOL_CHART_READY") = True

-        If SwapPage Then

-            .Worksheets(CHART_SHEET).Select

-        End If

-    End With

-End Sub

-

-Sub cmViewForm()

-    With ThisWorkbook

-        .Worksheets(FORM_SHEET).Select

-    End With

-End Sub

-

-Sub cmCloseProgram()

-    Dim ResistanceLine

-    ResistanceLine = MsgBox( _

-        Prompt:="Вы желаете завершить программу?", _

-        Buttons:=vbQuestion + vbYesNo, _

-        Title:=PROGRAM_NAME _

-    )

-    If ResistanceLine = vbYes Then

-       Application.Quit

-    End If

-End Sub

-

-Sub cmAbout()

-    dlgAbout.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlgAbout.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlgAbout.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlgAbout.Show

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-        helppath = "hh.exe " & .Path & "\Demark.chm"

-        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub cmSetStandaloneMode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetEnvironment Wb:=ThisWorkbook

-    ProtectionEnable Wb:=ThisWorkbook

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    rp = common_pwd

-    dlgGetPwd.edPwd = ""

-    dlgGetPwd.Show

-    If dlgGetPwd.edPwd = rp Then

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmPrint()

-    If MsgBox( _

-            Prompt:="Вы желаете распечатать результат?", _

-            Buttons:=vbYesNo + vbQuestion, _

-            Title:=PROGRAM_NAME) = vbNo _

-    Then

-        Exit Sub

-    End If

-    Dim s_ticker, s_name, s_time As String

-    s_ticker = ThisWorkbook.Worksheets(FORM_SHEET).Range("CALC_TICKER_NAME")

-    s_name = ThisWorkbook.Worksheets(FORM_SHEET).Range("CALC_NAME")

-    s_time = Now

-    Application.ScreenUpdating = False

-    cmViewChart SwapPage:=False

-    Application.ScreenUpdating = False

-    With ThisWorkbook.Worksheets(FORM_SHEET).PageSetup

-        .LeftHeader = s_ticker

-        .CenterHeader = PROGRAM_NAME

-        .RightHeader = s_time

-        .LeftFooter = s_name

-        .CenterFooter = "Page &P of &N"

-        .RightFooter = ""

-        .LeftMargin = Application.InchesToPoints(0.75)

-        .RightMargin = Application.InchesToPoints(0.75)

-        .TopMargin = Application.InchesToPoints(0.78)

-        .BottomMargin = Application.InchesToPoints(0.92)

-        .HeaderMargin = Application.InchesToPoints(0.5)

-        .FooterMargin = Application.InchesToPoints(0.5)

-        .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 = 2

-    End With

-    With ThisWorkbook.Worksheets(CHART_SHEET).PageSetup

-        .LeftHeader = s_ticker

-        .CenterHeader = PROGRAM_NAME

-        .RightHeader = s_time

-        .LeftFooter = s_name

-        .CenterFooter = "Page &P of &N"

-        .RightFooter = ""

-        .LeftMargin = Application.InchesToPoints(0.75)

-        .RightMargin = Application.InchesToPoints(0.75)

-        .TopMargin = Application.InchesToPoints(0.78)

-        .BottomMargin = Application.InchesToPoints(0.92)

-        .HeaderMargin = Application.InchesToPoints(0.5)

-        .FooterMargin = Application.InchesToPoints(0.5)

-        .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 = 2

-    End With

-    Application.ScreenUpdating = False

-    ThisWorkbook.Worksheets(Array("MainForm", "Chart")).PrintOut Copies:=1, Collate:=True

-    cmViewForm

-End Sub

-<<<<<<
-======================
-mDemark
->>>>>>
-Attribute VB_Name = "mDemark"

-Option Explicit

-

-Public Const FORM_SHEET As String = "MainForm"

-

-'Form Ranges

-Public Const FILE_NAME As String = "FILE_NAME"

-Public Const TABLE_1 As String = "TABLE_1"

-Public Const TABLE_2 As String = "TABLE_2"

-Public Const TABLE_3 As String = "TABLE_3"

-Public Const TABLE_4 As String = "TABLE_4"

-Public Const TABLE_COMMENT As String = "TABLE_COMMENT"

-

-'Основной тип данных - стандарт 1

-

-'*********************

-Dim PriceDataArray As TPriceData

-Dim DenmarkDataArray As TDenmark

-

-Dim mobjAppRunEnable As New cEnableRun

-

-Sub ClearResultTables()

-    With ThisWorkbook.Worksheets(FORM_SHEET)

-        .Range(TABLE_1).ClearContents ' таблица-1

-        .Range(TABLE_2).ClearContents ' таблица-2

-        .Range(TABLE_3).ClearContents ' таблица-3

-        .Range(TABLE_COMMENT).Value = "" ' коментарий-3

-        .Range(TABLE_4).ClearContents ' таблица-4

-    End With

-End Sub

-

-Function TDenmark_Calc() As Boolean

-    

-    Dim nWindow As Integer

-    Dim bPrevCloseFilter, bSuccCloseFilter As Boolean

-    

-    TDenmark_Calc = False

-    

-    mobjAppRunEnable.EnableRun ESTIMATION_DATE, Now

-    

-    With ThisWorkbook

-        .Application.ScreenUpdating = False

-'1)    Read User data

-        With .Worksheets(VAR_SHEET)

-            DenmarkDataArray.ProjectNumber = .Range("DEN_PROECT").Value

-            DenmarkDataArray.SignalParameter = .Range("DEN_PARAM").Value

-            nWindow = .Range("DEN_WINDOW").Value

-            bPrevCloseFilter = .Range("BOOL_PREV_CLOSE").Value

-            bSuccCloseFilter = .Range("BOOL_SUCC_CLOSE").Value

-        End With

-

-'2)   Memory allocation

-        allocate_memory PriceDataArray, DenmarkDataArray, nWindow

-

-'3)   Read data

-        Dim TheRange As Range

-        Set TheRange = .Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE)

-        Dim LinesCount As Integer

-        LinesCount = ReadPricesData(Location:=TheRange, Hist:=PriceDataArray.tC, dt:=1, pPriceData:=PriceDataArray)

-        

-        'Init function result

-        TDenmark_Calc = LinesCount >= nWindow

-        

-        If LinesCount >= nWindow Then

-        

-'4)   Calculate metod TDenmarkDataArray

-            DetDenmark PriceDataArray, DenmarkDataArray, bPrevCloseFilter, bSuccCloseFilter

-            If Abs(DenmarkDataArray.SignalValue) > 1 Then  'ценовые ориентиры, если есть сигнал

-                DetProj PriceDataArray, DenmarkDataArray

-            End If

-'5)   Write result

-            Application.ScreenUpdating = False

-    

-'6)    Clear interface tables

-            ClearResultTables

-            

-            ResultLinesOut Location:=TheRange.Offset(2, 0), pPD:=PriceDataArray, pDen:=DenmarkDataArray

-            

-            With .Worksheets(FORM_SHEET)

-                Out_Table_1 TheRange:=.Range(TABLE_1).Cells(1, 1), pDen:=DenmarkDataArray, LastIdx:=PriceDataArray.tC

-                Out_Table_2 _

-                        TheRange:=.Range(TABLE_2).Cells(1, 1), _

-                        TheComment:=.Range("TABLE_COMMENT"), _

-                        pPD:=PriceDataArray, _

-                        pDen:=DenmarkDataArray

-                Out_Table_3 TheRange:=.Range(TABLE_3).Cells(1, 1), pDen:=DenmarkDataArray

-                Out_Table_4 TheRange:=.Range(TABLE_4).Cells(1, 1), pPD:=PriceDataArray

-                With .Range(TABLE_1)

-                    .Font.name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-                With .Range(TABLE_2)

-                    .Font.name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-                With .Range(TABLE_3)

-                    .Font.name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-                With .Range(TABLE_4)

-                    .Font.name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-            End With

-            .Worksheets(VAR_SHEET).Range("BOOL_DEMARK_READY") = True

-        Else

-            MsgBox _

-                Prompt:="Недостаточна глубина выборки данных." _

-                    & vbCrLf & "Измените параметры запроса и пробуйте снова.", _

-                Buttons:=vbOKOnly + vbExclamation, _

-                Title:=PROGRAM_NAME

-            .Worksheets(VAR_SHEET).Range("BOOL_DEMARK_READY") = False

-            .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False

-        End If

-'7)   Free unused memory

-        free_unused_memory PriceDataArray, DenmarkDataArray

-    End With

-End Function

-

-Sub allocate_memory(pPriceData As TPriceData, pDenmarkData As TDenmark, memsize As Integer)

-'  Память под TDenmark

-    ReDim pDenmarkData.ResistanceLine(1 To memsize)

-    ReDim pDenmarkData.ResistancePoints(1 To memsize)

-    ReDim pDenmarkData.SupportLine(1 To memsize)

-    ReDim pDenmarkData.SupportPoints(1 To memsize)

-   

-' Инициализация данных по ценам

-    pPriceData.tC = memsize

-    ReDim pPriceData.D(1 To memsize)

-    ReDim pPriceData.Tm(1 To memsize)

-    ReDim pPriceData.Opn(1 To memsize)

-    ReDim pPriceData.Hgh(1 To memsize)

-    ReDim pPriceData.Lw(1 To memsize)

-    ReDim pPriceData.Cls(1 To memsize)

-    ReDim pPriceData.Vl(1 To memsize)

-

-End Sub

-

-Sub free_unused_memory(pP As TPriceData, pD As TDenmark)

-'   Free Prices

-    pP.tC = 0

-    Erase pP.D

-    Erase pP.Tm

-    Erase pP.Opn

-    Erase pP.Hgh

-    Erase pP.Lw

-    Erase pP.Cls

-    Erase pP.Vl

-    

-'Free TDenmark

-    Erase pD.ResistanceLine

-    Erase pD.ResistancePoints

-    Erase pD.SupportLine

-    Erase pD.SupportPoints

-End Sub

-

-

-'*****************************************

-Sub DetDenmark(pPriceData As TPriceData, pDenmarkData As TDenmark, ByVal ClosePrev2 As Boolean, ByVal CloseSucc1 As Boolean)

-' определение элементов данных Денмарка (в цифровой форме)

-' на текущий момент времени времени tC

-' ИСХОДНЫЕ ДАННЫЕ:

-' pPriceData  - окно, стандартная форма данных по ценам (определена)

-' ClosePrev2 - H(t) > max{ H(t-1), H(t+1)} и  H(t) > Close(t-2)

-' CloseSucc1 - H(t) > max{ H(t-1), H(t+1)}  и  R(t+1) > Close(t+1)

-' РЕЗУЛЬТАТ:

-' pDenmarkData - элементы данных Денмарка (память выделена, SignalParameter - определен):

-' линии ResistanceLine,SupportLine их наклоны, опорные точки, сигналы к покупке или продаже

-' SignalValue = 0 сигнал отсутствует

-' SignalValue < 0 прорыв восходящего тренда (сигнал продажи)

-' SignalValue > 0 прорыв нисходящего тренда (сигнал покупки)

-' Если pDenmarkData.ResistancePointCount < 2, то элементы ResistanceLine не определяются

-' Если pDenmarkData.SupportPointsCount < 2, то элементы SupportLine не определяются

-

-' начальная установка

-    Const QUALIFICATOR_DISABLE As String = "-"

-    Const QUALIFICATOR_ENABLE As String = "Signal"

-    

-    Dim UpQual(1 To 3) As String

-    Dim DownQual(1 To 3) As String

-    Dim UpSignal, DownSignal As Integer

-    Dim i As Integer

-    

-    pDenmarkData.SignalValue = 0

-    UpSignal = 0

-    DownSignal = 0

-    

-    For i = 1 To 3

-        pDenmarkData.Qualificator(i) = QUALIFICATOR_DISABLE

-        UpQual(i) = QUALIFICATOR_DISABLE

-        DownQual(i) = QUALIFICATOR_DISABLE

-    Next i

-    

-' определение линии поддержки и сопротивления

-    ResLine _

-        pPriceData, _

-        pPriceData.tC, _

-        pDenmarkData.ResistancePointCount, _

-        pDenmarkData.ResistanceLine, _

-        pDenmarkData.ResistancePoints, _

-        ClosePrev2, _

-        CloseSucc1

-        

-    SuppLine _

-        pPriceData, _

-        pPriceData.tC, _

-        pDenmarkData.SupportPointsCount, _

-        pDenmarkData.SupportLine, _

-        pDenmarkData.SupportPoints, _

-        ClosePrev2, _

-        CloseSucc1

-

-        

-        

-    If pDenmarkData.ResistancePointCount >= 2 Then

-        pDenmarkData.ResistanceAngle = 57.29578 * _

-            Atn(pDenmarkData.ResistanceLine(pPriceData.tC) - _

-                pDenmarkData.ResistanceLine(pPriceData.tC - 1))

-    End If

-    If pDenmarkData.SupportPointsCount >= 2 Then

-        pDenmarkData.SupportAngle = 57.29578 * _

-            Atn(pDenmarkData.SupportLine(pPriceData.tC) - _

-                pDenmarkData.SupportLine(pPriceData.tC - 1))

-    End If

-

-' ФОРМИРОВАНИЕ СИГНАЛА ----------------------------------

-    Dim t As Integer

-' 1. случай нисходящего тренда: ResistanceLine определен и ResistanceLine падает *************

-    If pDenmarkData.ResistancePointCount >= 2 And pDenmarkData.ResistanceAngle < 0 Then

-'    необходимое условие прорыва вверх

-        If pDenmarkData.ResistanceLine(pPriceData.tC) < pPriceData.Cls(pPriceData.tC) Then

-            UpSignal = 1

-            For t = pPriceData.tC - pDenmarkData.SignalParameter To pPriceData.tC - 1

-                If pPriceData.Cls(t) > pDenmarkData.ResistanceLine(t) Then

-                    UpSignal = 0

-                    Exit For

-                End If

-            Next t

-        End If

-        If UpSignal = 1 Then

-'       Qualificator-1: close убывает накануне прорыва

-            If pPriceData.Cls(pPriceData.tC - 2) > pPriceData.Cls(pPriceData.tC - 1) Then

-                UpSignal = UpSignal + 1

-                UpQual(1) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-2: open > ResistanceLine в момент прорыва

-            If pPriceData.Opn(pPriceData.tC) > pDenmarkData.ResistanceLine(pPriceData.tC) Then

-                UpSignal = UpSignal + 1

-                UpQual(2) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-3 - demand value < ResistanceLine(tC)

-            If 2 * pPriceData.Cls(pPriceData.tC - 1) - pPriceData.Lw(pPriceData.tC - 1) < pDenmarkData.ResistanceLine(pPriceData.tC) Then

-                UpSignal = UpSignal + 1

-                UpQual(3) = QUALIFICATOR_ENABLE

-            End If

-        End If

-    End If  ' нисходящий тренд обработан ************************************

-

-' 2. случай восходящего тренда: SupportLine определен и SupportLine растет

-    If pDenmarkData.SupportPointsCount >= 2 And pDenmarkData.SupportAngle > 0 Then

-'    ---------------------------------------------

-'    необходимое условие прорыва вниз

-        If pPriceData.Cls(pPriceData.tC) < pDenmarkData.SupportLine(pPriceData.tC) Then

-            DownSignal = -1

-            For t = pPriceData.tC - pDenmarkData.SignalParameter To pPriceData.tC - 1

-                If pPriceData.Cls(t) < pDenmarkData.SupportLine(t) Then

-                    DownSignal = 0

-                    Exit For

-                End If

-            Next t

-        End If

-        If DownSignal = -1 Then

-'       Qualificator-1: Close растет накануне прорыва

-            If pPriceData.Cls(pPriceData.tC - 2) < pPriceData.Cls(pPriceData.tC - 1) Then

-                DownSignal = DownSignal - 1

-                DownQual(1) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-2: Open ниже ResistanceLine в момент прорыва

-            If pPriceData.Opn(pPriceData.tC) < pDenmarkData.SupportLine(pPriceData.tC) Then

-                DownSignal = DownSignal - 1

-                DownQual(2) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-3 - supply value(t-1) > SupportLine(tC)

-            If 2 * pPriceData.Cls(pPriceData.tC - 1) - pPriceData.Hgh(pPriceData.tC - 1) > pDenmarkData.SupportLine(pPriceData.tC) Then

-                DownSignal = DownSignal - 1

-                DownQual(3) = QUALIFICATOR_ENABLE

-            End If

-        End If

-'    ---------------------------------------------

-    End If

-'      Существует преобладание тенденции

-    If Abs(DownSignal) <> UpSignal Then

-        If Abs(DownSignal) > UpSignal Then

-            pDenmarkData.SignalValue = DownSignal

-            For i = 1 To 3

-                pDenmarkData.Qualificator(i) = DownQual(i)

-            Next i

-        Else

-            pDenmarkData.SignalValue = UpSignal

-            For i = 1 To 3

-                pDenmarkData.Qualificator(i) = UpQual(i)

-            Next i

-        End If

-    End If

-End Sub

-

-Sub DetProj(pPriceData As TPriceData, pDenmarkData As TDenmark)

-'Определение проекции при наличии сигнала: |Signal| > 1

-'Услловие применимости |Signal| > 1 !!!

-    Dim pM As Double, t As Integer, Tm As Integer, tL As Integer

-

-    If pDenmarkData.SignalValue >= 2 Then  ' СИГНАЛ ПОКУПКИ

-

-        tL = pDenmarkData.ResistancePoints(pDenmarkData.ResistancePointCount)     ' tR determination

-        If tL = pPriceData.tC Then

-            tL = pDenmarkData.ResistancePoints(pDenmarkData.ResistancePointCount - 1)

-        End If

-

-'  Projections 1,2 --------------------------------------------

-        If pDenmarkData.ProjectNumber >= 1 And pDenmarkData.ProjectNumber <= 2 Then

-'           t* = Arg min {L(t) : t R <= t  <= tb ,  L(t) < ResistanceLine(t)},

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Lw(Tm) ' L(t-1) < ResistanceLine(t-1) for t - break point !

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Lw(t) < pM And pPriceData.Lw(t) < pDenmarkData.ResistanceLine(t) Then

-                    pM = pPriceData.Lw(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            If pDenmarkData.ProjectNumber = 1 Then

-'               P1( tb) = ResistanceLine(tb) + ResistanceLine(t*) - L(t*)

-                pDenmarkData.ProjectPrice = pDenmarkData.ResistanceLine(pPriceData.tC) + pDenmarkData.ResistanceLine(Tm) - pPriceData.Lw(Tm)

-            Else

-                pDenmarkData.ProjectPrice = pDenmarkData.ResistanceLine(pPriceData.tC) + pDenmarkData.ResistanceLine(Tm) - pPriceData.Cls(Tm)

-            End If

-        End If ' pDenmarkData.ProjectNumber >= 1 And pDenmarkData.ProjectNumber <= 2

-   

-'  ----------------------------------------------------------------

-'  Projections 3

-        If pDenmarkData.ProjectNumber = 3 Then

-'           t*  = Arg min { С(t) : t R <= t  <= tb ,  C(t) < ResistanceLine(t)}

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Cls(Tm)

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Cls(t) < pM And pPriceData.Cls(t) < pDenmarkData.ResistanceLine(t) Then

-                    pM = pPriceData.Cls(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            pDenmarkData.ProjectPrice = pDenmarkData.ResistanceLine(pPriceData.tC) + pDenmarkData.ResistanceLine(Tm) - pPriceData.Cls(Tm)

-        End If

-    End If ' pDenmarkData.SignalValue >= 2

-

-'-------------------------------------------------------------------

-'*******************************************************************

-' ПРОЕКЦИЯ ДЛЯ СИГНАЛА ПРОДАЖИ

-    If pDenmarkData.SignalValue <= -2 Then

-        tL = pDenmarkData.SupportPoints(pDenmarkData.SupportPointsCount)  ' tR determination

-        If tL = pPriceData.tC Then

-            tL = pDenmarkData.ResistancePoints(pDenmarkData.SupportPointsCount - 1)

-        End If

-

-'  Projections 1,2 --------------------------------------------

-        If pDenmarkData.ProjectNumber = 1 Or pDenmarkData.ProjectNumber = 2 Then

-'           t* = Arg max {H(t) : t R <= t  <= tb ,  H(t) > SupportLine(t)},

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Hgh(Tm) ' H(t-1) > SupportLine(t-1) for t - break point !

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Hgh(t) > pM And pPriceData.Hgh(t) > pDenmarkData.SupportLine(t) Then

-                    pM = pPriceData.Hgh(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            If pDenmarkData.ProjectNumber = 1 Then

- '              P1( tb) = SupportLine(tb) + SupportLine(t*) - H(t*)

-                pDenmarkData.ProjectPrice = pDenmarkData.SupportLine(pPriceData.tC) + pDenmarkData.SupportLine(Tm) - pPriceData.Hgh(Tm)

-            Else

-'               P2( tb) = SupportLine(tb) + SupportLine(t*) - C(t*)

-                pDenmarkData.ProjectPrice = pDenmarkData.SupportLine(pPriceData.tC) + pDenmarkData.SupportLine(Tm) - pPriceData.Cls(Tm)

-            End If

-        End If

-   

-'  ----------------------------------------------------------------

-'  Projections 3

-        If pDenmarkData.ProjectNumber = 3 Then

-'           t*  = Arg max { С(t) : t R <= t  <= tb ,  C(t) >  SupportLine(t)}

-'           P3( tb) = SupportLine(tb) + SupportLine(t*) - C(t*)

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Cls(Tm)

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pM < pPriceData.Cls(t) And pPriceData.Cls(t) > pDenmarkData.SupportLine(t) Then

-                    pM = pPriceData.Cls(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            pDenmarkData.ProjectPrice = pDenmarkData.SupportLine(pPriceData.tC) + pDenmarkData.SupportLine(Tm) - pPriceData.Cls(Tm)

-        End If

-    End If ' pDenmarkData.SignalValue <= -2

-End Sub

-

-Sub ResLine(pP As TPriceData, tE As Integer, ResistancePointCount As Integer, _

-            ResistanceLine() As Double, s() As Integer, ClosePrev2 As Boolean, CloseSucc1 As Boolean)

-' Определение линии сопротивления по Демарку [1]

-' Основной вариант

-' ИСХОДНЫЕ ДАННЫЕ:

-' High, dom(High) = [1, tE]

-' ClosePrev2 - H(t) > max{ H(t-1), H(t+1)} и  H(t) > Close(t-2)

-' CloseSucc1 - H(t) > max{ H(t-1), H(t+1)}  и  R(t+1) > Close(t+1)

-' РЕЗУЛЬТАТ:

-' 1) линия сопротивления ResistanceLine, dom(ResistanceLine)=[s(1), tE], и

-' 2) s = {s(1), s(2), ..., s(ResistancePointCount)}, s(1) < s(2) < ...< s(ResistancePointCount)

-'   ( s(ResistancePointCount)<= tE )- опорные точки

-' 3) число опорных точек ResistancePointCount.

-' 4) s(1) -  первый момент времени с которого определена SupportLine

-'    то есть dom{Supp} = [s(1), tC]

-' Прим. Если число опорных точек окажется < 2, то линия

-' сопротивления не определяется. В этом случае следует

-' увеличить историю tE !!!

-    Dim t As Integer, i As Integer

-    Dim v As Double

-    Dim IsGoodPoint As Boolean

-  

-'1 определение опорных моментов времени

-    ResistancePointCount = 0

-    For t = 3 To tE - 1

- '      v = max{high(t-1), high(t+1)} < high(t)}

-        v = pP.Hgh(t - 1)

-        If v < pP.Hgh(t + 1) Then

-            v = pP.Hgh(t + 1)

-        End If

-        IsGoodPoint = pP.Hgh(t) > v

-        If IsGoodPoint And ClosePrev2 Then

-            IsGoodPoint = IsGoodPoint And (pP.Cls(t - 2) < pP.Hgh(t))

-        End If

-        

-        If IsGoodPoint Then       'alt.: v >= High(t + 1)

-            s(ResistancePointCount + 1) = t: ResistancePointCount = ResistancePointCount + 1

-        End If

-    Next t

-    

-loop_:

-    

-    If ResistancePointCount < 2 Then

-        GoTo done

-    End If

-

-' 2 определение линии сопротивления

-    ResistanceLine(s(1)) = pP.Hgh(s(1))

-    For i = 2 To ResistancePointCount

-        ResistanceLine(s(i)) = pP.Hgh(s(i))

-        v = (pP.Hgh(s(i)) - pP.Hgh(s(i - 1))) / (s(i) - s(i - 1))

-        For t = s(i - 1) + 1 To s(i) - 1

-            ResistanceLine(t) = pP.Hgh(s(i - 1)) + v * (t - s(i - 1))

-        Next t

-    Next i

-    If s(ResistancePointCount) < tE Then

-        v = (pP.Hgh(s(ResistancePointCount)) - pP.Hgh(s(ResistancePointCount - 1))) / (s(ResistancePointCount) - s(ResistancePointCount - 1))

-        For t = s(ResistancePointCount) + 1 To tE

-            ResistanceLine(t) = pP.Hgh(s(ResistancePointCount - 1)) + v * (t - s(ResistancePointCount - 1))

-        Next t

-    End If

-    If CloseSucc1 Then

-        For t = 1 To ResistancePointCount

-            If ResistanceLine(s(t) + 1) < pP.Cls(s(t) + 1) Then

-                ResistancePointCount = ResistancePointCount - 1

-                ' удалить точку

-                For i = t To ResistancePointCount

-                    s(i) = s(i + 1)

-                Next i

-                s(ResistancePointCount + 1) = 0

-                ' очистить массив линии

-                Dim Lb, Rb As Integer

-                Lb = LBound(ResistanceLine)

-                Rb = UBound(ResistanceLine)

-                Erase ResistanceLine

-                ReDim ResistanceLine(Lb To Rb)

-                GoTo loop_

-            End If

-        Next t

-    End If

-    

-done:

-End Sub

-

-Sub SuppLine(pP As TPriceData, tE As Integer, SupportPointsCount As Integer, _

-               SupportLine() As Double, s() As Integer, ClosePrev2 As Boolean, CloseSucc1 As Boolean)

-' Определение линии поддержки по Демарку [1] (от конца)

-' Исходные данные:

-' Low, dom(Low) = [1, tE]

-' ClosePrev2 - H(t) > max{ H(t-1), H(t+1)} и  H(t) > Close(t-2)

-' CloseSucc1 - H(t) > max{ H(t-1), H(t+1)}  и  R(t+1) > Close(t+1)

-' Результат:

-' 1) линия сопротивления SupportLine, dom(SupportLine)=[s(1), tE],

-' 2) s = {s(1), s(2), ..., s(SupportPointsCount)}, s(1) < s(2) < ...< s(SupportPointsCount) -

-'    опорные точки

-' 3) число опорных точек SupportPointsCount.

-' Прим. Если фактическое число опорных точек окажется < 2, то линия

-' поддержки не определяется.

-    Dim t As Integer, i As Integer

-    Dim v As Double

-    Dim IsGoodPoint As Boolean

-    

-'1 определение опорных моментов времени

-     SupportPointsCount = 0

-    For t = 3 To tE - 1

-'       v = min{Low(t-1), Low(t+1)} > Low(t)

-        v = pP.Lw(t - 1)

-        If v > pP.Lw(t + 1) Then

-            v = pP.Lw(t + 1)

-        End If

-        

-        IsGoodPoint = pP.Lw(t) < v

-        

-        If IsGoodPoint And ClosePrev2 Then

-            IsGoodPoint = IsGoodPoint And (pP.Cls(t - 2) > pP.Lw(t))

-        End If

-        

-        If IsGoodPoint Then     'alt.: v >= High(t + 1)

-            s(SupportPointsCount + 1) = t: SupportPointsCount = SupportPointsCount + 1

-        End If

-    Next t

-

-loop_:

-    If SupportPointsCount < 2 Then

-        GoTo done

-    End If

-' 2 определение линии поддержки

-    

-    SupportLine(s(1)) = pP.Lw(s(1))

-    For i = 2 To SupportPointsCount

-        SupportLine(s(i)) = pP.Lw(s(i))

-        v = (pP.Lw(s(i)) - pP.Lw(s(i - 1))) / (s(i) - s(i - 1))

-        For t = s(i - 1) + 1 To s(i) - 1

-            SupportLine(t) = pP.Lw(s(i - 1)) + v * (t - s(i - 1))

-        Next t

-    Next i

-    If s(1) < tE Then

-        v = (pP.Lw(s(SupportPointsCount)) - pP.Lw(s(SupportPointsCount - 1))) / (s(SupportPointsCount) - s(SupportPointsCount - 1))

-        For t = s(SupportPointsCount) + 1 To tE

-            SupportLine(t) = pP.Lw(s(SupportPointsCount - 1)) + v * (t - s(SupportPointsCount - 1))

-        Next t

-    End If

-    If CloseSucc1 Then

-        For t = 1 To SupportPointsCount

-            If SupportLine(s(t) + 1) > pP.Cls(s(t) + 1) Then

-                SupportPointsCount = SupportPointsCount - 1

-                ' удалить точку

-                For i = t To SupportPointsCount

-                    s(i) = s(i + 1)

-                Next i

-                s(SupportPointsCount + 1) = 0

-                ' очистить массив линии

-                Dim Lb, Rb As Integer

-                Lb = LBound(SupportLine)

-                Rb = UBound(SupportLine)

-                Erase SupportLine

-                ReDim SupportLine(Lb To Rb)

-                GoTo loop_

-            End If

-        Next t

-    End If

-done:

-End Sub

-

-<<<<<<
-======================
-mChart
->>>>>>
-Attribute VB_Name = "mChart"

-Option Explicit

-

-Const CHART_NAME As String = "PriceChart"

-

-Sub Draw_Chart(SignalDefined As Boolean)

-

-    Dim n As Integer

-    Dim theChart As Chart

-    Dim ChartDataAria, szLastNumber As String

-    Dim MinYScale As Double

-    

-    

-    With ThisWorkbook

-' Checking data

-' Disable screen out

-        .Application.Cursor = xlWait

-        .Application.ScreenUpdating = False

-' Create series range

-        n = GetLinesCount(Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE))

-        szLastNumber = n + 1

-        If SignalDefined Then

-            ChartDataAria = "A2:A" + szLastNumber + ",D2:E" + szLastNumber + ",I2:K" + szLastNumber

-        Else

-            ChartDataAria = "A2:A" + szLastNumber + ",D2:E" + szLastNumber + ",I2:J" + szLastNumber

-        End If

-        MinYScale = GetMinValue(.Worksheets(RAW_DATA_SHEET).Range(ChartDataAria))

-' Find and delete old chart

-        .Worksheets(CHART_SHEET).Unprotect

-        Dim WindowWidth, WindowHeight As Integer

-        With .Worksheets(CHART_SHEET)

-            WindowWidth = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-            WindowHeight = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-        End With

-        

-        

-        With .Worksheets(CHART_SHEET).ChartObjects

-            .delete

-            With .Add(5, 5, WindowWidth - 10, WindowHeight - 10)

-                .SendToBack

-                Set theChart = .Chart

-            End With

-' Create a chart

-        End With

-        With theChart

-            .ChartType = xlLine

-            .SetSourceData Source:=Sheets(RAW_DATA_SHEET).Range( _

-                    ChartDataAria), PlotBy:=xlColumns

-            .Location Where:=xlLocationAsObject, name:=CHART_SHEET

-            .HasTitle = True

-            With .ChartTitle

-                .Text = ThisWorkbook.Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE).Value

-                With .Font

-                    .Size = 8

-                    .Bold = True

-                End With

-            End With

-            .HasLegend = True

-            With .Legend

-                .Position = xlTop

-                With .Font

-                    .name = "Arial"

-                    .Size = 8

-                End With

-            End With

-            .HasDataTable = False

-            With .Axes(xlCategory)

-                .HasMajorGridlines = True

-                .HasMinorGridlines = False

-                .TickLabels.Orientation = xlUpward

-                With .MajorGridlines.Border

-                    .ColorIndex = 48

-                    .Weight = xlHairline

-                    .LineStyle = xlDot

-                End With

-                .CrossesAt = 1

-                .TickLabelSpacing = 1

-                .TickMarkSpacing = 1

-                .AxisBetweenCategories = False

-                .ReversePlotOrder = False

-                .TickLabels.AutoScaleFont = True

-                With .TickLabels.Font

-                    .name = "Arial"

-                    .Size = 8

-                End With

-            End With

-            With .Axes(xlValue)

-                .HasMajorGridlines = True

-                .HasMinorGridlines = False

-                With .MajorGridlines.Border

-                    .ColorIndex = 48

-                    .Weight = xlHairline

-                    .LineStyle = xlDot

-                End With

-                .MinimumScale = MinYScale

-                .MaximumScaleIsAuto = True

-                .MinorUnitIsAuto = True

-                .MajorUnitIsAuto = True

-                .Crosses = xlCustom

-                .CrossesAt = MinYScale

-                .ReversePlotOrder = False

-                .ScaleType = xlLinear

-                .TickLabels.AutoScaleFont = True

-                With .TickLabels.Font

-                    .name = "Arial"

-                    .Size = 9

-                End With

-            End With

-            .ChartTitle.Top = 5

-            .ChartTitle.Left = 5

-            With .Legend

-                .Top = 5

-                .Fill.OneColorGradient _

-                    Style:=msoGradientHorizontal, _

-                    Variant:=3, _

-                    Degree:=0.303913939116503

-                .Fill.Visible = True

-                .Fill.ForeColor.SchemeColor = 71

-            End With

-            .PlotArea.Left = 10

-            .PlotArea.Top = .Legend.Top + .Legend.Height + 5

-            .PlotArea.Width = .ChartArea.Width - 20

-            .PlotArea.Height = .ChartArea.Height - .PlotArea.Top

-            

-' Tune OPEN line

-            With .SeriesCollection(1)

-                .Border.LineStyle = xlNone

-                .MarkerBackgroundColorIndex = xlNone

-                .MarkerForegroundColorIndex = 1

-                .MarkerStyle = xlPlus

-                .Smooth = False

-                .MarkerSize = 9

-                .Shadow = False

-            End With

-' Tune CLOSE line

-            With .SeriesCollection(2)

-                .Border.ColorIndex = 10

-                .Border.Weight = xlMedium

-                .Border.LineStyle = xlContinuous

-            End With

-' Tune RESISTANCE line

-            With .SeriesCollection(3)

-                .Border.ColorIndex = 3

-                .Border.Weight = xlThin

-                .Border.LineStyle = xlContinuous

-            End With

-' Tune SUUPORT line

-            With .SeriesCollection(4)

-                .Border.ColorIndex = 25

-                .Border.Weight = xlThin

-                .Border.LineStyle = xlContinuous

-            End With

-            If SignalDefined Then

-                With .SeriesCollection(5)

-                    .Border.ColorIndex = 6

-                    .Border.Weight = xlThin

-                    .Border.LineStyle = xlDot

-                End With

-            End If

-        End With

-        .Application.Cursor = xlDefault

-        With .Worksheets(CHART_SHEET)

-            .Range("A1").Select

-            .Protect userInterfaceOnly:=True

-        End With

-    End With

-End Sub

-

-Function GetMinValue(DataRange As Range) As Double

-    Dim Cell As Range

-    Dim MinValue, MaxValue, RangeValue, CorrectValue, Mult As Double

-    MinValue = MAX_PRICE_VALUE

-    MaxValue = MIN_PRICE_VALUE

-    For Each Cell In DataRange

-        If Not IsEmpty(Cell) And IsNumeric(Cell) Then

-            If Cell > MIN_PRICE_VALUE Then

-                If Cell < MinValue Then

-                    MinValue = Cell

-                End If

-                If Cell > MaxValue Then

-                    MaxValue = Cell

-                End If

-            End If

-        End If

-    Next

-    RangeValue = MaxValue - MinValue

-    If RangeValue < 0 Then

-        MinValue = 0

-    Else

-        CorrectValue = RangeValue / 4

-        Mult = MIN_PRICE_VALUE

-        While MinValue - Int(MinValue * Mult) / Mult > CorrectValue

-            Mult = Mult * 10

-        Wend

-        MinValue = Int(MinValue * Mult) / Mult

-    End If

-    GetMinValue = MinValue

-End Function

-

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub GetState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars("Worksheet Menu Bar").Visible = False

-End Sub

-

-

-Public Sub RestoreState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars("Worksheet Menu Bar").Visible = True

-End Sub

-

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{2E6ADAE7-CAA7-454E-97DF-760784AA27A5}{429C004E-8FA7-40D2-BE86-B83C0432EFE0}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub CommandButton1_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mWebQeury
->>>>>>
-Attribute VB_Name = "mWebQeury"

-Option Explicit

-

-Public Const Qry_DELETE_ALL As String = "Qry_DELETE_ALL"

-Public Const Qry_PATH_NO_CHANGE As String = "Qry_PATH_NO_CHANGE"

-

-

-Sub QryCreate(QryRange As Range, QryName As String, QryPath As String, Optional RefreshBkgnd = False)

-    Dim WebQuery As QueryTable

-    QryDelete QryRange:=QryRange, QryName:=QryName

-    

-    Set WebQuery = QryRange.Worksheet.QueryTables.Add( _

-            Connection:=QryPath, _

-            Destination:=QryRange)

-    

-    With WebQuery

-        .FieldNames = False

-        .name = QryName

-        .RefreshStyle = xlOverwriteCells

-        .RowNumbers = False

-        .FillAdjacentFormulas = False

-        .RefreshOnFileOpen = False

-        .HasAutoFormat = False

-        .BackgroundQuery = False

-        .TablesOnlyFromHTML = False

-        .Refresh BackgroundQuery:=RefreshBkgnd

-        .SavePassword = False

-        .SaveData = True

-    End With

-End Sub

-

-Function QryRefresh(QryRange As Range, QryName As String, Optional QryPath As String = Qry_PATH_NO_CHANGE, Optional Background As Boolean = False) As Boolean

-    Dim qry_result As Boolean

-    qry_result = False

-    If QryExist(QryRange, QryName) Then

-        With QryRange.Worksheet.QueryTables(QryName)

-            If QryPath <> Qry_PATH_NO_CHANGE Then

-                .Connection = QryPath

-            End If

-            .Refresh BackgroundQuery:=Background

-            qry_result = True

-        End With

-    End If

-    QryRefresh = qry_result

-End Function

-

-Sub QryDelete(QryRange As Range, Optional QryName As String = Qry_DELETE_ALL)

-    Dim WebQuery As QueryTable

-    For Each WebQuery In QryRange.Worksheet.QueryTables

-        If QryName = Qry_DELETE_ALL Or WebQuery.name = QryName Then

-            WebQuery.delete

-        End If

-    Next

-End Sub

-

-Function QryExist(QryRange As Range, QryName As String) As Boolean

-    Dim WebQuery As QueryTable

-    For Each WebQuery In QryRange.Worksheet.QueryTables

-        If WebQuery.name = QryName Then

-            QryExist = True

-            Exit For

-        End If

-    Next

-End Function

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Sub CreateCommandBar(theApp As Application)

-Attribute CreateCommandBar.VB_ProcData.VB_Invoke_Func = "R\n14"

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible + msoBarNoCustomize + msoBarNoMove + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Print"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 4

-                        .OnAction = "cmPrint"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Contents"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 49

-                        .OnAction = "cmHelpContents"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible + msoBarNoCustomize + msoBarNoMove + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(Flag As Boolean)

-    If Flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars("Worksheet Menu Bar")

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim curdate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    curdate = year * 10000

-    curdate = curdate + month * 100

-    curdate = curdate + day

-    If curdate > end_date Then

-        cmAbout

-        cmHelpContents

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mTool
->>>>>>
-Attribute VB_Name = "mTool"

-Option Explicit

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub tool_delete_all_tables()

-    QryDelete ThisWorkbook.Worksheets(RAW_DATA_SHEET).Range("A1")

-End Sub

-

-Sub tool_delete_all_charts(theSheet As Worksheet)

-    Dim theChart As Chart

-    For Each theChart In theSheet

-        theChart.Unprotect

-        theChart.delete

-    Next

-End Sub

-

-Sub DateTimeTest()

-    Dim the_date

-    Dim the_time

-    the_date = DateValue(Now)

-    the_time = TimeValue(Now)

-End Sub

-

-

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{934ECAAF-D9A7-45B4-BB5D-34A0D881DB0A}{9D1622C8-1FA0-4BD4-AE36-4A8180AEBFC3}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If Application.Workbooks.count > 1 Then

-        wbname = Wb.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKCancel, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            Wb.Close Savechanges:=False

-        End If

-        Exit Sub

-    End If

-End Sub

-

-Private Sub App_NewWorkbook(ByVal Wb As Workbook)

-    MsgBox ("New workbook created. It name is " & Wb.FullName)

-End Sub

-<<<<<<
-======================
-mDataCommands
->>>>>>
-Attribute VB_Name = "mDataCommands"

-Option Explicit

-

-Sub evFileOpen()

-    Dim fileToOpen As String

-    Dim Wb As Workbook

-    Dim ticker As String

-    Dim Result As Integer

-

-    fileToOpen = Application.GetOpenFilename("Text Files (*.txt), *.txt")

-    Set Wb = ThisWorkbook

-    With Wb

-        If fileToOpen <> "False" Then

-            If .Worksheets(VAR_SHEET).Range("BOOL_AUTORECALC") = True Then

-                .Worksheets(VAR_SHEET).Range("BOOL_AUTORECALC") = False

-            End If

-            .Worksheets(FORM_SHEET).Range(FILE_NAME) = fileToOpen

-            Result = UpdateHistoryFromFile(Wb, fileToOpen)

-            .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False

-            .Worksheets(VAR_SHEET).Range("BOOL_DEMARK_READY") = False

-            

-            ClearResultTables

-            

-            Select Case Result

-                Case FUNCRES_FILE_OK

-                    .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = True

-                    If TDenmark_Calc Then

-                        With .Worksheets(RAW_DATA_SHEET)

-                            ticker = .Range("B1")

-                        End With

-                        With .Worksheets(FORM_SHEET)

-                            .Range("CALC_TICKER_NAME") = ticker

-                        End With

-                    End If

-                Case FUNCRES_FILE_VERY_SMALL

-                    .Worksheets(FORM_SHEET).Range("CALC_TICKER_NAME") = MSG_FILE_VERY_SMALL

-                    MsgBox MSG_FILE_VERY_SMALL, vbOKOnly, PROGRAM_NAME

-                Case FUNCRES_FILE_INVALID_FORMAT

-                    .Worksheets(FORM_SHEET).Range("CALC_TICKER_NAME") = MSG_FILE_INVALID_FORMAT

-                    MsgBox MSG_FILE_INVALID_FORMAT, vbOKOnly, PROGRAM_NAME

-                End Select

-            .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False

-        End If

-    End With 'wb

-End Sub

-

-Sub evSubmit_Click()

-    Dim ticker As String

-

-    Application.Cursor = xlWait

-    Dim Wb As Workbook

-    Set Wb = ThisWorkbook

-    With Wb

-        With .Worksheets(VAR_SHEET)

-            ticker = .Range("DEN_SYMBOL")

-            If .Range("BOOL_DATA_READY") = False Or .Range("BOOL_LOAD_DATA") = True Then

-                .Range("BOOL_DATA_READY") = UpdateHistoryFromWeb(Wb)

-            End If

-            .Range("BOOL_DEMARK_READY") = False

-        End With

-        If TDenmark_Calc Then

-            With .Worksheets(FORM_SHEET)

-                .Range("CALC_TICKER_NAME") = ticker

-                .Range("FILE_NAME") = ""

-            End With

-        End If

-    End With

-    Application.Cursor = xlDefault

-End Sub

-

-Sub evTicker_Change()

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("IDX_DEN_SECNAME") = .Range("IDX_DEN_SYMBOL")

-    End With

-    evHistory_Change

-End Sub

-

-Sub evSecName_Change()

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("IDX_DEN_SYMBOL") = .Range("IDX_DEN_SECNAME")

-    End With

-    evHistory_Change

-End Sub

-

-Sub evHistory_Change()

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("BOOL_DATA_READY") = False

-    End With

-End Sub

-

-Sub evGroupChange()

-    Dim GroupIdx, LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange As String

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        GroupIdx = .Range("IDX_DEN_LIST")

-        .Range("IDX_DEN_SYMBOL") = 1

-        NewRangeOffsetCol = (GroupIdx - 1) * 2

-        LinesCount = GetLinesCount(.Range("TICKER_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .name & "!" & .Range(.Range("TICKER_TABLES").Offset(1, NewRangeOffsetCol), .Range("TICKER_TABLES").Offset(LinesCount, NewRangeOffsetCol)).Address

-        ThisWorkbook.Worksheets(FORM_SHEET).Shapes("cbxTikers").ControlFormat.ListFillRange = NewCbxRange

-        NewRangeOffsetCol = NewRangeOffsetCol + 1

-        NewCbxRange = .name & "!" & .Range(.Range("TICKER_TABLES").Offset(1, NewRangeOffsetCol), .Range("TICKER_TABLES").Offset(LinesCount, NewRangeOffsetCol)).Address

-        ThisWorkbook.Worksheets(FORM_SHEET).Shapes("cbxSecName").ControlFormat.ListFillRange = NewCbxRange

-    End With

-    evTicker_Change

-End Sub

-

-Sub evUpdateTickerList()

-    UpdateTickerList ThisWorkbook

-    evHistory_Change

-End Sub

-<<<<<<
-======================
-mGetFileData
->>>>>>
-Attribute VB_Name = "mGetFileData"

-Option Explicit

-

-Dim mobjAppRunEnable As New cEnableRun

-

-Public Const MAX_LOAD_DATA_LINES As Integer = 16000

-

-Public Const MSG_FILE_VERY_SMALL As String = "В файле недостаточно данных"

-Public Const MSG_FILE_INVALID_FORMAT As String = "Неверный формат файла"

-

-Public Const FUNCRES_FILE_OK As Integer = 0

-Public Const FUNCRES_FILE_VERY_SMALL As Integer = -1

-Public Const FUNCRES_FILE_INVALID_FORMAT As Integer = -2

-

-Function UpdateHistoryFromFile(Wb As Workbook, fileToOpen As String) As Integer

-    Dim DestRangeName As String

-    Dim ResultLength As Integer

-    Dim Location As Range

-    Dim denWindow As Integer

-    Dim IsIntraday As Boolean

-    Dim CalcNextTime As Boolean

-        

-    Dim SingleFileLine As String

-    Dim FileHandler As Integer

-    Dim i, j, row_idx As Integer

-    

-    UpdateHistoryFromFile = FUNCRES_FILE_INVALID_FORMAT

-    With Wb

-        .Application.ScreenUpdating = False

-        With .Worksheets(VAR_SHEET)

-            CalcNextTime = .Range("BOOL_NEXT_TIME")

-            denWindow = .Range("DEN_WINDOW") + 1

-            If CalcNextTime Then

-                denWindow = denWindow + 1

-            End If

-            IsIntraday = True

-        End With

-        With .Worksheets(RAW_DATA_SHEET)

-            'Clear table include temp area

-            .Parent.Application.DisplayAlerts = False

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW - 1, RAW_DATA_RANGE_COL - 1), _

-                .Cells(65535, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-            ).ClearContents

-            Set Location = .Range(RAW_DATA_RANGE).Offset(-1, 0)

-            

-            ' Reading data from file

-            FileHandler = FreeFile

-            row_idx = 0

-            Open fileToOpen For Input As #FileHandler

-            Do While Not EOF(FileHandler) And row_idx < MAX_LOAD_DATA_LINES

-                Line Input #FileHandler, SingleFileLine

-                .Range(PRICE_TABLE).Offset(row_idx, 0) = SingleFileLine

-                row_idx = row_idx + 1

-            Loop

-            Close #FileHandler

-            

-            ' Parsing data

-            DestRangeName = "=" & RAW_DATA_SHEET & "!$B$1:$B" & row_idx

-            ResultLength = row_idx

-            

-            .Range(DestRangeName).TextToColumns _

-                Destination:=.Range(DestRangeName), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=True, _

-                Semicolon:=True, _

-                Comma:=True, _

-                Space:=False, _

-                Other:=False, _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 1), _

-                                Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1))

-            

-            .Parent.Application.DisplayAlerts = True

-            Dim CurrentDate As String

-            Dim RawData As Range

-            

-            Set RawData = .Range(RAW_DATA_RANGE)

-            

-            If Not CheckFileFormat(RawData.Offset(-1, 0)) Then

-                UpdateHistoryFromFile = FUNCRES_FILE_INVALID_FORMAT

-                Exit Function

-            End If

-            

-            row_idx = 0

-            With RawData

-                CurrentDate = .Value

-                For i = 1 To ResultLength

-                    If Not IsIntraday And CurrentDate = .Offset(i, DATE_IDX).Value Then

-                        ' skip virtual prices

-                        If (.Offset(i, VOLUME_IDX) > MIN_PRICE_VALUE) Then

-                            If .Offset(row_idx, HIGH_IDX).Value < .Offset(i, HIGH_IDX).Value Then

-                                .Offset(row_idx, HIGH_IDX).Value = .Offset(i, HIGH_IDX).Value

-                            End If

-                            If .Offset(row_idx, LOW_IDX).Value > .Offset(i, LOW_IDX).Value Then

-                                .Offset(row_idx, LOW_IDX).Value = .Offset(i, LOW_IDX).Value

-                            End If

-                            .Offset(row_idx, VOLUME_IDX).Value = _

-                                .Offset(row_idx, VOLUME_IDX).Value + .Offset(i, VOLUME_IDX).Value

-                            .Offset(row_idx, TIME_IDX).Value = .Offset(i, TIME_IDX).Value

-                            .Offset(row_idx, CLOSE_IDX).Value = .Offset(i, CLOSE_IDX).Value

-                        End If

-                    Else

-                        ' skip virtual prices

-                        If (.Offset(row_idx, VOLUME_IDX) > MIN_PRICE_VALUE) Then

-                            row_idx = row_idx + 1

-                        End If

-                        For j = DATE_IDX To VOLUME_IDX

-                            .Offset(row_idx, j) = .Offset(i, j)

-                        Next j

-                        CurrentDate = .Offset(i, DATE_IDX)

-                    End If

-                Next i

-            End With ' RawData

-            ' Clear unused Cells

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(65536, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-            ).ClearContents

-            

-            If row_idx > denWindow Then

-                row_idx = row_idx - denWindow

-                .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-                ).delete xlShiftUp

-            Else

-                UpdateHistoryFromFile = FUNCRES_FILE_VERY_SMALL

-                Exit Function

-            End If

-            

-            row_idx = denWindow + 1

-            

-            Set Location = .Range( _

-                .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_IDX) _

-            )

-            

-            Location.TextToColumns _

-                Destination:=Location.Offset(0, DATE_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:="/", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2))

-            

-            Location.Offset(0, TIME_IDX).TextToColumns _

-                Destination:=Location.Offset(0, TIME_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:=":", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2))

-            

-            ' Check estimation date

-            

-            Dim end_date, end_time As Date

-            Dim year, month, day As Integer

-            Dim hour, minute As Integer

-            Dim next_time_exist As Boolean

-            

-            year = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 3)

-            month = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 2)

-            day = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 1)

-            hour = Location.Cells(denWindow - 1, TIME_STAMP_OFFSET + 1)

-            minute = Location.Cells(denWindow - 1, TIME_STAMP_OFFSET + 2)

-            

-            next_time_exist = day + month + year <> 0

-            

-            If next_time_exist Then

-                end_date = DateSerial(year, month, day)

-                end_time = TimeSerial(hour, minute, 0)

-                mobjAppRunEnable.EnableRun ESTIMATION_DATE, end_date

-            End If

-             

-            row_idx = 0

-            Dim temp_str As String

-                    

-            If IsIntraday Then

-                Do While IsEmpty(Location.Cells(1 + row_idx, 1 + DATE_IDX)) = False

-                       temp_str = Location.Cells(1 + row_idx, 1 + PROJECT_IDX + 1)

-                       temp_str = temp_str & "/"

-                       temp_str = temp_str & Location.Cells(1 + row_idx, 1 + PROJECT_IDX + 2)

-                       temp_str = temp_str & "-"

-                       temp_str = temp_str & Location.Cells(1 + row_idx, 1 + TIME_IDX)

-                       Location.Cells(1 + row_idx, DATE_IDX) = temp_str

-                       row_idx = row_idx + 1

-                Loop

-                row_idx = row_idx - 1

-                Dim condition As Boolean

-                condition = Not CalcNextTime And next_time_exist And end_date = DateValue(Now) And end_time > TimeValue(Now)

-                If condition Then

-                    .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL - 1), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-                    ).delete xlShiftUp

-                End If

-            End If

-        End With ' .Worksheets(RAW_DATA_SHEET)

-    End With ' wb

-    UpdateHistoryFromFile = FUNCRES_FILE_OK

-End Function

-

-Function CheckFileFormat(HeaderString As Range) As Boolean

-    With HeaderString

-        CheckFileFormat = _

-            .Offset(0, DATE_IDX) = "Date" And _

-            .Offset(0, TIME_IDX) = "Time" And _

-            .Offset(0, OPEN_IDX) = "Open" And _

-            .Offset(0, CLOSE_IDX) = "Close" And _

-            .Offset(0, LOW_IDX) = "Low" And _

-            .Offset(0, HIGH_IDX) = "High" And _

-            .Offset(0, VOLUME_IDX) = "Volume"

-    End With

-End Function

-<<<<<<
-Project Name : 'Denmark_method'
-Quirk - duff tag length======================
-MGetWebData
->>>>>>
-Attribute VB_Name = "MGetWebData"

-Option Explicit

-

-Dim mobjAppRunEnable As New cEnableRun

-

-Const QueryDataName As String = "ExternalDenmarkData"

-

-Function UpdateHistoryFromWeb(wb As Workbook) As Boolean

-    Dim DestRangeName As String

-    Dim ResultLength As Integer

-    Dim QryPathStr As String

-    Dim Location As Range

-    Dim denWindow As Integer

-    Dim IsIntraday As Boolean

-    Dim CalcNextTime As Boolean

-        

-    UpdateHistoryFromWeb = False

-    QryPathStr = GetQryPath(wb)

-    With wb

-        .Application.ScreenUpdating = False

-        With .Worksheets(VAR_SHEET)

-            DestRangeName = .Range("DEN_SYMBOL")

-            CalcNextTime = .Range("BOOL_NEXT_TIME")

-            denWindow = .Range("DEN_WINDOW") + 1

-            If CalcNextTime Then

-                denWindow = denWindow + 1

-            End If

-            IsIntraday = IsNumeric(.Range("DEN_TIME"))

-        End With

-        With .Worksheets(RAW_DATA_SHEET)

-            .Range(PRICE_TABLE) = DestRangeName

-            'Clear table include temp area

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW - 1, RAW_DATA_RANGE_COL - 1), _

-                .Cells(65535, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-            ).ClearContents

-            Set Location = .Range(RAW_DATA_RANGE).Offset(-1, 0)

-            If Not QryExist(Location, QueryDataName) Then

-                QryCreate Location, QueryDataName, QryPathStr

-            Else

-                QryRefresh Location, QueryDataName, QryPathStr

-            End If

-            With Location.Worksheet.QueryTables(QueryDataName)

-                DestRangeName = .ResultRange.name.RefersTo

-                ResultLength = .ResultRange.count

-            End With

-    

-    '        .Parent.Application.DisplayAlerts = False

-            

-            .Range(DestRangeName).TextToColumns _

-                Destination:=.Range(DestRangeName), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=True, _

-                Semicolon:=True, _

-                Comma:=True, _

-                Space:=False, _

-                Other:=False, _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 1), _

-                                Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1))

-            

-    '        .Parent.Application.DisplayAlerts = True

-            Dim i, j, row_idx As Integer

-            Dim CurrentDate As String

-            Dim RawData As Range

-            

-            Set RawData = .Range(RAW_DATA_RANGE)

-            row_idx = 0

-            With RawData

-                CurrentDate = .Value

-                For i = 1 To ResultLength

-                    If Not IsIntraday And CurrentDate = .Offset(i, DATE_IDX).Value Then

-                        ' skip virtual prices

-                        If (.Offset(i, VOLUME_IDX) > MIN_PRICE_VALUE) Then

-                            If .Offset(row_idx, HIGH_IDX).Value < .Offset(i, HIGH_IDX).Value Then

-                                .Offset(row_idx, HIGH_IDX).Value = .Offset(i, HIGH_IDX).Value

-                            End If

-                            If .Offset(row_idx, LOW_IDX).Value > .Offset(i, LOW_IDX).Value Then

-                                .Offset(row_idx, LOW_IDX).Value = .Offset(i, LOW_IDX).Value

-                            End If

-                            .Offset(row_idx, VOLUME_IDX).Value = _

-                                .Offset(row_idx, VOLUME_IDX).Value + .Offset(i, VOLUME_IDX).Value

-                            .Offset(row_idx, TIME_IDX).Value = .Offset(i, TIME_IDX).Value

-                            .Offset(row_idx, CLOSE_IDX).Value = .Offset(i, CLOSE_IDX).Value

-                        End If

-                    Else

-                        ' skip virtual prices

-                        If (.Offset(row_idx, VOLUME_IDX) > MIN_PRICE_VALUE) Then

-                            row_idx = row_idx + 1

-                        End If

-                        For j = DATE_IDX To VOLUME_IDX

-                            .Offset(row_idx, j) = .Offset(i, j)

-                        Next j

-                        CurrentDate = .Offset(i, DATE_IDX)

-                    End If

-                Next i

-            End With ' RawData

-            ' Clear unused Cells

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(65536, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-            ).ClearContents

-            

-            If row_idx > denWindow Then

-                row_idx = row_idx - denWindow

-                .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-                ).delete xlShiftUp

-            Else

-                Exit Function

-            End If

-            

-            row_idx = denWindow + 1

-            

-            Set Location = .Range( _

-                .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_IDX) _

-            )

-            

-            Location.TextToColumns _

-                Destination:=Location.Offset(0, DATE_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:="/", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2))

-            

-            Location.Offset(0, TIME_IDX).TextToColumns _

-                Destination:=Location.Offset(0, TIME_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:=":", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2))

-            

-            ' Check estimation date

-            

-            Dim end_date, end_time As Date

-            Dim year, month, day As Integer

-            Dim hour, minute As Integer

-            Dim next_time_exist As Boolean

-            

-            year = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 3)

-            month = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 2)

-            day = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 1)

-            hour = Location.Cells(denWindow - 1, TIME_STAMP_OFFSET + 1)

-            minute = Location.Cells(denWindow - 1, TIME_STAMP_OFFSET + 2)

-            

-            next_time_exist = day + month + year <> 0

-            

-            If next_time_exist Then

-                end_date = DateSerial(year, month, day)

-                end_time = TimeSerial(hour, minute, 0)

-                mobjAppRunEnable.EnableRun ESTIMATION_DATE, end_date

-            End If

-             

-            row_idx = 0

-            Dim temp_str As String

-                    

-            If IsIntraday Then

-                Do While IsEmpty(Location.Cells(1 + row_idx, 1 + DATE_IDX)) = False

-                       temp_str = Location.Cells(1 + row_idx, 1 + PROJECT_IDX + 1)

-                       temp_str = temp_str & "/"

-                       temp_str = temp_str & Location.Cells(1 + row_idx, 1 + PROJECT_IDX + 2)

-                       temp_str = temp_str & "-"

-                       temp_str = temp_str & Location.Cells(1 + row_idx, 1 + TIME_IDX)

-                       Location.Cells(1 + row_idx, DATE_IDX) = temp_str

-                       row_idx = row_idx + 1

-                Loop

-                row_idx = row_idx - 1

-                Dim condition As Boolean

-                condition = Not CalcNextTime And next_time_exist And end_date = DateValue(Now) And end_time > TimeValue(Now)

-                If condition Then

-                    .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL - 1), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-                    ).delete xlShiftUp

-                End If

-            Else

-                Do While IsEmpty(Location.Cells(1 + row_idx, 1 + DATE_IDX)) = False

-                       temp_str = "'" & Location.Cells(1 + row_idx, 1)

-                       Location.Cells(1 + row_idx, DATE_IDX) = temp_str

-                       row_idx = row_idx + 1

-                Loop

-                row_idx = row_idx - 1

-                condition = Not CalcNextTime And next_time_exist And end_date = DateValue(Now) And TimeValue(Now) < TimeSerial(18, 0, 0)

-                If condition Then

-                    .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL - 1), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-                    ).delete xlShiftUp

-                End If

-            End If

-        End With ' .Worksheets(RAW_DATA_SHEET)

-    End With ' wb

-    UpdateHistoryFromWeb = True

-End Function

-

-Private Function GetQryPath(wb As Workbook) As String

-    Dim QryPathStr As String

-    Dim IsIntradai As Boolean

-    Dim DayCount As Integer

-    With wb.Worksheets(VAR_SHEET)

-        QryPathStr = "URL;http://online.rbc.ru/cgi-bin/online/nph-single-old.cgi?"

-        QryPathStr = QryPathStr & "ticker=" & .Range("DEN_SYMBOL")

-        QryPathStr = QryPathStr & "&source=" & .Range("DEN_SOURCE")

-        QryPathStr = QryPathStr & "&board=" & .Range("DEN_BOARD")

-        IsIntradai = IsNumeric(.Range("DEN_TIME"))

-        If IsIntradai Then

-            QryPathStr = QryPathStr & "&period=" & .Range("DEN_TIME")

-        Else

-            QryPathStr = QryPathStr & "&period=60"

-        End If

-        QryPathStr = QryPathStr & "&oh=11&ch=18"

-        QryPathStr = QryPathStr & "&separator=%2C"

-        QryPathStr = QryPathStr & "&vmode=Ignore&vtype=BA2"

-        QryPathStr = QryPathStr & "&format=Excel"

-        

-        If IsIntradai Then

-            DayCount = .Range("DEN_HISTORY") * .Range("DEN_TIME") \ 420 + 1 + .Range("DEN_HISTORY")

-        Else

-            DayCount = .Range("DEN_HISTORY")

-        End If

-        QryPathStr = QryPathStr & "&daysback=" & DayCount

-'        .Range("LAST_HIST_QRY") = QryPathStr

-    End With

-    GetQryPath = QryPathStr

-    

-End Function

-

-Sub UpdateTickerList(wb As Workbook)

-    Dim Idx, n As Integer

-    Dim ResultLength As Integer

-    Dim Location As Range

-    Dim QryPathStr As String

-    Dim QueryDataName As String

-    Dim DestRangeArea As String

-    

-    QryPathStr = GetListPath(wb)

-    With wb

-        With .Worksheets(VAR_SHEET)

-            Idx = .Range("IDX_DEN_LIST")

-            Set Location = .Range("TICKER_TABLES").Offset(0, (Idx - 1) * 2)

-             .Range("IDX_DEN_SYMBOL") = 1

-            QueryDataName = Location.Offset(0, 0)

-            'Clear table

-            .Range(Location.Offset(1, 0), Location.Offset(65535 - Location.Row, 1)).ClearContents

-            

-            If Not QryExist(Location.Offset(1, 0), QueryDataName) Then

-                QryCreate Location.Offset(1, 0), QueryDataName, QryPathStr

-            Else

-                QryRefresh Location.Offset(1, 0), QueryDataName, QryPathStr

-            End If

-            ' Remove header

-            ' Find [DATA]

-            n = 0

-            Do While Location.Offset(n, 0) <> "[DATA]"

-                n = n + 1

-            Loop

-            .Range(Location.Offset(1, 0), Location.Offset(n, 1)).delete Shift:=xlUp

-            With .QueryTables(QueryDataName)

-                DestRangeArea = .ResultRange.name.RefersTo

-                ResultLength = .ResultRange.count

-            End With

-        

-        '        .Parent.Application.DisplayAlerts = False

-                

-            .Range(DestRangeArea).TextToColumns _

-                Destination:=.Range(DestRangeArea), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=True, _

-                Semicolon:=True, _

-                Comma:=True, _

-                Space:=False, _

-                Other:=False, _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 9))

-        ' Sort Data

-            Set Location = .Range(.Range(DestRangeArea).Offset(0, 0), .Range(DestRangeArea).Offset(ResultLength - 1, 1))

-            Location.Sort _

-                Key1:=.Range(DestRangeArea).Offset(0, 0), _

-                Order1:=xlAscending, _

-                Header:=xlNo, _

-                OrderCustom:=1, _

-                MatchCase:=False, _

-                Orientation:=xlTopToBottom

-        End With

-        ' Setup Ticker List

-         With .Worksheets(VAR_SHEET)

-            DestRangeArea = .name & "!" & .Range(.Range(DestRangeArea).Cells(1, 1), .Range(DestRangeArea).Cells(ResultLength - 1, 1)).Address

-         End With

-        With .Worksheets(FORM_SHEET).Shapes("cbxTikers").ControlFormat

-            .ListFillRange = DestRangeArea

-            .ListIndex = 1

-        End With

-        ' Setup Name List

-         With .Worksheets(VAR_SHEET)

-            DestRangeArea = .name & "!" & .Range(.Range(DestRangeArea).Cells(1, 1), .Range(DestRangeArea).Cells(ResultLength - 1, 1)).Offset(0, 1).Address

-         End With

-        With .Worksheets(FORM_SHEET).Shapes("cbxSecName").ControlFormat

-            .ListFillRange = DestRangeArea

-            .ListIndex = 1

-        End With

-    End With

-End Sub

-

-Private Function GetListPath(wb As Workbook) As String

-    Dim QryPathStr As String

-    With wb.Worksheets(VAR_SHEET)

-        QryPathStr = "URL;http://online.rbc.ru/cgi-bin/names.cgi?"

-        QryPathStr = QryPathStr & "&source=" & .Range("DEN_SOURCE")

-        QryPathStr = QryPathStr & "&board=" & .Range("DEN_BOARD")

-        QryPathStr = QryPathStr & "&category=STOCKS"

-        '.Range("LAST_DIR_QRY") = QryPathStr

-    End With

-    GetListPath = QryPathStr

-End Function

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    Set MyAppEvents.app = Application

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    If Application.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEL сейчас будут закрыты!", vbOKCancel, "$" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close Savechanges:=False

-            Exit Sub

-        End If

-    End If

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False

-    cmSetStandaloneMode

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment wb:=ThisWorkbook, DesignMode:=False

-        If ThisWorkbook.Saved = False Then

-            ThisWorkbook.Save

-        End If

-    End If

-    Application.Caption = Empty

-    Application.CommandBars("Worksheet Menu Bar").Reset

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-        Dim MaxX, MaxY As Integer

-        With ThisWorkbook.Worksheets(FORM_SHEET)

-            MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-            MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-        End With

-

-        With ThisWorkbook.Application

-            .ScreenUpdating = False

-            .WindowState = xlNormal

-            .Height = MaxY

-            .Width = MaxX

-        End With

-End Sub

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mReadWrite
->>>>>>
-Attribute VB_Name = "mReadWrite"

-Option Explicit

-

-Public Const GOOD_LINE_STATUS As String = "Ok"

-Public Const BAD_LINE_STATUS As String = "N/A"

-

-Function ReadPricesData(Location As Range, Hist As Integer, dt As Integer, _

-              pPriceData As TPriceData) As Integer

-    'Инициализация типа TPriceData из таблицы типа - 1

-    'kопируются не более чем hist последних строк

-    'aPoint - начало таблицы

-    'первые две строки таблицы идентифицирует данные (строки)

-    Dim n, i As Integer

-    

-    'Определение числа строк таблицы - n

-    n = GetLinesCount(Location)

-    ReadPricesData = n

-    If n < 9 Then             'обработать ошибку !!!

-        GoTo done

-    End If

-    ' число строк определено ()

-    If Hist > (n - 3) \ dt + 1 Then ' коррекция истории

-        Hist = (n - 3) \ dt + 1 '

-    End If

-    Dim t, s As Integer

-    For t = 0 To Hist - 1

-        s = n - t * dt - 1

-        pPriceData.D(Hist - t) = Location.Offset(s, DATE_IDX).Value

-        pPriceData.Tm(Hist - t) = Location.Offset(s, TIME_IDX).Value

-        pPriceData.Opn(Hist - t) = Location.Offset(s, OPEN_IDX).Value

-        pPriceData.Hgh(Hist - t) = Location.Offset(s, HIGH_IDX).Value

-        pPriceData.Lw(Hist - t) = Location.Offset(s, LOW_IDX).Value

-        pPriceData.Cls(Hist - t) = Location.Offset(s, CLOSE_IDX).Value

-        pPriceData.Vl(Hist - t) = Location.Offset(s, VOLUME_IDX).Value

-    Next t

-    ReadPricesData = t + 1

-done:

-End Function

-

-Sub ResultLinesOut(Location As Range, pPD As TPriceData, pDen As TDenmark)

-    Dim n As Integer

-    

-    n = GetLinesCount(Location)

-    With Location

-        .Offset(-1, RESIST_IDX) = "Resistance"

-        .Offset(-1, SUPPORT_IDX) = "Support"

-        .Offset(-1, PROJECT_IDX) = "Project"

-    End With

-    Dim t, count, Idx, loc_idx As Integer

-    count = pPD.tC

-    For t = 0 To count - 1

-        Idx = count - t

-        loc_idx = n - t - 1

-        If pDen.ResistanceLine(Idx) > MIN_PRICE_VALUE Then

-            Location.Offset(loc_idx, RESIST_IDX).Value = pDen.ResistanceLine(Idx)

-        End If

-        If pDen.SupportLine(Idx) > MIN_PRICE_VALUE Then

-            Location.Offset(loc_idx, SUPPORT_IDX).Value = pDen.SupportLine(Idx)

-        End If

-        If Abs(pDen.SignalValue) > 1 Then

-            Location.Offset(loc_idx, PROJECT_IDX).Value = pDen.ProjectPrice

-        End If

-    Next t

-End Sub

-

-Sub Out_Table_1(TheRange As Range, pDen As TDenmark, LastIdx As Integer)

-    

-    

-    ' Col = 2 - не определен !!!

-    ' Status - Col = 0

-    If pDen.ResistancePointCount >= 2 Then

-        TheRange.Offset(0, 0).Value = GOOD_LINE_STATUS

-    Else

-        TheRange.Offset(0, 0).Value = BAD_LINE_STATUS

-    End If

-    If pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(1, 0).Value = GOOD_LINE_STATUS

-    Else

-        TheRange.Offset(1, 0).Value = BAD_LINE_STATUS

-    End If

-    ' -----------------------------------------

-    ' углы наклонов линии сопротивления и поддержки - Col = 1

-    If pDen.ResistancePointCount >= 2 Then

-        TheRange.Offset(0, 1).Value = pDen.ResistanceAngle

-    End If

-    If pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(1, 1).Value = pDen.SupportAngle

-    End If

-    If pDen.ResistancePointCount >= 2 And pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(2, 1).Value = (pDen.ResistanceAngle + pDen.SupportAngle) / 2

-    End If

-    ' -----------------------------------------

-    ' Опорные цены линий денмарка на текущий момент

-    If pDen.ResistancePointCount >= 2 Then

-        TheRange.Offset(0, 2).Value = pDen.ResistanceLine(LastIdx)

-    End If

-    If pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(1, 2).Value = pDen.SupportLine(LastIdx)

-    End If

-    If pDen.ResistancePointCount >= 2 And pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(2, 2).Value = _

-            (pDen.ResistanceLine(LastIdx) + pDen.SupportLine(LastIdx)) / 2

-    End If

-    

-End Sub

-

-Sub Out_Table_2(TheRange As Range, TheComment As Range, pPD As TPriceData, pDen As TDenmark)

-    Const ColorIndexBUY = 5

-    Const ColorIndexSELL = 3

-    Const ColorIndexNOTHINK = 14

-    

-    Dim SignalValue_defined, allert_enable  As Boolean

-    Dim Message As String

-    SignalValue_defined = False

-    allert_enable = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_ALLERT_DLG")

-    Message = "Сигнал об изменении тренда не идентифицирован."

-    If pDen.SignalValue >= 2 Then

-        SignalValue_defined = True

-        With TheRange.Offset(0, 0)

-            .Value = "BUY"

-            .Font.Bold = True

-            .Font.ColorIndex = ColorIndexBUY

-        End With

-        TheRange.Offset(0, 1).Value2 = pPD.D(pPD.tC)

-        TheRange.Offset(0, 2).Value2 = pPD.Tm(pPD.tC)

-        TheRange.Offset(0, 3).Value = pDen.SignalValue - 1

-        TheRange.Offset(0, 4).Value = pDen.ProjectPrice

-        Message = "BUY Signal: возможен прорыв вверх нисходящего тренда с уровнем значимости = " & pDen.SignalValue - 1 & " ! "

-    End If

-    If pDen.SignalValue <= -2 Then

-        SignalValue_defined = True

-        With TheRange.Offset(0, 0)

-            .Value = "SELL"

-            .Font.Bold = True

-            .Font.ColorIndex = ColorIndexSELL

-        End With

-        TheRange.Offset(0, 1).Value2 = pPD.D(pPD.tC)

-        TheRange.Offset(0, 2).Value2 = pPD.Tm(pPD.tC)

-        TheRange.Offset(0, 3).Value = pDen.SignalValue + 1

-        TheRange.Offset(0, 4).Value = pDen.ProjectPrice

-        Message = "SELL Signal: возможен прорыв вниз восходящего тренда с уровнем значимости = " & -(pDen.SignalValue + 1) & "!"

-    End If

-    With TheComment

-        .Value = Message

-        .Font.Bold = True

-        Dim color_idx As Integer

-        If SignalValue_defined Then

-            If pDen.SignalValue > 0 Then

-                .Font.ColorIndex = ColorIndexBUY

-            Else

-                .Font.ColorIndex = ColorIndexSELL

-            End If

-        Else

-            .Font.ColorIndex = ColorIndexNOTHINK

-        End If

-    End With

-    If allert_enable And SignalValue_defined Then

-        MsgBox _

-            Prompt:=Message, _

-            Title:=PROGRAM_NAME, _

-            Buttons:=vbOKOnly + vbInformation

-    End If

-End Sub

-

-Sub Out_Table_3(TheRange As Range, pDen As TDenmark)

-    Dim i As Integer

-    For i = 1 To 3

-        TheRange.Offset(i - 1, 0).Value = pDen.Qualificator(i)

-    Next i

-End Sub

-

-Sub Out_Table_4(TheRange As Range, pPD As TPriceData)

-    Dim LastIdx As Integer

-    LastIdx = pPD.tC

-    With TheRange

-        .Offset(0, 0).Value2 = "'" & pPD.D(LastIdx)

-        .Offset(0, 1).Value2 = "'" & pPD.Tm(LastIdx)

-        .Offset(0, 2) = pPD.Opn(LastIdx)

-        .Offset(0, 3) = pPD.Hgh(LastIdx)

-        .Offset(0, 4) = pPD.Lw(LastIdx)

-        .Offset(0, 5) = pPD.Cls(LastIdx)

-        .Offset(0, 6) = pPD.Cls(LastIdx) - pPD.Cls(LastIdx - 1)

-    End With

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Denmark method bar"

-Public Const common_pwd As Long = 31415926

-

-

-Sub SetEnvironment(wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    With Application

-        .Caption = PROGRAM_NAME

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .GetState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-    End With

-    With wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(FORM_SHEET).Select

-    End With

-    CreateCommandBar theApp:=wb.Application

-End Sub

-

-Sub RestoreEnvironment(wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Application.ScreenUpdating = False

-    With wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                     cWindow.DisplayHeadings = True

-                Next

-            End If

-        Next

-        .Worksheets(FORM_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu (True)

-        End If

-        With mobjAppState

-            .RestoreState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(wb As Workbook)

-    With wb

-        .Application.ScreenUpdating = False

-        

-        With .Worksheets(RAW_DATA_SHEET)

-            .Visible = xlVeryHidden

-            .Protect Password:=common_pwd, userInterfaceOnly:=True, Contents:=False

-        End With

-        With .Worksheets(VAR_SHEET)

-            .Visible = xlVeryHidden

-            .Protect Password:=common_pwd, userInterfaceOnly:=True, Contents:=False

-        End With

-        With .Worksheets(FORM_SHEET)

-            .EnableSelection = xlNoSelection

-            .Protect userInterfaceOnly:=True

-            .Select

-        End With

-        With .Worksheets(CHART_SHEET)

-            .EnableSelection = xlNoSelection

-            .Protect userInterfaceOnly:=True

-        End With

-        .Protect Windows:=True

-        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(wb As Workbook)

-    With wb

-        .Unprotect

-        .Application.ScreenUpdating = False

-        With .Worksheets(RAW_DATA_SHEET)

-            .Visible = xlVeryHidden

-            .Unprotect Password:=common_pwd

-        End With

-        With .Worksheets(VAR_SHEET)

-            .Visible = xlVeryHidden

-            .Unprotect Password:=common_pwd

-        End With

-        With .Worksheets(CHART_SHEET)

-            .Select

-            .Unprotect

-        End With

-        With .Worksheets(FORM_SHEET)

-            .Select

-            .Unprotect

-        End With

-        .Application.ScreenUpdating = True

-        

-    End With

-End Sub

-

-<<<<<<
-======================
-mTypes
->>>>>>
-Attribute VB_Name = "mTypes"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Метод г-на Демарка"

-Public Const PROGRAM_VERSION As String = "version 3.0 Professional"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-

-'Public Const ESTIMATION_DATE As Long = 19980915

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "J27"

-

-Public Const RAW_DATA_SHEET As String = "Raw_data"

-Public Const PRICE_TABLE As String = "B1"

-Public Const RAW_DATA_RANGE As String = "B3"

-Public Const RAW_DATA_RANGE_COL As Integer = 2

-Public Const RAW_DATA_RANGE_ROW As Integer = 3

-

-Public Const VAR_SHEET As String = "Var_s"

-

-Public Const CHART_SHEET As String = "Chart"

-

-Public Const MIN_PRICE_VALUE As Double = 0.000001

-Public Const MAX_PRICE_VALUE As Double = 1000000000

-

-' Fields indexes in RAW_DATA_RANGE

-Public Const DATE_IDX As Integer = 0

-Public Const TIME_IDX As Integer = 1

-Public Const OPEN_IDX As Integer = 2

-Public Const CLOSE_IDX As Integer = 3

-Public Const LOW_IDX As Integer = 4

-Public Const HIGH_IDX As Integer = 5

-Public Const VOLUME_IDX As Integer = 6

-Public Const RESIST_IDX As Integer = 7

-Public Const SUPPORT_IDX As Integer = 8

-Public Const PROJECT_IDX As Integer = 9

-

-Public Const DATE_STAMP_OFFSET = PROJECT_IDX + 1

-Public Const TIME_STAMP_OFFSET = PROJECT_IDX + 4

-Public Const DATE_TIME_STAMP_SIZE = 5

-

-Type TPriceData

-    D() As String      ' календарная дата

-    Tm() As String     ' время

-    Opn() As Double    ' Open

-    Hgh() As Double    ' High

-    Lw() As Double     ' Low

-    Cls() As Double    ' Close

-    Vl() As Double     ' Volume

-    tC As Integer      ' Current time

-End Type

-

-Type TDenmark

-   ResistanceLine() As Double           'Resistance line

-   ResistancePoints() As Integer        'Resistance pivot points

-   ResistancePointCount As Integer      'The number of resistance pivot points

-   ResistanceAngle As Double            'Angle of Declination of ResistanceLine

-   

-   SupportLine() As Double              'Support line

-   SupportPoints() As Integer           'Support pivot points

-   SupportPointsCount As Integer        'The number of support pivot points

-   SupportAngle As Double               ' Angle of Declination of SupportLine

-   

-   SignalParameter     As Integer       ' parameter for SignalValue

-   SignalValue      As Integer          'SignalValue

-   

-   

-   Qualificator(1 To 3) As String       ' qualificators

- 

-   ProjectNumber As Integer             ' номер проекции

-   ProjectPrice  As Double              ' проекция цены

-   

-End Type

-

-

-<<<<<<
-======================
-mCommands
->>>>>>
-Attribute VB_Name = "mCommands"

-Option Explicit

-Dim AppRunEnable As New cEnableRun

-

-Sub evParamChange()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DEMARK_READY") = False

-End Sub

-

-Sub cmViewChart(Optional SwapPage As Boolean = True)

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("BOOL_CHART_READY") = False

-        If .Range("BOOL_DEMARK_READY") <> True Then

-            If .Range("BOOL_AUTORECALC") = True Then

-                evSubmit_Click

-                If .Range("BOOL_DEMARK_READY") <> True Then

-                    Exit Sub

-                End If

-            Else

-                MsgBox _

-                    "График не может быть построен." & vbCrLf & "Исходные данные не обработаны.", _

-                    vbOKOnly + vbExclamation, _

-                    PROGRAM_NAME

-                Exit Sub

-            End If

-        End If

-    End With

-    With ThisWorkbook.Worksheets(FORM_SHEET)

-        With .Range("TABLE_1")

-            Dim test_lines As Boolean

-            test_lines = StrComp(.Cells(1, 1).Value, GOOD_LINE_STATUS)

-            test_lines = test_lines + StrComp(.Cells(2, 1).Value, GOOD_LINE_STATUS)

-            If test_lines <> 0 Then

-                MsgBox _

-                    Prompt:="График не может быть построен." & vbCrLf & "Опорные точки не определены .", _

-                    Title:=PROGRAM_NAME, _

-                    Buttons:=vbOKOnly + vbExclamation

-                Exit Sub

-            End If

-        End With

-        Draw_Chart Not IsEmpty(.Range("TABLE_2").Cells(1, 1))

-    End With

-    With ThisWorkbook

-        .Worksheets(VAR_SHEET).Range("BOOL_CHART_READY") = True

-        If SwapPage Then

-            .Worksheets(CHART_SHEET).Select

-        End If

-    End With

-End Sub

-

-Sub cmViewForm()

-    With ThisWorkbook

-        .Worksheets(FORM_SHEET).Select

-    End With

-End Sub

-

-Sub cmCloseProgram()

-    Dim ResistanceLine

-    ResistanceLine = MsgBox( _

-        Prompt:="Вы желаете завершить программу?", _

-        Buttons:=vbQuestion + vbYesNo, _

-        Title:=PROGRAM_NAME _

-    )

-    If ResistanceLine = vbYes Then

-       Application.Quit

-    End If

-End Sub

-

-Sub cmAbout()

-    dlgAbout.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlgAbout.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlgAbout.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlgAbout.Show

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-        helppath = "hh.exe " & .Path & "\Demark.chm"

-        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub cmSetStandaloneMode()

-    Application.ScreenUpdating = False

-    ProtectionDisable wb:=ThisWorkbook

-    SetEnvironment wb:=ThisWorkbook

-    ProtectionEnable wb:=ThisWorkbook

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    rp = common_pwd

-    dlgGetPwd.edPwd = ""

-    dlgGetPwd.Show

-    If dlgGetPwd.edPwd = rp Then

-        ProtectionDisable wb:=ThisWorkbook

-        RestoreEnvironment wb:=ThisWorkbook, DesignMode:=True

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmPrint()

-    If MsgBox( _

-            Prompt:="Вы желаете распечатать результат?", _

-            Buttons:=vbYesNo + vbQuestion, _

-            Title:=PROGRAM_NAME) = vbNo _

-    Then

-        Exit Sub

-    End If

-    Dim s_ticker, s_name, s_time As String

-    s_ticker = ThisWorkbook.Worksheets(FORM_SHEET).Range("CALC_TICKER_NAME")

-    s_name = ThisWorkbook.Worksheets(FORM_SHEET).Range("CALC_NAME")

-    s_time = Now

-    Application.ScreenUpdating = False

-    cmViewChart SwapPage:=False

-    Application.ScreenUpdating = False

-    With ThisWorkbook.Worksheets(FORM_SHEET).PageSetup

-        .LeftHeader = s_ticker

-        .CenterHeader = PROGRAM_NAME

-        .RightHeader = s_time

-        .LeftFooter = s_name

-        .CenterFooter = "Page &P of &N"

-        .RightFooter = ""

-        .LeftMargin = Application.InchesToPoints(0.75)

-        .RightMargin = Application.InchesToPoints(0.75)

-        .TopMargin = Application.InchesToPoints(0.78)

-        .BottomMargin = Application.InchesToPoints(0.92)

-        .HeaderMargin = Application.InchesToPoints(0.5)

-        .FooterMargin = Application.InchesToPoints(0.5)

-        .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 = 2

-    End With

-    With ThisWorkbook.Worksheets(CHART_SHEET).PageSetup

-        .LeftHeader = s_ticker

-        .CenterHeader = PROGRAM_NAME

-        .RightHeader = s_time

-        .LeftFooter = s_name

-        .CenterFooter = "Page &P of &N"

-        .RightFooter = ""

-        .LeftMargin = Application.InchesToPoints(0.75)

-        .RightMargin = Application.InchesToPoints(0.75)

-        .TopMargin = Application.InchesToPoints(0.78)

-        .BottomMargin = Application.InchesToPoints(0.92)

-        .HeaderMargin = Application.InchesToPoints(0.5)

-        .FooterMargin = Application.InchesToPoints(0.5)

-        .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 = 2

-    End With

-    Application.ScreenUpdating = False

-    ThisWorkbook.Worksheets(Array("MainForm", "Chart")).PrintOut Copies:=1, Collate:=True

-    cmViewForm

-End Sub

-<<<<<<
-======================
-mDemark
->>>>>>
-Attribute VB_Name = "mDemark"

-Option Explicit

-

-Public Const FORM_SHEET As String = "MainForm"

-

-'Form Ranges

-Public Const FILE_NAME As String = "FILE_NAME"

-Public Const TABLE_1 As String = "TABLE_1"

-Public Const TABLE_2 As String = "TABLE_2"

-Public Const TABLE_3 As String = "TABLE_3"

-Public Const TABLE_4 As String = "TABLE_4"

-Public Const TABLE_COMMENT As String = "TABLE_COMMENT"

-

-'Основной тип данных - стандарт 1

-

-'*********************

-Dim PriceDataArray As TPriceData

-Dim DenmarkDataArray As TDenmark

-

-Dim mobjAppRunEnable As New cEnableRun

-

-Sub ClearResultTables()

-    With ThisWorkbook.Worksheets(FORM_SHEET)

-        .Range(TABLE_1).ClearContents ' таблица-1

-        .Range(TABLE_2).ClearContents ' таблица-2

-        .Range(TABLE_3).ClearContents ' таблица-3

-        .Range(TABLE_COMMENT).Value = "" ' коментарий-3

-        .Range(TABLE_4).ClearContents ' таблица-4

-    End With

-End Sub

-

-Function TDenmark_Calc() As Boolean

-    

-    Dim nWindow As Integer

-    Dim bPrevCloseFilter, bSuccCloseFilter As Boolean

-    

-    TDenmark_Calc = False

-    

-    mobjAppRunEnable.EnableRun ESTIMATION_DATE, Now

-    

-    With ThisWorkbook

-        .Application.ScreenUpdating = False

-'1)    Read User data

-        With .Worksheets(VAR_SHEET)

-            DenmarkDataArray.ProjectNumber = .Range("DEN_PROECT").Value

-            DenmarkDataArray.SignalParameter = .Range("DEN_PARAM").Value

-            nWindow = .Range("DEN_WINDOW").Value

-            bPrevCloseFilter = .Range("BOOL_PREV_CLOSE").Value

-            bSuccCloseFilter = .Range("BOOL_SUCC_CLOSE").Value

-        End With

-

-'2)   Memory allocation

-        allocate_memory PriceDataArray, DenmarkDataArray, nWindow

-

-'3)   Read data

-        Dim TheRange As Range

-        Set TheRange = .Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE)

-        Dim LinesCount As Integer

-        LinesCount = ReadPricesData(Location:=TheRange, Hist:=PriceDataArray.tC, dt:=1, pPriceData:=PriceDataArray)

-        

-        'Init function result

-        TDenmark_Calc = LinesCount >= nWindow

-        

-        If LinesCount >= nWindow Then

-        

-'4)   Calculate metod TDenmarkDataArray

-            DetDenmark PriceDataArray, DenmarkDataArray, bPrevCloseFilter, bSuccCloseFilter

-            If Abs(DenmarkDataArray.SignalValue) > 1 Then  'ценовые ориентиры, если есть сигнал

-                DetProj PriceDataArray, DenmarkDataArray

-            End If

-'5)   Write result

-            Application.ScreenUpdating = False

-    

-'6)    Clear interface tables

-            ClearResultTables

-            

-            ResultLinesOut Location:=TheRange.Offset(2, 0), pPD:=PriceDataArray, pDen:=DenmarkDataArray

-            

-            With .Worksheets(FORM_SHEET)

-                Out_Table_1 TheRange:=.Range(TABLE_1).Cells(1, 1), pDen:=DenmarkDataArray, LastIdx:=PriceDataArray.tC

-                Out_Table_2 _

-                        TheRange:=.Range(TABLE_2).Cells(1, 1), _

-                        TheComment:=.Range("TABLE_COMMENT"), _

-                        pPD:=PriceDataArray, _

-                        pDen:=DenmarkDataArray

-                Out_Table_3 TheRange:=.Range(TABLE_3).Cells(1, 1), pDen:=DenmarkDataArray

-                Out_Table_4 TheRange:=.Range(TABLE_4).Cells(1, 1), pPD:=PriceDataArray

-                With .Range(TABLE_1)

-                    .Font.name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-                With .Range(TABLE_2)

-                    .Font.name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-                With .Range(TABLE_3)

-                    .Font.name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-                With .Range(TABLE_4)

-                    .Font.name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-            End With

-            .Worksheets(VAR_SHEET).Range("BOOL_DEMARK_READY") = True

-        Else

-            MsgBox _

-                Prompt:="Недостаточна глубина выборки данных." _

-                    & vbCrLf & "Измените параметры запроса и пробуйте снова.", _

-                Buttons:=vbOKOnly + vbExclamation, _

-                Title:=PROGRAM_NAME

-            .Worksheets(VAR_SHEET).Range("BOOL_DEMARK_READY") = False

-            .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False

-        End If

-'7)   Free unused memory

-        free_unused_memory PriceDataArray, DenmarkDataArray

-    End With

-End Function

-

-Sub allocate_memory(pPriceData As TPriceData, pDenmarkData As TDenmark, memsize As Integer)

-'  Память под TDenmark

-    ReDim pDenmarkData.ResistanceLine(1 To memsize)

-    ReDim pDenmarkData.ResistancePoints(1 To memsize)

-    ReDim pDenmarkData.SupportLine(1 To memsize)

-    ReDim pDenmarkData.SupportPoints(1 To memsize)

-   

-' Инициализация данных по ценам

-    pPriceData.tC = memsize

-    ReDim pPriceData.D(1 To memsize)

-    ReDim pPriceData.Tm(1 To memsize)

-    ReDim pPriceData.Opn(1 To memsize)

-    ReDim pPriceData.Hgh(1 To memsize)

-    ReDim pPriceData.Lw(1 To memsize)

-    ReDim pPriceData.Cls(1 To memsize)

-    ReDim pPriceData.Vl(1 To memsize)

-

-End Sub

-

-Sub free_unused_memory(pP As TPriceData, pD As TDenmark)

-'   Free Prices

-    pP.tC = 0

-    Erase pP.D

-    Erase pP.Tm

-    Erase pP.Opn

-    Erase pP.Hgh

-    Erase pP.Lw

-    Erase pP.Cls

-    Erase pP.Vl

-    

-'Free TDenmark

-    Erase pD.ResistanceLine

-    Erase pD.ResistancePoints

-    Erase pD.SupportLine

-    Erase pD.SupportPoints

-End Sub

-

-

-'*****************************************

-Sub DetDenmark(pPriceData As TPriceData, pDenmarkData As TDenmark, ByVal ClosePrev2 As Boolean, ByVal CloseSucc1 As Boolean)

-' определение элементов данных Денмарка (в цифровой форме)

-' на текущий момент времени времени tC

-' ИСХОДНЫЕ ДАННЫЕ:

-' pPriceData  - окно, стандартная форма данных по ценам (определена)

-' ClosePrev2 - H(t) > max{ H(t-1), H(t+1)} и  H(t) > Close(t-2)

-' CloseSucc1 - H(t) > max{ H(t-1), H(t+1)}  и  R(t+1) > Close(t+1)

-' РЕЗУЛЬТАТ:

-' pDenmarkData - элементы данных Денмарка (память выделена, SignalParameter - определен):

-' линии ResistanceLine,SupportLine их наклоны, опорные точки, сигналы к покупке или продаже

-' SignalValue = 0 сигнал отсутствует

-' SignalValue < 0 прорыв восходящего тренда (сигнал продажи)

-' SignalValue > 0 прорыв нисходящего тренда (сигнал покупки)

-' Если pDenmarkData.ResistancePointCount < 2, то элементы ResistanceLine не определяются

-' Если pDenmarkData.SupportPointsCount < 2, то элементы SupportLine не определяются

-

-' начальная установка

-    Const QUALIFICATOR_DISABLE As String = "-"

-    Const QUALIFICATOR_ENABLE As String = "Signal"

-    

-    Dim UpQual(1 To 3) As String

-    Dim DownQual(1 To 3) As String

-    Dim UpSignal, DownSignal As Integer

-    Dim i As Integer

-    

-    pDenmarkData.SignalValue = 0

-    UpSignal = 0

-    DownSignal = 0

-    

-    For i = 1 To 3

-        pDenmarkData.Qualificator(i) = QUALIFICATOR_DISABLE

-        UpQual(i) = QUALIFICATOR_DISABLE

-        DownQual(i) = QUALIFICATOR_DISABLE

-    Next i

-    

-' определение линии поддержки и сопротивления

-    ResLine _

-        pPriceData, _

-        pPriceData.tC, _

-        pDenmarkData.ResistancePointCount, _

-        pDenmarkData.ResistanceLine, _

-        pDenmarkData.ResistancePoints, _

-        ClosePrev2, _

-        CloseSucc1

-        

-    SuppLine _

-        pPriceData, _

-        pPriceData.tC, _

-        pDenmarkData.SupportPointsCount, _

-        pDenmarkData.SupportLine, _

-        pDenmarkData.SupportPoints, _

-        ClosePrev2, _

-        CloseSucc1

-

-        

-        

-    If pDenmarkData.ResistancePointCount >= 2 Then

-        pDenmarkData.ResistanceAngle = 57.29578 * _

-            Atn(pDenmarkData.ResistanceLine(pPriceData.tC) - _

-                pDenmarkData.ResistanceLine(pPriceData.tC - 1))

-    End If

-    If pDenmarkData.SupportPointsCount >= 2 Then

-        pDenmarkData.SupportAngle = 57.29578 * _

-            Atn(pDenmarkData.SupportLine(pPriceData.tC) - _

-                pDenmarkData.SupportLine(pPriceData.tC - 1))

-    End If

-

-' ФОРМИРОВАНИЕ СИГНАЛА ----------------------------------

-    Dim t As Integer

-' 1. случай нисходящего тренда: ResistanceLine определен и ResistanceLine падает *************

-    If pDenmarkData.ResistancePointCount >= 2 And pDenmarkData.ResistanceAngle < 0 Then

-'    необходимое условие прорыва вверх

-        If pDenmarkData.ResistanceLine(pPriceData.tC) < pPriceData.Cls(pPriceData.tC) Then

-            UpSignal = 1

-            For t = pPriceData.tC - pDenmarkData.SignalParameter To pPriceData.tC - 1

-                If pPriceData.Cls(t) > pDenmarkData.ResistanceLine(t) Then

-                    UpSignal = 0

-                    Exit For

-                End If

-            Next t

-        End If

-        If UpSignal = 1 Then

-'       Qualificator-1: close убывает накануне прорыва

-            If pPriceData.Cls(pPriceData.tC - 2) > pPriceData.Cls(pPriceData.tC - 1) Then

-                UpSignal = UpSignal + 1

-                UpQual(1) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-2: open > ResistanceLine в момент прорыва

-            If pPriceData.Opn(pPriceData.tC) > pDenmarkData.ResistanceLine(pPriceData.tC) Then

-                UpSignal = UpSignal + 1

-                UpQual(2) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-3 - demand value < ResistanceLine(tC)

-            If 2 * pPriceData.Cls(pPriceData.tC - 1) - pPriceData.Lw(pPriceData.tC - 1) < pDenmarkData.ResistanceLine(pPriceData.tC) Then

-                UpSignal = UpSignal + 1

-                UpQual(3) = QUALIFICATOR_ENABLE

-            End If

-        End If

-    End If  ' нисходящий тренд обработан ************************************

-

-' 2. случай восходящего тренда: SupportLine определен и SupportLine растет

-    If pDenmarkData.SupportPointsCount >= 2 And pDenmarkData.SupportAngle > 0 Then

-'    ---------------------------------------------

-'    необходимое условие прорыва вниз

-        If pPriceData.Cls(pPriceData.tC) < pDenmarkData.SupportLine(pPriceData.tC) Then

-            DownSignal = -1

-            For t = pPriceData.tC - pDenmarkData.SignalParameter To pPriceData.tC - 1

-                If pPriceData.Cls(t) < pDenmarkData.SupportLine(t) Then

-                    DownSignal = 0

-                    Exit For

-                End If

-            Next t

-        End If

-        If DownSignal = -1 Then

-'       Qualificator-1: Close растет накануне прорыва

-            If pPriceData.Cls(pPriceData.tC - 2) < pPriceData.Cls(pPriceData.tC - 1) Then

-                DownSignal = DownSignal - 1

-                DownQual(1) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-2: Open ниже ResistanceLine в момент прорыва

-            If pPriceData.Opn(pPriceData.tC) < pDenmarkData.SupportLine(pPriceData.tC) Then

-                DownSignal = DownSignal - 1

-                DownQual(2) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-3 - supply value(t-1) > SupportLine(tC)

-            If 2 * pPriceData.Cls(pPriceData.tC - 1) - pPriceData.Hgh(pPriceData.tC - 1) > pDenmarkData.SupportLine(pPriceData.tC) Then

-                DownSignal = DownSignal - 1

-                DownQual(3) = QUALIFICATOR_ENABLE

-            End If

-        End If

-'    ---------------------------------------------

-    End If

-'      Существует преобладание тенденции

-    If Abs(DownSignal) <> UpSignal Then

-        If Abs(DownSignal) > UpSignal Then

-            pDenmarkData.SignalValue = DownSignal

-            For i = 1 To 3

-                pDenmarkData.Qualificator(i) = DownQual(i)

-            Next i

-        Else

-            pDenmarkData.SignalValue = UpSignal

-            For i = 1 To 3

-                pDenmarkData.Qualificator(i) = UpQual(i)

-            Next i

-        End If

-    End If

-End Sub

-

-Sub DetProj(pPriceData As TPriceData, pDenmarkData As TDenmark)

-'Определение проекции при наличии сигнала: |Signal| > 1

-'Услловие применимости |Signal| > 1 !!!

-    Dim pM As Double, t As Integer, Tm As Integer, tL As Integer

-

-    If pDenmarkData.SignalValue >= 2 Then  ' СИГНАЛ ПОКУПКИ

-

-        tL = pDenmarkData.ResistancePoints(pDenmarkData.ResistancePointCount)     ' tR determination

-        If tL = pPriceData.tC Then

-            tL = pDenmarkData.ResistancePoints(pDenmarkData.ResistancePointCount - 1)

-        End If

-

-'  Projections 1,2 --------------------------------------------

-        If pDenmarkData.ProjectNumber >= 1 And pDenmarkData.ProjectNumber <= 2 Then

-'           t* = Arg min {L(t) : t R <= t  <= tb ,  L(t) < ResistanceLine(t)},

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Lw(Tm) ' L(t-1) < ResistanceLine(t-1) for t - break point !

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Lw(t) < pM And pPriceData.Lw(t) < pDenmarkData.ResistanceLine(t) Then

-                    pM = pPriceData.Lw(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            If pDenmarkData.ProjectNumber = 1 Then

-'               P1( tb) = ResistanceLine(tb) + ResistanceLine(t*) - L(t*)

-                pDenmarkData.ProjectPrice = pDenmarkData.ResistanceLine(pPriceData.tC) + pDenmarkData.ResistanceLine(Tm) - pPriceData.Lw(Tm)

-            Else

-                pDenmarkData.ProjectPrice = pDenmarkData.ResistanceLine(pPriceData.tC) + pDenmarkData.ResistanceLine(Tm) - pPriceData.Cls(Tm)

-            End If

-        End If ' pDenmarkData.ProjectNumber >= 1 And pDenmarkData.ProjectNumber <= 2

-   

-'  ----------------------------------------------------------------

-'  Projections 3

-        If pDenmarkData.ProjectNumber = 3 Then

-'           t*  = Arg min { С(t) : t R <= t  <= tb ,  C(t) < ResistanceLine(t)}

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Cls(Tm)

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Cls(t) < pM And pPriceData.Cls(t) < pDenmarkData.ResistanceLine(t) Then

-                    pM = pPriceData.Cls(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            pDenmarkData.ProjectPrice = pDenmarkData.ResistanceLine(pPriceData.tC) + pDenmarkData.ResistanceLine(Tm) - pPriceData.Cls(Tm)

-        End If

-    End If ' pDenmarkData.SignalValue >= 2

-

-'-------------------------------------------------------------------

-'*******************************************************************

-' ПРОЕКЦИЯ ДЛЯ СИГНАЛА ПРОДАЖИ

-    If pDenmarkData.SignalValue <= -2 Then

-        tL = pDenmarkData.SupportPoints(pDenmarkData.SupportPointsCount)  ' tR determination

-        If tL = pPriceData.tC Then

-            tL = pDenmarkData.ResistancePoints(pDenmarkData.SupportPointsCount - 1)

-        End If

-

-'  Projections 1,2 --------------------------------------------

-        If pDenmarkData.ProjectNumber = 1 Or pDenmarkData.ProjectNumber = 2 Then

-'           t* = Arg max {H(t) : t R <= t  <= tb ,  H(t) > SupportLine(t)},

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Hgh(Tm) ' H(t-1) > SupportLine(t-1) for t - break point !

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Hgh(t) > pM And pPriceData.Hgh(t) > pDenmarkData.SupportLine(t) Then

-                    pM = pPriceData.Hgh(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            If pDenmarkData.ProjectNumber = 1 Then

- '              P1( tb) = SupportLine(tb) + SupportLine(t*) - H(t*)

-                pDenmarkData.ProjectPrice = pDenmarkData.SupportLine(pPriceData.tC) + pDenmarkData.SupportLine(Tm) - pPriceData.Hgh(Tm)

-            Else

-'               P2( tb) = SupportLine(tb) + SupportLine(t*) - C(t*)

-                pDenmarkData.ProjectPrice = pDenmarkData.SupportLine(pPriceData.tC) + pDenmarkData.SupportLine(Tm) - pPriceData.Cls(Tm)

-            End If

-        End If

-   

-'  ----------------------------------------------------------------

-'  Projections 3

-        If pDenmarkData.ProjectNumber = 3 Then

-'           t*  = Arg max { С(t) : t R <= t  <= tb ,  C(t) >  SupportLine(t)}

-'           P3( tb) = SupportLine(tb) + SupportLine(t*) - C(t*)

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Cls(Tm)

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pM < pPriceData.Cls(t) And pPriceData.Cls(t) > pDenmarkData.SupportLine(t) Then

-                    pM = pPriceData.Cls(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            pDenmarkData.ProjectPrice = pDenmarkData.SupportLine(pPriceData.tC) + pDenmarkData.SupportLine(Tm) - pPriceData.Cls(Tm)

-        End If

-    End If ' pDenmarkData.SignalValue <= -2

-End Sub

-

-Sub ResLine(pP As TPriceData, tE As Integer, ResistancePointCount As Integer, _

-            ResistanceLine() As Double, s() As Integer, ClosePrev2 As Boolean, CloseSucc1 As Boolean)

-' Определение линии сопротивления по Демарку [1]

-' Основной вариант

-' ИСХОДНЫЕ ДАННЫЕ:

-' High, dom(High) = [1, tE]

-' ClosePrev2 - H(t) > max{ H(t-1), H(t+1)} и  H(t) > Close(t-2)

-' CloseSucc1 - H(t) > max{ H(t-1), H(t+1)}  и  R(t+1) > Close(t+1)

-' РЕЗУЛЬТАТ:

-' 1) линия сопротивления ResistanceLine, dom(ResistanceLine)=[s(1), tE], и

-' 2) s = {s(1), s(2), ..., s(ResistancePointCount)}, s(1) < s(2) < ...< s(ResistancePointCount)

-'   ( s(ResistancePointCount)<= tE )- опорные точки

-' 3) число опорных точек ResistancePointCount.

-' 4) s(1) -  первый момент времени с которого определена SupportLine

-'    то есть dom{Supp} = [s(1), tC]

-' Прим. Если число опорных точек окажется < 2, то линия

-' сопротивления не определяется. В этом случае следует

-' увеличить историю tE !!!

-    Dim t As Integer, i As Integer

-    Dim v As Double

-    Dim IsGoodPoint As Boolean

-  

-'1 определение опорных моментов времени

-    ResistancePointCount = 0

-    For t = 3 To tE - 1

- '      v = max{high(t-1), high(t+1)} < high(t)}

-        v = pP.Hgh(t - 1)

-        If v < pP.Hgh(t + 1) Then

-            v = pP.Hgh(t + 1)

-        End If

-        IsGoodPoint = pP.Hgh(t) > v

-        If IsGoodPoint And ClosePrev2 Then

-            IsGoodPoint = IsGoodPoint And (pP.Cls(t - 2) < pP.Hgh(t))

-        End If

-        

-        If IsGoodPoint Then       'alt.: v >= High(t + 1)

-            s(ResistancePointCount + 1) = t: ResistancePointCount = ResistancePointCount + 1

-        End If

-    Next t

-    

-loop_:

-    

-    If ResistancePointCount < 2 Then

-        GoTo done

-    End If

-

-' 2 определение линии сопротивления

-    ResistanceLine(s(1)) = pP.Hgh(s(1))

-    For i = 2 To ResistancePointCount

-        ResistanceLine(s(i)) = pP.Hgh(s(i))

-        v = (pP.Hgh(s(i)) - pP.Hgh(s(i - 1))) / (s(i) - s(i - 1))

-        For t = s(i - 1) + 1 To s(i) - 1

-            ResistanceLine(t) = pP.Hgh(s(i - 1)) + v * (t - s(i - 1))

-        Next t

-    Next i

-    If s(ResistancePointCount) < tE Then

-        v = (pP.Hgh(s(ResistancePointCount)) - pP.Hgh(s(ResistancePointCount - 1))) / (s(ResistancePointCount) - s(ResistancePointCount - 1))

-        For t = s(ResistancePointCount) + 1 To tE

-            ResistanceLine(t) = pP.Hgh(s(ResistancePointCount - 1)) + v * (t - s(ResistancePointCount - 1))

-        Next t

-    End If

-    If CloseSucc1 Then

-        For t = 1 To ResistancePointCount

-            If ResistanceLine(s(t) + 1) < pP.Cls(s(t) + 1) Then

-                ResistancePointCount = ResistancePointCount - 1

-                ' удалить точку

-                For i = t To ResistancePointCount

-                    s(i) = s(i + 1)

-                Next i

-                s(ResistancePointCount + 1) = 0

-                ' очистить массив линии

-                Dim Lb, Rb As Integer

-                Lb = LBound(ResistanceLine)

-                Rb = UBound(ResistanceLine)

-                Erase ResistanceLine

-                ReDim ResistanceLine(Lb To Rb)

-                GoTo loop_

-            End If

-        Next t

-    End If

-    

-done:

-End Sub

-

-Sub SuppLine(pP As TPriceData, tE As Integer, SupportPointsCount As Integer, _

-               SupportLine() As Double, s() As Integer, ClosePrev2 As Boolean, CloseSucc1 As Boolean)

-' Определение линии поддержки по Демарку [1] (от конца)

-' Исходные данные:

-' Low, dom(Low) = [1, tE]

-' ClosePrev2 - H(t) > max{ H(t-1), H(t+1)} и  H(t) > Close(t-2)

-' CloseSucc1 - H(t) > max{ H(t-1), H(t+1)}  и  R(t+1) > Close(t+1)

-' Результат:

-' 1) линия сопротивления SupportLine, dom(SupportLine)=[s(1), tE],

-' 2) s = {s(1), s(2), ..., s(SupportPointsCount)}, s(1) < s(2) < ...< s(SupportPointsCount) -

-'    опорные точки

-' 3) число опорных точек SupportPointsCount.

-' Прим. Если фактическое число опорных точек окажется < 2, то линия

-' поддержки не определяется.

-    Dim t As Integer, i As Integer

-    Dim v As Double

-    Dim IsGoodPoint As Boolean

-    

-'1 определение опорных моментов времени

-     SupportPointsCount = 0

-    For t = 3 To tE - 1

-'       v = min{Low(t-1), Low(t+1)} > Low(t)

-        v = pP.Lw(t - 1)

-        If v > pP.Lw(t + 1) Then

-            v = pP.Lw(t + 1)

-        End If

-        

-        IsGoodPoint = pP.Lw(t) < v

-        

-        If IsGoodPoint And ClosePrev2 Then

-            IsGoodPoint = IsGoodPoint And (pP.Cls(t - 2) > pP.Lw(t))

-        End If

-        

-        If IsGoodPoint Then     'alt.: v >= High(t + 1)

-            s(SupportPointsCount + 1) = t: SupportPointsCount = SupportPointsCount + 1

-        End If

-    Next t

-

-loop_:

-    If SupportPointsCount < 2 Then

-        GoTo done

-    End If

-' 2 определение линии поддержки

-    

-    SupportLine(s(1)) = pP.Lw(s(1))

-    For i = 2 To SupportPointsCount

-        SupportLine(s(i)) = pP.Lw(s(i))

-        v = (pP.Lw(s(i)) - pP.Lw(s(i - 1))) / (s(i) - s(i - 1))

-        For t = s(i - 1) + 1 To s(i) - 1

-            SupportLine(t) = pP.Lw(s(i - 1)) + v * (t - s(i - 1))

-        Next t

-    Next i

-    If s(1) < tE Then

-        v = (pP.Lw(s(SupportPointsCount)) - pP.Lw(s(SupportPointsCount - 1))) / (s(SupportPointsCount) - s(SupportPointsCount - 1))

-        For t = s(SupportPointsCount) + 1 To tE

-            SupportLine(t) = pP.Lw(s(SupportPointsCount - 1)) + v * (t - s(SupportPointsCount - 1))

-        Next t

-    End If

-    If CloseSucc1 Then

-        For t = 1 To SupportPointsCount

-            If SupportLine(s(t) + 1) > pP.Cls(s(t) + 1) Then

-                SupportPointsCount = SupportPointsCount - 1

-                ' удалить точку

-                For i = t To SupportPointsCount

-                    s(i) = s(i + 1)

-                Next i

-                s(SupportPointsCount + 1) = 0

-                ' очистить массив линии

-                Dim Lb, Rb As Integer

-                Lb = LBound(SupportLine)

-                Rb = UBound(SupportLine)

-                Erase SupportLine

-                ReDim SupportLine(Lb To Rb)

-                GoTo loop_

-            End If

-        Next t

-    End If

-done:

-End Sub

-

-<<<<<<
-======================
-mChart
->>>>>>
-Attribute VB_Name = "mChart"

-Option Explicit

-

-Const CHART_NAME As String = "PriceChart"

-

-Sub Draw_Chart(SignalDefined As Boolean)

-

-    Dim n As Integer

-    Dim theChart As Chart

-    Dim ChartDataAria, szLastNumber As String

-    Dim MinYScale As Double

-    

-    

-    With ThisWorkbook

-' Checking data

-' Disable screen out

-        .Application.Cursor = xlWait

-        .Application.ScreenUpdating = False

-' Create series range

-        n = GetLinesCount(Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE))

-        szLastNumber = n + 1

-        If SignalDefined Then

-            ChartDataAria = "A2:A" + szLastNumber + ",D2:E" + szLastNumber + ",I2:K" + szLastNumber

-        Else

-            ChartDataAria = "A2:A" + szLastNumber + ",D2:E" + szLastNumber + ",I2:J" + szLastNumber

-        End If

-        MinYScale = GetMinValue(.Worksheets(RAW_DATA_SHEET).Range(ChartDataAria))

-' Find and delete old chart

-        .Worksheets(CHART_SHEET).Unprotect

-        Dim WindowWidth, WindowHeight As Integer

-        With .Worksheets(CHART_SHEET)

-            WindowWidth = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-            WindowHeight = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-        End With

-        

-        

-        With .Worksheets(CHART_SHEET).ChartObjects

-            .delete

-            With .Add(5, 5, WindowWidth - 10, WindowHeight - 10)

-                .SendToBack

-                Set theChart = .Chart

-            End With

-' Create a chart

-        End With

-        With theChart

-            .ChartType = xlLine

-            .SetSourceData Source:=Sheets(RAW_DATA_SHEET).Range( _

-                    ChartDataAria), PlotBy:=xlColumns

-            .Location Where:=xlLocationAsObject, name:=CHART_SHEET

-            .HasTitle = True

-            With .ChartTitle

-                .Text = ThisWorkbook.Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE).Value

-                With .Font

-                    .Size = 8

-                    .Bold = True

-                End With

-            End With

-            .HasLegend = True

-            With .Legend

-                .Position = xlTop

-                With .Font

-                    .name = "Arial"

-                    .Size = 8

-                End With

-            End With

-            .HasDataTable = False

-            With .Axes(xlCategory)

-                .HasMajorGridlines = True

-                .HasMinorGridlines = False

-                .TickLabels.Orientation = xlUpward

-                With .MajorGridlines.Border

-                    .ColorIndex = 48

-                    .Weight = xlHairline

-                    .LineStyle = xlDot

-                End With

-                .CrossesAt = 1

-                .TickLabelSpacing = 1

-                .TickMarkSpacing = 1

-                .AxisBetweenCategories = False

-                .ReversePlotOrder = False

-                .TickLabels.AutoScaleFont = True

-                With .TickLabels.Font

-                    .name = "Arial"

-                    .Size = 8

-                End With

-            End With

-            With .Axes(xlValue)

-                .HasMajorGridlines = True

-                .HasMinorGridlines = False

-                With .MajorGridlines.Border

-                    .ColorIndex = 48

-                    .Weight = xlHairline

-                    .LineStyle = xlDot

-                End With

-                .MinimumScale = MinYScale

-                .MaximumScaleIsAuto = True

-                .MinorUnitIsAuto = True

-                .MajorUnitIsAuto = True

-                .Crosses = xlCustom

-                .CrossesAt = MinYScale

-                .ReversePlotOrder = False

-                .ScaleType = xlLinear

-                .TickLabels.AutoScaleFont = True

-                With .TickLabels.Font

-                    .name = "Arial"

-                    .Size = 9

-                End With

-            End With

-            .ChartTitle.Top = 5

-            .ChartTitle.Left = 5

-            With .Legend

-                .Top = 5

-                .Fill.OneColorGradient _

-                    Style:=msoGradientHorizontal, _

-                    Variant:=3, _

-                    Degree:=0.303913939116503

-                .Fill.Visible = True

-                .Fill.ForeColor.SchemeColor = 71

-            End With

-            .PlotArea.Left = 10

-            .PlotArea.Top = .Legend.Top + .Legend.Height + 5

-            .PlotArea.Width = .ChartArea.Width - 20

-            .PlotArea.Height = .ChartArea.Height - .PlotArea.Top

-            

-' Tune OPEN line

-            With .SeriesCollection(1)

-                .Border.LineStyle = xlNone

-                .MarkerBackgroundColorIndex = xlNone

-                .MarkerForegroundColorIndex = 1

-                .MarkerStyle = xlPlus

-                .Smooth = False

-                .MarkerSize = 9

-                .Shadow = False

-            End With

-' Tune CLOSE line

-            With .SeriesCollection(2)

-                .Border.ColorIndex = 10

-                .Border.Weight = xlMedium

-                .Border.LineStyle = xlContinuous

-            End With

-' Tune RESISTANCE line

-            With .SeriesCollection(3)

-                .Border.ColorIndex = 3

-                .Border.Weight = xlThin

-                .Border.LineStyle = xlContinuous

-            End With

-' Tune SUUPORT line

-            With .SeriesCollection(4)

-                .Border.ColorIndex = 25

-                .Border.Weight = xlThin

-                .Border.LineStyle = xlContinuous

-            End With

-            If SignalDefined Then

-                With .SeriesCollection(5)

-                    .Border.ColorIndex = 6

-                    .Border.Weight = xlThin

-                    .Border.LineStyle = xlDot

-                End With

-            End If

-        End With

-        .Application.Cursor = xlDefault

-        With .Worksheets(CHART_SHEET)

-            .Range("A1").Select

-            .Protect userInterfaceOnly:=True

-        End With

-    End With

-End Sub

-

-Function GetMinValue(DataRange As Range) As Double

-    Dim Cell As Range

-    Dim MinValue, MaxValue, RangeValue, CorrectValue, Mult As Double

-    MinValue = MAX_PRICE_VALUE

-    MaxValue = MIN_PRICE_VALUE

-    For Each Cell In DataRange

-        If Not IsEmpty(Cell) And IsNumeric(Cell) Then

-            If Cell > MIN_PRICE_VALUE Then

-                If Cell < MinValue Then

-                    MinValue = Cell

-                End If

-                If Cell > MaxValue Then

-                    MaxValue = Cell

-                End If

-            End If

-        End If

-    Next

-    RangeValue = MaxValue - MinValue

-    If RangeValue < 0 Then

-        MinValue = 0

-    Else

-        CorrectValue = RangeValue / 4

-        Mult = MIN_PRICE_VALUE

-        While MinValue - Int(MinValue * Mult) / Mult > CorrectValue

-            Mult = Mult * 10

-        Wend

-        MinValue = Int(MinValue * Mult) / Mult

-    End If

-    GetMinValue = MinValue

-End Function

-

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub GetState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars("Worksheet Menu Bar").Visible = False

-End Sub

-

-

-Public Sub RestoreState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars("Worksheet Menu Bar").Visible = True

-End Sub

-

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{35D51C1F-97FA-4A43-AFD8-907E207B8623}{337D4835-40CC-4F14-BAEB-0008DC0F4CDA}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub CommandButton1_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mWebQeury
->>>>>>
-Attribute VB_Name = "mWebQeury"

-Option Explicit

-

-Public Const Qry_DELETE_ALL As String = "Qry_DELETE_ALL"

-Public Const Qry_PATH_NO_CHANGE As String = "Qry_PATH_NO_CHANGE"

-

-

-Sub QryCreate(QryRange As Range, QryName As String, QryPath As String, Optional RefreshBkgnd = False)

-    Dim WebQuery As QueryTable

-    QryDelete QryRange:=QryRange, QryName:=QryName

-    

-    Set WebQuery = QryRange.Worksheet.QueryTables.Add( _

-            Connection:=QryPath, _

-            Destination:=QryRange)

-    

-    With WebQuery

-        .FieldNames = False

-        .name = QryName

-        .RefreshStyle = xlOverwriteCells

-        .RowNumbers = False

-        .FillAdjacentFormulas = False

-        .RefreshOnFileOpen = False

-        .HasAutoFormat = False

-        .BackgroundQuery = False

-        .TablesOnlyFromHTML = False

-        .Refresh BackgroundQuery:=RefreshBkgnd

-        .SavePassword = False

-        .SaveData = True

-    End With

-End Sub

-

-Function QryRefresh(QryRange As Range, QryName As String, Optional QryPath As String = Qry_PATH_NO_CHANGE, Optional Background As Boolean = False) As Boolean

-    Dim qry_result As Boolean

-    qry_result = False

-    If QryExist(QryRange, QryName) Then

-        With QryRange.Worksheet.QueryTables(QryName)

-            If QryPath <> Qry_PATH_NO_CHANGE Then

-                .Connection = QryPath

-            End If

-            .Refresh BackgroundQuery:=Background

-            qry_result = True

-        End With

-    End If

-    QryRefresh = qry_result

-End Function

-

-Sub QryDelete(QryRange As Range, Optional QryName As String = Qry_DELETE_ALL)

-    Dim WebQuery As QueryTable

-    For Each WebQuery In QryRange.Worksheet.QueryTables

-        If QryName = Qry_DELETE_ALL Or WebQuery.name = QryName Then

-            WebQuery.delete

-        End If

-    Next

-End Sub

-

-Function QryExist(QryRange As Range, QryName As String) As Boolean

-    Dim WebQuery As QueryTable

-    For Each WebQuery In QryRange.Worksheet.QueryTables

-        If WebQuery.name = QryName Then

-            QryExist = True

-            Exit For

-        End If

-    Next

-End Function

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Sub CreateCommandBar(theApp As Application)

-Attribute CreateCommandBar.VB_ProcData.VB_Invoke_Func = "R\n14"

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible + msoBarNoCustomize + msoBarNoMove + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Print"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 4

-                        .OnAction = "cmPrint"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Contents"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 49

-                        .OnAction = "cmHelpContents"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible + msoBarNoCustomize + msoBarNoMove + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(Flag As Boolean)

-    If Flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars("Worksheet Menu Bar")

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim curdate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    curdate = year * 10000

-    curdate = curdate + month * 100

-    curdate = curdate + day

-    If curdate > end_date Then

-        cmAbout

-        cmHelpContents

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mTool
->>>>>>
-Attribute VB_Name = "mTool"

-Option Explicit

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub tool_delete_all_tables()

-    QryDelete ThisWorkbook.Worksheets(RAW_DATA_SHEET).Range("A1")

-End Sub

-

-Sub tool_delete_all_charts(theSheet As Worksheet)

-    Dim theChart As Chart

-    For Each theChart In theSheet

-        theChart.Unprotect

-        theChart.delete

-    Next

-End Sub

-

-Sub DateTimeTest()

-    Dim the_date

-    Dim the_time

-    the_date = DateValue(Now)

-    the_time = TimeValue(Now)

-End Sub

-

-

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{D9A1733C-82C5-4284-875F-95D7994101E1}{8ACF2A5D-5534-489E-8C57-88CB97F9CEEB}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-

-Private Sub App_WorkbookOpen(ByVal wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If Application.Workbooks.count > 1 Then

-        wbname = wb.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKCancel, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            wb.Close Savechanges:=False

-        End If

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-mDataCommands
->>>>>>
-Attribute VB_Name = "mDataCommands"

-Option Explicit

-

-Sub evFileOpen()

-    Dim fileToOpen As String

-    Dim wb As Workbook

-    Dim ticker As String

-    Dim Result As Integer

-

-    fileToOpen = Application.GetOpenFilename("Text Files (*.txt), *.txt")

-    Set wb = ThisWorkbook

-    With wb

-        If fileToOpen <> "False" Then

-            If .Worksheets(VAR_SHEET).Range("BOOL_AUTORECALC") = True Then

-                .Worksheets(VAR_SHEET).Range("BOOL_AUTORECALC") = False

-            End If

-            .Worksheets(FORM_SHEET).Range(FILE_NAME) = fileToOpen

-            Result = UpdateHistoryFromFile(wb, fileToOpen)

-            .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False

-            .Worksheets(VAR_SHEET).Range("BOOL_DEMARK_READY") = False

-            

-            ClearResultTables

-            

-            Select Case Result

-                Case FUNCRES_FILE_OK

-                    .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = True

-                    If TDenmark_Calc Then

-                        With .Worksheets(RAW_DATA_SHEET)

-                            ticker = .Range("B1")

-                        End With

-                        With .Worksheets(FORM_SHEET)

-                            .Range("CALC_TICKER_NAME") = ticker

-                        End With

-                    End If

-                Case FUNCRES_FILE_VERY_SMALL

-                    .Worksheets(FORM_SHEET).Range("CALC_TICKER_NAME") = MSG_FILE_VERY_SMALL

-                    MsgBox MSG_FILE_VERY_SMALL, vbOKOnly, PROGRAM_NAME

-                Case FUNCRES_FILE_INVALID_FORMAT

-                    .Worksheets(FORM_SHEET).Range("CALC_TICKER_NAME") = MSG_FILE_INVALID_FORMAT

-                    MsgBox MSG_FILE_INVALID_FORMAT, vbOKOnly, PROGRAM_NAME

-                End Select

-            .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False

-        End If

-    End With 'wb

-End Sub

-

-Sub evSubmit_Click()

-    Dim ticker As String

-

-    Application.Cursor = xlWait

-    Dim wb As Workbook

-    Set wb = ThisWorkbook

-    With wb

-        With .Worksheets(VAR_SHEET)

-            ticker = .Range("DEN_SYMBOL")

-            If .Range("BOOL_DATA_READY") = False Or .Range("BOOL_LOAD_DATA") = True Then

-                .Range("BOOL_DATA_READY") = UpdateHistoryFromWeb(wb)

-            End If

-            .Range("BOOL_DEMARK_READY") = False

-        End With

-        If TDenmark_Calc Then

-            With .Worksheets(FORM_SHEET)

-                .Range("CALC_TICKER_NAME") = ticker

-                .Range("FILE_NAME") = ""

-            End With

-        End If

-    End With

-    Application.Cursor = xlDefault

-End Sub

-

-Sub evTicker_Change()

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("IDX_DEN_SECNAME") = .Range("IDX_DEN_SYMBOL")

-    End With

-    evHistory_Change

-End Sub

-

-Sub evSecName_Change()

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("IDX_DEN_SYMBOL") = .Range("IDX_DEN_SECNAME")

-    End With

-    evHistory_Change

-End Sub

-

-Sub evHistory_Change()

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("BOOL_DATA_READY") = False

-    End With

-End Sub

-

-Sub evGroupChange()

-    Dim GroupIdx, LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange As String

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        GroupIdx = .Range("IDX_DEN_LIST")

-        .Range("IDX_DEN_SYMBOL") = 1

-        NewRangeOffsetCol = (GroupIdx - 1) * 2

-        LinesCount = GetLinesCount(.Range("TICKER_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .name & "!" & .Range(.Range("TICKER_TABLES").Offset(1, NewRangeOffsetCol), .Range("TICKER_TABLES").Offset(LinesCount, NewRangeOffsetCol)).Address

-        ThisWorkbook.Worksheets(FORM_SHEET).Shapes("cbxTikers").ControlFormat.ListFillRange = NewCbxRange

-        NewRangeOffsetCol = NewRangeOffsetCol + 1

-        NewCbxRange = .name & "!" & .Range(.Range("TICKER_TABLES").Offset(1, NewRangeOffsetCol), .Range("TICKER_TABLES").Offset(LinesCount, NewRangeOffsetCol)).Address

-        ThisWorkbook.Worksheets(FORM_SHEET).Shapes("cbxSecName").ControlFormat.ListFillRange = NewCbxRange

-    End With

-    evTicker_Change

-End Sub

-

-Sub evUpdateTickerList()

-    UpdateTickerList ThisWorkbook

-    evHistory_Change

-End Sub

-<<<<<<
-======================
-mGetFileData
->>>>>>
-Attribute VB_Name = "mGetFileData"

-Option Explicit

-

-Dim mobjAppRunEnable As New cEnableRun

-

-Public Const MAX_LOAD_DATA_LINES As Integer = 16000

-

-Public Const MSG_FILE_VERY_SMALL As String = "В файле недостаточно данных"

-Public Const MSG_FILE_INVALID_FORMAT As String = "Неверный формат файла"

-

-Public Const FUNCRES_FILE_OK As Integer = 0

-Public Const FUNCRES_FILE_VERY_SMALL As Integer = -1

-Public Const FUNCRES_FILE_INVALID_FORMAT As Integer = -2

-

-Function UpdateHistoryFromFile(wb As Workbook, fileToOpen As String) As Integer

-    Dim DestRangeName As String

-    Dim ResultLength As Integer

-    Dim Location As Range

-    Dim denWindow As Integer

-    Dim IsIntraday As Boolean

-    Dim CalcNextTime As Boolean

-        

-    Dim SingleFileLine As String

-    Dim FileHandler As Integer

-    Dim i, j, row_idx As Integer

-    

-    UpdateHistoryFromFile = FUNCRES_FILE_INVALID_FORMAT

-    With wb

-        .Application.ScreenUpdating = False

-        With .Worksheets(VAR_SHEET)

-            CalcNextTime = .Range("BOOL_NEXT_TIME")

-            denWindow = .Range("DEN_WINDOW") + 1

-            If CalcNextTime Then

-                denWindow = denWindow + 1

-            End If

-            IsIntraday = True

-        End With

-        With .Worksheets(RAW_DATA_SHEET)

-            'Clear table include temp area

-            .Parent.Application.DisplayAlerts = False

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW - 1, RAW_DATA_RANGE_COL - 1), _

-                .Cells(65535, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-            ).ClearContents

-            Set Location = .Range(RAW_DATA_RANGE).Offset(-1, 0)

-            

-            ' Reading data from file

-            FileHandler = FreeFile

-            row_idx = 0

-            Open fileToOpen For Input As #FileHandler

-            Do While Not EOF(FileHandler) And row_idx < MAX_LOAD_DATA_LINES

-                Line Input #FileHandler, SingleFileLine

-                .Range(PRICE_TABLE).Offset(row_idx, 0) = SingleFileLine

-                row_idx = row_idx + 1

-            Loop

-            Close #FileHandler

-            

-            ' Parsing data

-            DestRangeName = "=" & RAW_DATA_SHEET & "!$B$1:$B" & row_idx

-            ResultLength = row_idx

-            

-            .Range(DestRangeName).TextToColumns _

-                Destination:=.Range(DestRangeName), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=True, _

-                Semicolon:=True, _

-                Comma:=True, _

-                Space:=False, _

-                Other:=False, _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 1), _

-                                Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1))

-            

-            .Parent.Application.DisplayAlerts = True

-            Dim CurrentDate As String

-            Dim RawData As Range

-            

-            Set RawData = .Range(RAW_DATA_RANGE)

-            

-            If Not CheckFileFormat(RawData.Offset(-1, 0)) Then

-                UpdateHistoryFromFile = FUNCRES_FILE_INVALID_FORMAT

-                Exit Function

-            End If

-            

-            row_idx = 0

-            With RawData

-                CurrentDate = .Value

-                For i = 1 To ResultLength

-                    If Not IsIntraday And CurrentDate = .Offset(i, DATE_IDX).Value Then

-                        ' skip virtual prices

-                        If (.Offset(i, VOLUME_IDX) > MIN_PRICE_VALUE) Then

-                            If .Offset(row_idx, HIGH_IDX).Value < .Offset(i, HIGH_IDX).Value Then

-                                .Offset(row_idx, HIGH_IDX).Value = .Offset(i, HIGH_IDX).Value

-                            End If

-                            If .Offset(row_idx, LOW_IDX).Value > .Offset(i, LOW_IDX).Value Then

-                                .Offset(row_idx, LOW_IDX).Value = .Offset(i, LOW_IDX).Value

-                            End If

-                            .Offset(row_idx, VOLUME_IDX).Value = _

-                                .Offset(row_idx, VOLUME_IDX).Value + .Offset(i, VOLUME_IDX).Value

-                            .Offset(row_idx, TIME_IDX).Value = .Offset(i, TIME_IDX).Value

-                            .Offset(row_idx, CLOSE_IDX).Value = .Offset(i, CLOSE_IDX).Value

-                        End If

-                    Else

-                        ' skip virtual prices

-                        If (.Offset(row_idx, VOLUME_IDX) > MIN_PRICE_VALUE) Then

-                            row_idx = row_idx + 1

-                        End If

-                        For j = DATE_IDX To VOLUME_IDX

-                            .Offset(row_idx, j) = .Offset(i, j)

-                        Next j

-                        CurrentDate = .Offset(i, DATE_IDX)

-                    End If

-                Next i

-            End With ' RawData

-            ' Clear unused Cells

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(65536, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-            ).ClearContents

-            

-            If row_idx > denWindow Then

-                row_idx = row_idx - denWindow

-                .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-                ).delete xlShiftUp

-            Else

-                UpdateHistoryFromFile = FUNCRES_FILE_VERY_SMALL

-                Exit Function

-            End If

-            

-            row_idx = denWindow + 1

-            

-            Set Location = .Range( _

-                .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_IDX) _

-            )

-            

-            Location.TextToColumns _

-                Destination:=Location.Offset(0, DATE_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:="/", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2))

-            

-            Location.Offset(0, TIME_IDX).TextToColumns _

-                Destination:=Location.Offset(0, TIME_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:=":", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2))

-            

-            ' Check estimation date

-            

-            Dim end_date, end_time As Date

-            Dim year, month, day As Integer

-            Dim hour, minute As Integer

-            Dim next_time_exist As Boolean

-            

-            year = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 3)

-            month = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 2)

-            day = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 1)

-            hour = Location.Cells(denWindow - 1, TIME_STAMP_OFFSET + 1)

-            minute = Location.Cells(denWindow - 1, TIME_STAMP_OFFSET + 2)

-            

-            next_time_exist = day + month + year <> 0

-            

-            If next_time_exist Then

-                end_date = DateSerial(year, month, day)

-                end_time = TimeSerial(hour, minute, 0)

-                mobjAppRunEnable.EnableRun ESTIMATION_DATE, end_date

-            End If

-             

-            row_idx = 0

-            Dim temp_str As String

-                    

-            If IsIntraday Then

-                Do While IsEmpty(Location.Cells(1 + row_idx, 1 + DATE_IDX)) = False

-                       temp_str = Location.Cells(1 + row_idx, 1 + PROJECT_IDX + 1)

-                       temp_str = temp_str & "/"

-                       temp_str = temp_str & Location.Cells(1 + row_idx, 1 + PROJECT_IDX + 2)

-                       temp_str = temp_str & "-"

-                       temp_str = temp_str & Location.Cells(1 + row_idx, 1 + TIME_IDX)

-                       Location.Cells(1 + row_idx, DATE_IDX) = temp_str

-                       row_idx = row_idx + 1

-                Loop

-                row_idx = row_idx - 1

-                Dim condition As Boolean

-                condition = Not CalcNextTime And next_time_exist And end_date = DateValue(Now) And end_time > TimeValue(Now)

-                If condition Then

-                    .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL - 1), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-                    ).delete xlShiftUp

-                End If

-            End If

-        End With ' .Worksheets(RAW_DATA_SHEET)

-    End With ' wb

-    UpdateHistoryFromFile = FUNCRES_FILE_OK

-End Function

-

-Function CheckFileFormat(HeaderString As Range) As Boolean

-    With HeaderString

-        CheckFileFormat = _

-            .Offset(0, DATE_IDX) = "Date" And _

-            .Offset(0, TIME_IDX) = "Time" And _

-            .Offset(0, OPEN_IDX) = "Open" And _

-            .Offset(0, CLOSE_IDX) = "Close" And _

-            .Offset(0, LOW_IDX) = "Low" And _

-            .Offset(0, HIGH_IDX) = "High" And _

-            .Offset(0, VOLUME_IDX) = "Volume"

-    End With

-End Function

-<<<<<<
-Project Name : 'Denmark_method'
-Quirk - duff tag length======================
-MGetWebData
->>>>>>
-Attribute VB_Name = "MGetWebData"

-Option Explicit

-

-Const DATE_STAMP_OFFSET = PROJECT_IDX + 1

-Const TIME_STAMP_OFFSET = PROJECT_IDX + 4

-Const DATE_TIME_STAMP_SIZE = 5

-

-Dim mobjAppRunEnable As New cEnableRun

-

-Const QueryDataName As String = "ExternalDenmarkData"

-

-Function UpdateHistory(wb As Workbook) As Boolean

-    Dim DestRangeName As String

-    Dim ResultLength As Integer

-    Dim QryPathStr As String

-    Dim Location As Range

-    Dim denWindow As Integer

-    Dim IsIntraday As Boolean

-    Dim CalcNextTime As Boolean

-        

-    UpdateHistory = False

-    QryPathStr = GetQryPath(wb)

-    With wb

-        .Application.ScreenUpdating = False

-        With .Worksheets(VAR_SHEET)

-            DestRangeName = .Range("DEN_SYMBOL")

-            CalcNextTime = .Range("BOOL_NEXT_TIME")

-            denWindow = .Range("DEN_WINDOW") + 1

-            If CalcNextTime Then

-                denWindow = denWindow + 1

-            End If

-            IsIntraday = IsNumeric(.Range("DEN_TIME"))

-        End With

-        With .Worksheets(RAW_DATA_SHEET)

-            .Range(PRICE_TABLE) = DestRangeName

-            'Clear table include temp area

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW - 1, RAW_DATA_RANGE_COL - 1), _

-                .Cells(65535, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-            ).ClearContents

-            Set Location = .Range(RAW_DATA_RANGE).Offset(-1, 0)

-            If Not QryExist(Location, QueryDataName) Then

-                QryCreate Location, QueryDataName, QryPathStr

-            Else

-                QryRefresh Location, QueryDataName, QryPathStr

-            End If

-            With Location.Worksheet.QueryTables(QueryDataName)

-                DestRangeName = .ResultRange.name.RefersTo

-                ResultLength = .ResultRange.count

-            End With

-    

-    '        .Parent.Application.DisplayAlerts = False

-            

-            .Range(DestRangeName).TextToColumns _

-                Destination:=.Range(DestRangeName), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=True, _

-                Semicolon:=True, _

-                Comma:=True, _

-                Space:=False, _

-                Other:=False, _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 1), _

-                                Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1))

-            

-    '        .Parent.Application.DisplayAlerts = True

-            Dim i, j, row_idx As Integer

-            Dim CurrentDate As String

-            Dim RawData As Range

-            

-            Set RawData = .Range(RAW_DATA_RANGE)

-            row_idx = 0

-            With RawData

-                CurrentDate = .Value

-                For i = 1 To ResultLength

-                    If Not IsIntraday And CurrentDate = .Offset(i, DATE_IDX).Value Then

-                        ' skip virtual prices

-                        If (.Offset(i, VOLUME_IDX) > MIN_PRICE_VALUE) Then

-                            If .Offset(row_idx, HIGH_IDX).Value < .Offset(i, HIGH_IDX).Value Then

-                                .Offset(row_idx, HIGH_IDX).Value = .Offset(i, HIGH_IDX).Value

-                            End If

-                            If .Offset(row_idx, LOW_IDX).Value > .Offset(i, LOW_IDX).Value Then

-                                .Offset(row_idx, LOW_IDX).Value = .Offset(i, LOW_IDX).Value

-                            End If

-                            .Offset(row_idx, VOLUME_IDX).Value = _

-                                .Offset(row_idx, VOLUME_IDX).Value + .Offset(i, VOLUME_IDX).Value

-                            .Offset(row_idx, TIME_IDX).Value = .Offset(i, TIME_IDX).Value

-                            .Offset(row_idx, CLOSE_IDX).Value = .Offset(i, CLOSE_IDX).Value

-                        End If

-                    Else

-                        ' skip virtual prices

-                        If (.Offset(row_idx, VOLUME_IDX) > MIN_PRICE_VALUE) Then

-                            row_idx = row_idx + 1

-                        End If

-                        For j = DATE_IDX To VOLUME_IDX

-                            .Offset(row_idx, j) = .Offset(i, j)

-                        Next j

-                        CurrentDate = .Offset(i, DATE_IDX)

-                    End If

-                Next i

-            End With ' RawData

-            ' Clear unused Cells

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(65536, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-            ).ClearContents

-            

-            If row_idx > denWindow Then

-                row_idx = row_idx - denWindow

-                .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-                ).delete xlShiftUp

-            Else

-                Exit Function

-            End If

-            

-            row_idx = denWindow + 1

-            

-            Set Location = .Range( _

-                .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_IDX) _

-            )

-            

-            Location.TextToColumns _

-                Destination:=Location.Offset(0, DATE_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:="/", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2))

-            

-            Location.Offset(0, TIME_IDX).TextToColumns _

-                Destination:=Location.Offset(0, TIME_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:=":", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2))

-            

-            ' Check estimation date

-            

-            Dim end_date, end_time As Date

-            Dim year, month, day As Integer

-            Dim hour, minute As Integer

-            Dim next_time_exist As Boolean

-            

-            year = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 3)

-            month = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 2)

-            day = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 1)

-            hour = Location.Cells(denWindow - 1, TIME_STAMP_OFFSET + 1)

-            minute = Location.Cells(denWindow - 1, TIME_STAMP_OFFSET + 2)

-            

-            next_time_exist = day + month + year <> 0

-            

-            If next_time_exist Then

-                end_date = DateSerial(year, month, day)

-                end_time = TimeSerial(hour, minute, 0)

-                mobjAppRunEnable.EnableRun ESTIMATION_DATE, end_date

-            End If

-             

-            row_idx = 0

-            Dim temp_str As String

-                    

-            If IsIntraday Then

-                Do While IsEmpty(Location.Cells(1 + row_idx, 1 + DATE_IDX)) = False

-                       temp_str = Location.Cells(1 + row_idx, 1 + PROJECT_IDX + 1)

-                       temp_str = temp_str & "/"

-                       temp_str = temp_str & Location.Cells(1 + row_idx, 1 + PROJECT_IDX + 2)

-                       temp_str = temp_str & "-"

-                       temp_str = temp_str & Location.Cells(1 + row_idx, 1 + TIME_IDX)

-                       Location.Cells(1 + row_idx, DATE_IDX) = temp_str

-                       row_idx = row_idx + 1

-                Loop

-                row_idx = row_idx - 1

-                Dim condition As Boolean

-                condition = Not CalcNextTime And next_time_exist And end_date = DateValue(Now) And end_time > TimeValue(Now)

-                If condition Then

-                    .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL - 1), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-                    ).delete xlShiftUp

-                End If

-            Else

-                Do While IsEmpty(Location.Cells(1 + row_idx, 1 + DATE_IDX)) = False

-                       temp_str = "'" & Location.Cells(1 + row_idx, 1)

-                       Location.Cells(1 + row_idx, DATE_IDX) = temp_str

-                       row_idx = row_idx + 1

-                Loop

-                row_idx = row_idx - 1

-                condition = Not CalcNextTime And next_time_exist And end_date = DateValue(Now) And TimeValue(Now) < TimeSerial(18, 0, 0)

-                If condition Then

-                    .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL - 1), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-                    ).delete xlShiftUp

-                End If

-            End If

-        End With ' .Worksheets(RAW_DATA_SHEET)

-    End With ' wb

-    UpdateHistory = True

-End Function

-

-Private Function GetQryPath(wb As Workbook) As String

-    Dim QryPathStr As String

-    Dim IsIntradai As Boolean

-    Dim DayCount As Integer

-    With wb.Worksheets(VAR_SHEET)

-        QryPathStr = "URL;http://online.rbc.ru/cgi-bin/online/nph-single-old.cgi?"

-        QryPathStr = QryPathStr & "ticker=" & .Range("DEN_SYMBOL")

-        QryPathStr = QryPathStr & "&source=" & .Range("DEN_SOURCE")

-        QryPathStr = QryPathStr & "&board=" & .Range("DEN_BOARD")

-        IsIntradai = IsNumeric(.Range("DEN_TIME"))

-        If IsIntradai Then

-            QryPathStr = QryPathStr & "&period=" & .Range("DEN_TIME")

-        Else

-            QryPathStr = QryPathStr & "&period=60"

-        End If

-        QryPathStr = QryPathStr & "&oh=11&ch=18"

-        QryPathStr = QryPathStr & "&separator=%2C"

-        QryPathStr = QryPathStr & "&vmode=Ignore&vtype=BA2"

-        QryPathStr = QryPathStr & "&format=Excel"

-        

-        If IsIntradai Then

-            DayCount = .Range("DEN_HISTORY") * .Range("DEN_TIME") \ 420 + 1 + .Range("DEN_HISTORY")

-        Else

-            DayCount = .Range("DEN_HISTORY")

-        End If

-        QryPathStr = QryPathStr & "&daysback=" & DayCount

-'        .Range("LAST_HIST_QRY") = QryPathStr

-    End With

-    GetQryPath = QryPathStr

-    

-End Function

-

-Sub UpdateTickerList(wb As Workbook)

-    Dim Idx, n As Integer

-    Dim ResultLength As Integer

-    Dim Location As Range

-    Dim QryPathStr As String

-    Dim QueryDataName As String

-    Dim DestRangeArea As String

-    

-    QryPathStr = GetListPath(wb)

-    With wb

-        With .Worksheets(VAR_SHEET)

-            Idx = .Range("IDX_DEN_LIST")

-            Set Location = .Range("TICKER_TABLES").Offset(0, (Idx - 1) * 2)

-             .Range("IDX_DEN_SYMBOL") = 1

-            QueryDataName = Location.Offset(0, 0)

-            'Clear table

-            .Range(Location.Offset(1, 0), Location.Offset(65535 - Location.Row, 1)).ClearContents

-            

-            If Not QryExist(Location.Offset(1, 0), QueryDataName) Then

-                QryCreate Location.Offset(1, 0), QueryDataName, QryPathStr

-            Else

-                QryRefresh Location.Offset(1, 0), QueryDataName, QryPathStr

-            End If

-            ' Remove header

-            ' Find [DATA]

-            n = 0

-            Do While Location.Offset(n, 0) <> "[DATA]"

-                n = n + 1

-            Loop

-            .Range(Location.Offset(1, 0), Location.Offset(n, 1)).delete Shift:=xlUp

-            With .QueryTables(QueryDataName)

-                DestRangeArea = .ResultRange.name.RefersTo

-                ResultLength = .ResultRange.count

-            End With

-        

-        '        .Parent.Application.DisplayAlerts = False

-                

-            .Range(DestRangeArea).TextToColumns _

-                Destination:=.Range(DestRangeArea), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=True, _

-                Semicolon:=True, _

-                Comma:=True, _

-                Space:=False, _

-                Other:=False, _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 9))

-        ' Sort Data

-            Set Location = .Range(.Range(DestRangeArea).Offset(0, 0), .Range(DestRangeArea).Offset(ResultLength - 1, 1))

-            Location.Sort _

-                Key1:=.Range(DestRangeArea).Offset(0, 0), _

-                Order1:=xlAscending, _

-                Header:=xlNo, _

-                OrderCustom:=1, _

-                MatchCase:=False, _

-                Orientation:=xlTopToBottom

-        End With

-        ' Setup Ticker List

-         With .Worksheets(VAR_SHEET)

-            DestRangeArea = .name & "!" & .Range(.Range(DestRangeArea).Cells(1, 1), .Range(DestRangeArea).Cells(ResultLength - 1, 1)).Address

-         End With

-        With .Worksheets(FORM_SHEET).Shapes("cbxTikers").ControlFormat

-            .ListFillRange = DestRangeArea

-            .ListIndex = 1

-        End With

-    End With

-End Sub

-

-Private Function GetListPath(wb As Workbook) As String

-    Dim QryPathStr As String

-    With wb.Worksheets(VAR_SHEET)

-        QryPathStr = "URL;http://online.rbc.ru/cgi-bin/names.cgi?"

-        QryPathStr = QryPathStr & "&source=" & .Range("DEN_SOURCE")

-        QryPathStr = QryPathStr & "&board=" & .Range("DEN_BOARD")

-        QryPathStr = QryPathStr & "&category=STOCKS"

-        '.Range("LAST_DIR_QRY") = QryPathStr

-    End With

-    GetListPath = QryPathStr

-End Function

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    Set MyAppEvents.app = Application

-    Dim wbname As String

-    Application.ScreenUpdating = False

-    If Application.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        Shell "EXCEL " & wbname

-        ThisWorkbook.Close Savechanges:=False

-        Exit Sub

-    End If

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False

-    cmSetStandaloneMode

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment wb:=ThisWorkbook, DesignMode:=False

-        If ThisWorkbook.Saved = False Then

-            ThisWorkbook.Save

-        End If

-    End If

-    Application.Caption = Empty

-    Application.CommandBars("Worksheet Menu Bar").Reset

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-        Dim MaxX, MaxY As Integer

-        With ThisWorkbook.Worksheets(FORM_SHEET)

-            MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-            MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-        End With

-

-        With ThisWorkbook.Application

-            .ScreenUpdating = False

-            .WindowState = xlNormal

-            .Height = MaxY

-            .Width = MaxX

-        End With

-End Sub

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mReadWrite
->>>>>>
-Attribute VB_Name = "mReadWrite"

-Option Explicit

-

-Public Const GOOD_LINE_STATUS As String = "Ok"

-Public Const BAD_LINE_STATUS As String = "N/A"

-

-Function ReadWebData(Location As Range, Hist As Integer, dt As Integer, _

-              pPriceData As TPriceData) As Integer

-    'Инициализация типа TPriceData из таблицы типа - 1

-    'kопируются не более чем hist последних строк

-    'aPoint - начало таблицы

-    'первые две строки таблицы идентифицирует данные (строки)

-    Dim n, i As Integer

-    

-    'Определение числа строк таблицы - n

-    n = GetLinesCount(Location)

-    ReadWebData = n

-    If n < 9 Then             'обработать ошибку !!!

-        GoTo done

-    End If

-    ' число строк определено ()

-    If Hist > (n - 3) \ dt + 1 Then ' коррекция истории

-        Hist = (n - 3) \ dt + 1 '

-    End If

-    Dim t, s As Integer

-    For t = 0 To Hist - 1

-        s = n - t * dt - 1

-        pPriceData.D(Hist - t) = Location.Offset(s, DATE_IDX).Value

-        pPriceData.Tm(Hist - t) = Location.Offset(s, TIME_IDX).Value

-        pPriceData.Opn(Hist - t) = Location.Offset(s, OPEN_IDX).Value

-        pPriceData.Hgh(Hist - t) = Location.Offset(s, HIGH_IDX).Value

-        pPriceData.Lw(Hist - t) = Location.Offset(s, LOW_IDX).Value

-        pPriceData.Cls(Hist - t) = Location.Offset(s, CLOSE_IDX).Value

-        pPriceData.Vl(Hist - t) = Location.Offset(s, VOLUME_IDX).Value

-    Next t

-    ReadWebData = t + 1

-done:

-End Function

-

-Sub ResultLinesOut(Location As Range, pPD As TPriceData, pDen As TDenmark)

-    Dim n As Integer

-    

-    n = GetLinesCount(Location)

-    With Location

-        .Offset(-1, RESIST_IDX) = "Resistance"

-        .Offset(-1, SUPPORT_IDX) = "Support"

-        .Offset(-1, PROJECT_IDX) = "Project"

-    End With

-    Dim t, count, Idx, loc_idx As Integer

-    count = pPD.tC

-    For t = 0 To count - 1

-        Idx = count - t

-        loc_idx = n - t - 1

-        If pDen.ResistanceLine(Idx) > MIN_PRICE_VALUE Then

-            Location.Offset(loc_idx, RESIST_IDX).Value = pDen.ResistanceLine(Idx)

-        End If

-        If pDen.SupportLine(Idx) > MIN_PRICE_VALUE Then

-            Location.Offset(loc_idx, SUPPORT_IDX).Value = pDen.SupportLine(Idx)

-        End If

-        If Abs(pDen.SignalValue) > 1 Then

-            Location.Offset(loc_idx, PROJECT_IDX).Value = pDen.ProjectPrice

-        End If

-    Next t

-End Sub

-

-Sub Out_Table_1(TheRange As Range, pDen As TDenmark, LastIdx As Integer)

-    

-    

-    ' Col = 2 - не определен !!!

-    ' Status - Col = 0

-    If pDen.ResistancePointCount >= 2 Then

-        TheRange.Offset(0, 0).Value = GOOD_LINE_STATUS

-    Else

-        TheRange.Offset(0, 0).Value = BAD_LINE_STATUS

-    End If

-    If pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(1, 0).Value = GOOD_LINE_STATUS

-    Else

-        TheRange.Offset(1, 0).Value = BAD_LINE_STATUS

-    End If

-    ' -----------------------------------------

-    ' углы наклонов линии сопротивления и поддержки - Col = 1

-    If pDen.ResistancePointCount >= 2 Then

-        TheRange.Offset(0, 1).Value = pDen.ResistanceAngle

-    End If

-    If pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(1, 1).Value = pDen.SupportAngle

-    End If

-    If pDen.ResistancePointCount >= 2 And pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(2, 1).Value = (pDen.ResistanceAngle + pDen.SupportAngle) / 2

-    End If

-    ' -----------------------------------------

-    ' Опорные цены линий денмарка на текущий момент

-    If pDen.ResistancePointCount >= 2 Then

-        TheRange.Offset(0, 2).Value = pDen.ResistanceLine(LastIdx)

-    End If

-    If pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(1, 2).Value = pDen.SupportLine(LastIdx)

-    End If

-    If pDen.ResistancePointCount >= 2 And pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(2, 2).Value = _

-            (pDen.ResistanceLine(LastIdx) + pDen.SupportLine(LastIdx)) / 2

-    End If

-    

-End Sub

-

-Sub Out_Table_2(TheRange As Range, TheComment As Range, pPD As TPriceData, pDen As TDenmark)

-    Const ColorIndexBUY = 5

-    Const ColorIndexSELL = 3

-    Const ColorIndexNOTHINK = 14

-    

-    Dim SignalValue_defined, allert_enable  As Boolean

-    Dim Message As String

-    SignalValue_defined = False

-    allert_enable = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_ALLERT_DLG")

-    Message = "Сигнал об изменении тренда не идентифицирован."

-    If pDen.SignalValue >= 2 Then

-        SignalValue_defined = True

-        With TheRange.Offset(0, 0)

-            .Value = "BUY"

-            .Font.Bold = True

-            .Font.ColorIndex = ColorIndexBUY

-        End With

-        TheRange.Offset(0, 1).Value2 = pPD.D(pPD.tC)

-        TheRange.Offset(0, 2).Value2 = pPD.Tm(pPD.tC)

-        TheRange.Offset(0, 3).Value = pDen.SignalValue - 1

-        TheRange.Offset(0, 4).Value = pDen.ProjectPrice

-        Message = "BUY Signal: возможен прорыв вверх нисходящего тренда с уровнем значимости = " & pDen.SignalValue - 1 & " ! "

-    End If

-    If pDen.SignalValue <= -2 Then

-        SignalValue_defined = True

-        With TheRange.Offset(0, 0)

-            .Value = "SELL"

-            .Font.Bold = True

-            .Font.ColorIndex = ColorIndexSELL

-        End With

-        TheRange.Offset(0, 1).Value2 = pPD.D(pPD.tC)

-        TheRange.Offset(0, 2).Value2 = pPD.Tm(pPD.tC)

-        TheRange.Offset(0, 3).Value = pDen.SignalValue + 1

-        TheRange.Offset(0, 4).Value = pDen.ProjectPrice

-        Message = "SELL Signal: возможен прорыв вниз восходящего тренда с уровнем значимости = " & -(pDen.SignalValue + 1) & "!"

-    End If

-    With TheComment

-        .Value = Message

-        .Font.Bold = True

-        Dim color_idx As Integer

-        If SignalValue_defined Then

-            If pDen.SignalValue > 0 Then

-                .Font.ColorIndex = ColorIndexBUY

-            Else

-                .Font.ColorIndex = ColorIndexSELL

-            End If

-        Else

-            .Font.ColorIndex = ColorIndexNOTHINK

-        End If

-    End With

-    If allert_enable And SignalValue_defined Then

-        MsgBox _

-            Prompt:=Message, _

-            Title:=PROGRAM_NAME, _

-            Buttons:=vbOKOnly + vbInformation

-    End If

-End Sub

-

-Sub Out_Table_3(TheRange As Range, pDen As TDenmark)

-    Dim i As Integer

-    For i = 1 To 3

-        TheRange.Offset(i - 1, 0).Value = pDen.Qualificator(i)

-    Next i

-End Sub

-

-Sub Out_Table_4(TheRange As Range, pPD As TPriceData)

-    Dim LastIdx As Integer

-    LastIdx = pPD.tC

-    With TheRange

-        .Offset(0, 0).Value2 = "'" & pPD.D(LastIdx)

-        .Offset(0, 1).Value2 = "'" & pPD.Tm(LastIdx)

-        .Offset(0, 2) = pPD.Opn(LastIdx)

-        .Offset(0, 3) = pPD.Hgh(LastIdx)

-        .Offset(0, 4) = pPD.Lw(LastIdx)

-        .Offset(0, 5) = pPD.Cls(LastIdx)

-        .Offset(0, 6) = pPD.Cls(LastIdx) - pPD.Cls(LastIdx - 1)

-    End With

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Denmark method bar"

-Public Const common_pwd As Long = 31415926

-

-

-Sub SetEnvironment(wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    With Application

-        .Caption = PROGRAM_NAME

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .GetState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-    End With

-    With wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(FORM_SHEET).Select

-    End With

-    CreateCommandBar theApp:=wb.Application

-End Sub

-

-Sub RestoreEnvironment(wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Application.ScreenUpdating = False

-    With wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                     cWindow.DisplayHeadings = True

-                Next

-            End If

-        Next

-        .Worksheets(FORM_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu (True)

-        End If

-        With mobjAppState

-            .RestoreState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(wb As Workbook)

-    With wb

-        .Application.ScreenUpdating = False

-        

-        With .Worksheets(RAW_DATA_SHEET)

-            .Visible = xlVeryHidden

-            .Protect Password:=common_pwd, userInterfaceOnly:=True, Contents:=False

-        End With

-        With .Worksheets(VAR_SHEET)

-            .Visible = xlVeryHidden

-            .Protect Password:=common_pwd, userInterfaceOnly:=True, Contents:=False

-        End With

-        With .Worksheets(FORM_SHEET)

-            .EnableSelection = xlNoSelection

-            .Protect userInterfaceOnly:=True

-            .Select

-        End With

-        With .Worksheets(CHART_SHEET)

-            .EnableSelection = xlNoSelection

-            .Protect userInterfaceOnly:=True

-        End With

-        .Protect Windows:=True

-        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(wb As Workbook)

-    With wb

-        .Unprotect

-        .Application.ScreenUpdating = False

-        With .Worksheets(RAW_DATA_SHEET)

-            .Visible = xlVeryHidden

-            .Unprotect Password:=common_pwd

-        End With

-        With .Worksheets(VAR_SHEET)

-            .Visible = xlVeryHidden

-            .Unprotect Password:=common_pwd

-        End With

-        With .Worksheets(CHART_SHEET)

-            .Select

-            .Unprotect

-        End With

-        With .Worksheets(FORM_SHEET)

-            .Select

-            .Unprotect

-        End With

-        .Application.ScreenUpdating = True

-        

-    End With

-End Sub

-

-<<<<<<
-======================
-mTypes
->>>>>>
-Attribute VB_Name = "mTypes"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Метод г-на Демарка"

-Public Const PROGRAM_VERSION As String = "version 1.0 Professional"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-

-Public Const ESTIMATION_DATE As Long = 19990413

-'Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "J27"

-

-Public Const RAW_DATA_SHEET As String = "Raw_data"

-Public Const PRICE_TABLE As String = "B1"

-Public Const RAW_DATA_RANGE As String = "B3"

-Public Const RAW_DATA_RANGE_COL As Integer = 2

-Public Const RAW_DATA_RANGE_ROW As Integer = 3

-

-Public Const VAR_SHEET As String = "Var_s"

-

-Public Const CHART_SHEET As String = "Chart"

-

-Public Const MIN_PRICE_VALUE As Double = 0.000001

-Public Const MAX_PRICE_VALUE As Double = 1000000000

-

-' Fields indexes in RAW_DATA_RANGE

-Public Const DATE_IDX As Integer = 0

-Public Const TIME_IDX As Integer = 1

-Public Const OPEN_IDX As Integer = 2

-Public Const CLOSE_IDX As Integer = 3

-Public Const LOW_IDX As Integer = 4

-Public Const HIGH_IDX As Integer = 5

-Public Const VOLUME_IDX As Integer = 6

-Public Const RESIST_IDX As Integer = 7

-Public Const SUPPORT_IDX As Integer = 8

-Public Const PROJECT_IDX As Integer = 9

-

-Type TPriceData

-    D() As String      ' календарная дата

-    Tm() As String     ' время

-    Opn() As Double    ' Open

-    Hgh() As Double    ' High

-    Lw() As Double     ' Low

-    Cls() As Double    ' Close

-    Vl() As Double     ' Volume

-    tC As Integer      ' Current time

-End Type

-

-Type TDenmark

-   ResistanceLine() As Double           'Resistance line

-   ResistancePoints() As Integer        'Resistance pivot points

-   ResistancePointCount As Integer      'The number of resistance pivot points

-   ResistanceAngle As Double            'Angle of Declination of ResistanceLine

-   

-   SupportLine() As Double              'Support line

-   SupportPoints() As Integer           'Support pivot points

-   SupportPointsCount As Integer        'The number of support pivot points

-   SupportAngle As Double               ' Angle of Declination of SupportLine

-   

-   SignalParameter     As Integer       ' parameter for SignalValue

-   SignalValue      As Integer          'SignalValue

-   

-   

-   Qualificator(1 To 3) As String       ' qualificators

- 

-   ProjectNumber As Integer             ' номер проекции

-   ProjectPrice  As Double              ' проекция цены

-   

-End Type

-

-

-<<<<<<
-======================
-mCommands
->>>>>>
-Attribute VB_Name = "mCommands"

-Option Explicit

-Dim AppRunEnable As New cEnableRun

-

-Sub evHistory_Change()

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("BOOL_DATA_READY") = False

-    End With

-End Sub

-

-Sub evSubmit_Click()

-    Dim ticker As String

-

-    Application.Cursor = xlWait

-    Dim wb As Workbook

-    Set wb = ThisWorkbook

-    With wb

-        With .Worksheets(VAR_SHEET)

-            ticker = .Range("DEN_SYMBOL")

-            If .Range("BOOL_DATA_DOWNLOAD") = True Or .Range("BOOL_DATA_READY") = False Then

-                .Range("BOOL_DATA_READY") = UpdateHistory(wb)

-                .Range("BOOL_DENMARK_READY") = False

-            End If

-        End With

-        If TDenmark_Calc Then

-            With .Worksheets(FORM_SHEET)

-                .Range("CALC_TICKER_NAME") = ticker

-            End With

-        End If

-    End With

-    Application.Cursor = xlDefault

-    

-End Sub

-

-

-Sub evParamChange()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DENMARK_READY") = False

-End Sub

-

-Sub evGroupChange()

-    Dim GroupIdx, LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange As String

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        GroupIdx = .Range("IDX_DEN_LIST")

-        .Range("IDX_DEN_SYMBOL") = 1

-        NewRangeOffsetCol = (GroupIdx - 1) * 2

-        LinesCount = GetLinesCount(.Range("TICKER_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .name & "!" & .Range(.Range("TICKER_TABLES").Offset(1, NewRangeOffsetCol), .Range("TICKER_TABLES").Offset(LinesCount, NewRangeOffsetCol)).Address

-        ThisWorkbook.Worksheets(FORM_SHEET).Shapes("cbxTikers").ControlFormat.ListFillRange = NewCbxRange

-    End With

-    evHistory_Change

-End Sub

-

-Sub evUpdateTickerList()

-    UpdateTickerList ThisWorkbook

-    evHistory_Change

-End Sub

-

-Sub cmViewChart(Optional SwapPage As Boolean = True)

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("BOOL_CHART_READY") = False

-        If .Range("BOOL_DENMARK_READY") <> True Then

-            If .Range("BOOL_AUTORECALC") = True Then

-                evSubmit_Click

-                If .Range("BOOL_DENMARK_READY") <> True Then

-                    Exit Sub

-                End If

-            Else

-                MsgBox _

-                    "График не может быть построен." & vbCrLf & "Исходные данные не обработаны.", _

-                    vbOKOnly + vbExclamation, _

-                    PROGRAM_NAME

-                Exit Sub

-            End If

-        End If

-    End With

-    With ThisWorkbook.Worksheets(FORM_SHEET)

-        With .Range("TABLE_1")

-            Dim test_lines As Boolean

-            test_lines = StrComp(.Cells(1, 1).Value, GOOD_LINE_STATUS)

-            test_lines = test_lines + StrComp(.Cells(2, 1).Value, GOOD_LINE_STATUS)

-            If test_lines <> 0 Then

-                MsgBox _

-                    Prompt:="График не может быть построен." & vbCrLf & "Опорные точки не определены .", _

-                    Title:=PROGRAM_NAME, _

-                    Buttons:=vbOKOnly + vbExclamation

-                Exit Sub

-            End If

-        End With

-        Draw_Chart Not IsEmpty(.Range("TABLE_2").Cells(1, 1))

-    End With

-    With ThisWorkbook

-        .Worksheets(VAR_SHEET).Range("BOOL_CHART_READY") = True

-        If SwapPage Then

-            .Worksheets(CHART_SHEET).Select

-        End If

-    End With

-End Sub

-

-Sub cmViewForm()

-    With ThisWorkbook

-        .Worksheets(FORM_SHEET).Select

-    End With

-End Sub

-

-Sub cmCloseProgram()

-    Dim ResistanceLine

-    ResistanceLine = MsgBox( _

-        Prompt:="Вы желаете завершить программу?", _

-        Buttons:=vbQuestion + vbYesNo, _

-        Title:=PROGRAM_NAME _

-    )

-    If ResistanceLine = vbYes Then

-       Application.Quit

-    End If

-End Sub

-

-Sub cmAbout()

-    dlgAbout.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlgAbout.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlgAbout.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlgAbout.Show

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-        helppath = "hh.exe " & .Path & "\Demark.chm"

-        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub cmSetStandaloneMode()

-    Application.ScreenUpdating = False

-    ProtectionDisable wb:=ThisWorkbook

-    SetEnvironment wb:=ThisWorkbook

-    ProtectionEnable wb:=ThisWorkbook

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    rp = common_pwd

-    dlgGetPwd.edPwd = ""

-    dlgGetPwd.Show

-    If dlgGetPwd.edPwd = rp Then

-        ProtectionDisable wb:=ThisWorkbook

-        RestoreEnvironment wb:=ThisWorkbook, DesignMode:=True

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmPrint()

-    If MsgBox( _

-            Prompt:="Вы желаете распечатать результат?", _

-            Buttons:=vbYesNo + vbQuestion, _

-            Title:=PROGRAM_NAME) = vbNo _

-    Then

-        Exit Sub

-    End If

-    Dim s_ticker, s_name, s_time As String

-    s_ticker = ThisWorkbook.Worksheets(FORM_SHEET).Range("CALC_TICKER_NAME")

-    s_name = ThisWorkbook.Worksheets(FORM_SHEET).Range("CALC_NAME")

-    s_time = Now

-    Application.ScreenUpdating = False

-    cmViewChart SwapPage:=False

-    Application.ScreenUpdating = False

-    With ThisWorkbook.Worksheets(FORM_SHEET).PageSetup

-        .LeftHeader = s_ticker

-        .CenterHeader = PROGRAM_NAME

-        .RightHeader = s_time

-        .LeftFooter = s_name

-        .CenterFooter = "Page &P of &N"

-        .RightFooter = ""

-        .LeftMargin = Application.InchesToPoints(0.75)

-        .RightMargin = Application.InchesToPoints(0.75)

-        .TopMargin = Application.InchesToPoints(0.78)

-        .BottomMargin = Application.InchesToPoints(0.92)

-        .HeaderMargin = Application.InchesToPoints(0.5)

-        .FooterMargin = Application.InchesToPoints(0.5)

-        .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 = 2

-    End With

-    With ThisWorkbook.Worksheets(CHART_SHEET).PageSetup

-        .LeftHeader = s_ticker

-        .CenterHeader = PROGRAM_NAME

-        .RightHeader = s_time

-        .LeftFooter = s_name

-        .CenterFooter = "Page &P of &N"

-        .RightFooter = ""

-        .LeftMargin = Application.InchesToPoints(0.75)

-        .RightMargin = Application.InchesToPoints(0.75)

-        .TopMargin = Application.InchesToPoints(0.78)

-        .BottomMargin = Application.InchesToPoints(0.92)

-        .HeaderMargin = Application.InchesToPoints(0.5)

-        .FooterMargin = Application.InchesToPoints(0.5)

-        .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 = 2

-    End With

-    Application.ScreenUpdating = False

-    ThisWorkbook.Worksheets(Array("MainForm", "Chart")).PrintOut Copies:=1, Collate:=True

-    cmViewForm

-End Sub

-<<<<<<
-======================
-mDemark
->>>>>>
-Attribute VB_Name = "mDemark"

-Option Explicit

-

-Public Const FORM_SHEET As String = "MainForm"

-

-'Form Ranges

-Public Const TABLE_1 As String = "TABLE_1"

-Public Const TABLE_2 As String = "TABLE_2"

-Public Const TABLE_3 As String = "TABLE_3"

-Public Const TABLE_4 As String = "TABLE_4"

-Public Const TABLE_COMMENT As String = "TABLE_COMMENT"

-

-'Основной тип данных - стандарт 1

-

-'*********************

-Dim PriceDataArray As TPriceData

-Dim DenmarkDataArray As TDenmark

-

-Dim mobjAppRunEnable As New cEnableRun

-

-Function TDenmark_Calc() As Boolean

-    

-    Dim nWindow As Integer

-    Dim bPrevCloseFilter, bSuccCloseFilter As Boolean

-    

-    TDenmark_Calc = False

-    

-    mobjAppRunEnable.EnableRun ESTIMATION_DATE, Now

-    

-    With ThisWorkbook

-        .Application.ScreenUpdating = False

-'1)    Read User data

-        With .Worksheets(VAR_SHEET)

-            DenmarkDataArray.ProjectNumber = .Range("DEN_PROECT").Value

-            DenmarkDataArray.SignalParameter = .Range("DEN_PARAM").Value

-            nWindow = .Range("DEN_WINDOW").Value

-            bPrevCloseFilter = .Range("BOOL_PREV_CLOSE").Value

-            bSuccCloseFilter = .Range("BOOL_SUCC_CLOSE").Value

-        End With

-

-'2)   Memory allocation

-        allocate_memory PriceDataArray, DenmarkDataArray, nWindow

-

-'3)   Read data

-        Dim TheRange As Range

-        Set TheRange = .Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE)

-        Dim LinesCount As Integer

-        LinesCount = ReadWebData(Location:=TheRange, Hist:=PriceDataArray.tC, dt:=1, pPriceData:=PriceDataArray)

-        

-        'Init function result

-        TDenmark_Calc = LinesCount >= nWindow

-        

-        If LinesCount >= nWindow Then

-        

-'4)   Calculate metod TDenmarkDataArray

-            DetDenmark PriceDataArray, DenmarkDataArray, bPrevCloseFilter, bSuccCloseFilter

-            If Abs(DenmarkDataArray.SignalValue) > 1 Then  'ценовые ориентиры, если есть сигнал

-                DetProj PriceDataArray, DenmarkDataArray

-            End If

-'5)   Write result

-            Application.ScreenUpdating = False

-    

-'6)    Clear interface tables

-            With .Worksheets(FORM_SHEET)

-                .Range(TABLE_1).ClearContents ' таблица-1

-                .Range(TABLE_2).ClearContents ' таблица-2

-                .Range(TABLE_3).ClearContents ' таблица-3

-                .Range(TABLE_COMMENT).Value = "" ' коментарий-3

-                .Range(TABLE_4).ClearContents ' таблица-4

-            End With

-    

-            ResultLinesOut Location:=TheRange.Offset(2, 0), pPD:=PriceDataArray, pDen:=DenmarkDataArray

-            

-            With .Worksheets(FORM_SHEET)

-                Out_Table_1 TheRange:=.Range(TABLE_1).Cells(1, 1), pDen:=DenmarkDataArray, LastIdx:=PriceDataArray.tC

-                Out_Table_2 _

-                        TheRange:=.Range(TABLE_2).Cells(1, 1), _

-                        TheComment:=.Range("TABLE_COMMENT"), _

-                        pPD:=PriceDataArray, _

-                        pDen:=DenmarkDataArray

-                Out_Table_3 TheRange:=.Range(TABLE_3).Cells(1, 1), pDen:=DenmarkDataArray

-                Out_Table_4 TheRange:=.Range(TABLE_4).Cells(1, 1), pPD:=PriceDataArray

-                With .Range(TABLE_1)

-                    .Font.name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-                With .Range(TABLE_2)

-                    .Font.name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-                With .Range(TABLE_3)

-                    .Font.name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-                With .Range(TABLE_4)

-                    .Font.name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-            End With

-            .Worksheets(VAR_SHEET).Range("BOOL_DENMARK_READY") = True

-        Else

-            MsgBox _

-                Prompt:="Недостаточна глубина выборки данных." _

-                    & vbCrLf & "Измените параметры запроса и пробуйте снова.", _

-                Buttons:=vbOKOnly + vbExclamation, _

-                Title:=PROGRAM_NAME

-            .Worksheets(VAR_SHEET).Range("BOOL_DENMARK_READY") = False

-            .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False

-        End If

-'7)   Free unused memory

-        free_unused_memory PriceDataArray, DenmarkDataArray

-    End With

-End Function

-

-Sub allocate_memory(pPriceData As TPriceData, pDenmarkData As TDenmark, memsize As Integer)

-'  Память под TDenmark

-    ReDim pDenmarkData.ResistanceLine(1 To memsize)

-    ReDim pDenmarkData.ResistancePoints(1 To memsize)

-    ReDim pDenmarkData.SupportLine(1 To memsize)

-    ReDim pDenmarkData.SupportPoints(1 To memsize)

-   

-' Инициализация данных по ценам

-    pPriceData.tC = memsize

-    ReDim pPriceData.D(1 To memsize)

-    ReDim pPriceData.Tm(1 To memsize)

-    ReDim pPriceData.Opn(1 To memsize)

-    ReDim pPriceData.Hgh(1 To memsize)

-    ReDim pPriceData.Lw(1 To memsize)

-    ReDim pPriceData.Cls(1 To memsize)

-    ReDim pPriceData.Vl(1 To memsize)

-

-End Sub

-

-Sub free_unused_memory(pP As TPriceData, pD As TDenmark)

-'   Free Prices

-    pP.tC = 0

-    Erase pP.D

-    Erase pP.Tm

-    Erase pP.Opn

-    Erase pP.Hgh

-    Erase pP.Lw

-    Erase pP.Cls

-    Erase pP.Vl

-    

-'Free TDenmark

-    Erase pD.ResistanceLine

-    Erase pD.ResistancePoints

-    Erase pD.SupportLine

-    Erase pD.SupportPoints

-End Sub

-

-

-'*****************************************

-Sub DetDenmark(pPriceData As TPriceData, pDenmarkData As TDenmark, ByVal ClosePrev2 As Boolean, ByVal CloseSucc1 As Boolean)

-' определение элементов данных Денмарка (в цифровой форме)

-' на текущий момент времени времени tC

-' ИСХОДНЫЕ ДАННЫЕ:

-' pPriceData  - окно, стандартная форма данных по ценам (определена)

-' ClosePrev2 - H(t) > max{ H(t-1), H(t+1)} и  H(t) > Close(t-2)

-' CloseSucc1 - H(t) > max{ H(t-1), H(t+1)}  и  R(t+1) > Close(t+1)

-' РЕЗУЛЬТАТ:

-' pDenmarkData - элементы данных Денмарка (память выделена, SignalParameter - определен):

-' линии ResistanceLine,SupportLine их наклоны, опорные точки, сигналы к покупке или продаже

-' SignalValue = 0 сигнал отсутствует

-' SignalValue < 0 прорыв восходящего тренда (сигнал продажи)

-' SignalValue > 0 прорыв нисходящего тренда (сигнал покупки)

-' Если pDenmarkData.ResistancePointCount < 2, то элементы ResistanceLine не определяются

-' Если pDenmarkData.SupportPointsCount < 2, то элементы SupportLine не определяются

-

-' начальная установка

-    Const QUALIFICATOR_DISABLE As String = "-"

-    Const QUALIFICATOR_ENABLE As String = "Signal"

-    

-    Dim UpQual(1 To 3) As String

-    Dim DownQual(1 To 3) As String

-    Dim UpSignal, DownSignal As Integer

-    Dim i As Integer

-    

-    pDenmarkData.SignalValue = 0

-    UpSignal = 0

-    DownSignal = 0

-    

-    For i = 1 To 3

-        pDenmarkData.Qualificator(i) = QUALIFICATOR_DISABLE

-        UpQual(i) = QUALIFICATOR_DISABLE

-        DownQual(i) = QUALIFICATOR_DISABLE

-    Next i

-    

-' определение линии поддержки и сопротивления

-    ResLine _

-        pPriceData, _

-        pPriceData.tC, _

-        pDenmarkData.ResistancePointCount, _

-        pDenmarkData.ResistanceLine, _

-        pDenmarkData.ResistancePoints, _

-        ClosePrev2, _

-        CloseSucc1

-        

-    SuppLine _

-        pPriceData, _

-        pPriceData.tC, _

-        pDenmarkData.SupportPointsCount, _

-        pDenmarkData.SupportLine, _

-        pDenmarkData.SupportPoints, _

-        ClosePrev2, _

-        CloseSucc1

-

-        

-        

-    If pDenmarkData.ResistancePointCount >= 2 Then

-        pDenmarkData.ResistanceAngle = 57.29578 * _

-            Atn(pDenmarkData.ResistanceLine(pPriceData.tC) - _

-                pDenmarkData.ResistanceLine(pPriceData.tC - 1))

-    End If

-    If pDenmarkData.SupportPointsCount >= 2 Then

-        pDenmarkData.SupportAngle = 57.29578 * _

-            Atn(pDenmarkData.SupportLine(pPriceData.tC) - _

-                pDenmarkData.SupportLine(pPriceData.tC - 1))

-    End If

-

-' ФОРМИРОВАНИЕ СИГНАЛА ----------------------------------

-    Dim t As Integer

-' 1. случай нисходящего тренда: ResistanceLine определен и ResistanceLine падает *************

-    If pDenmarkData.ResistancePointCount >= 2 And pDenmarkData.ResistanceAngle < 0 Then

-'    необходимое условие прорыва вверх

-        If pDenmarkData.ResistanceLine(pPriceData.tC) < pPriceData.Cls(pPriceData.tC) Then

-            UpSignal = 1

-            For t = pPriceData.tC - pDenmarkData.SignalParameter To pPriceData.tC - 1

-                If pPriceData.Cls(t) > pDenmarkData.ResistanceLine(t) Then

-                    UpSignal = 0

-                    Exit For

-                End If

-            Next t

-        End If

-        If UpSignal = 1 Then

-'       Qualificator-1: close убывает накануне прорыва

-            If pPriceData.Cls(pPriceData.tC - 2) > pPriceData.Cls(pPriceData.tC - 1) Then

-                UpSignal = UpSignal + 1

-                UpQual(1) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-2: open > ResistanceLine в момент прорыва

-            If pPriceData.Opn(pPriceData.tC) > pDenmarkData.ResistanceLine(pPriceData.tC) Then

-                UpSignal = UpSignal + 1

-                UpQual(2) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-3 - demand value < ResistanceLine(tC)

-            If 2 * pPriceData.Cls(pPriceData.tC - 1) - pPriceData.Lw(pPriceData.tC - 1) < pDenmarkData.ResistanceLine(pPriceData.tC) Then

-                UpSignal = UpSignal + 1

-                UpQual(3) = QUALIFICATOR_ENABLE

-            End If

-        End If

-    End If  ' нисходящий тренд обработан ************************************

-

-' 2. случай восходящего тренда: SupportLine определен и SupportLine растет

-    If pDenmarkData.SupportPointsCount >= 2 And pDenmarkData.SupportAngle > 0 Then

-'    ---------------------------------------------

-'    необходимое условие прорыва вниз

-        If pPriceData.Cls(pPriceData.tC) < pDenmarkData.SupportLine(pPriceData.tC) Then

-            DownSignal = -1

-            For t = pPriceData.tC - pDenmarkData.SignalParameter To pPriceData.tC - 1

-                If pPriceData.Cls(t) < pDenmarkData.SupportLine(t) Then

-                    DownSignal = 0

-                    Exit For

-                End If

-            Next t

-        End If

-        If DownSignal = -1 Then

-'       Qualificator-1: Close растет накануне прорыва

-            If pPriceData.Cls(pPriceData.tC - 2) < pPriceData.Cls(pPriceData.tC - 1) Then

-                DownSignal = DownSignal - 1

-                DownQual(1) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-2: Open ниже ResistanceLine в момент прорыва

-            If pPriceData.Opn(pPriceData.tC) < pDenmarkData.SupportLine(pPriceData.tC) Then

-                DownSignal = DownSignal - 1

-                DownQual(2) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-3 - supply value(t-1) > SupportLine(tC)

-            If 2 * pPriceData.Cls(pPriceData.tC - 1) - pPriceData.Hgh(pPriceData.tC - 1) > pDenmarkData.SupportLine(pPriceData.tC) Then

-                DownSignal = DownSignal - 1

-                DownQual(3) = QUALIFICATOR_ENABLE

-            End If

-        End If

-'    ---------------------------------------------

-    End If

-'      Существует преобладание тенденции

-    If Abs(DownSignal) <> UpSignal Then

-        If Abs(DownSignal) > UpSignal Then

-            pDenmarkData.SignalValue = DownSignal

-            For i = 1 To 3

-                pDenmarkData.Qualificator(i) = DownQual(i)

-            Next i

-        Else

-            pDenmarkData.SignalValue = UpSignal

-            For i = 1 To 3

-                pDenmarkData.Qualificator(i) = UpQual(i)

-            Next i

-        End If

-    End If

-End Sub

-

-Sub DetProj(pPriceData As TPriceData, pDenmarkData As TDenmark)

-'Определение проекции при наличии сигнала: |Signal| > 1

-'Услловие применимости |Signal| > 1 !!!

-    Dim pM As Double, t As Integer, Tm As Integer, tL As Integer

-

-    If pDenmarkData.SignalValue >= 2 Then  ' СИГНАЛ ПОКУПКИ

-

-        tL = pDenmarkData.ResistancePoints(pDenmarkData.ResistancePointCount)     ' tR determination

-        If tL = pPriceData.tC Then

-            tL = pDenmarkData.ResistancePoints(pDenmarkData.ResistancePointCount - 1)

-        End If

-

-'  Projections 1,2 --------------------------------------------

-        If pDenmarkData.ProjectNumber >= 1 And pDenmarkData.ProjectNumber <= 2 Then

-'           t* = Arg min {L(t) : t R <= t  <= tb ,  L(t) < ResistanceLine(t)},

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Lw(Tm) ' L(t-1) < ResistanceLine(t-1) for t - break point !

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Lw(t) < pM And pPriceData.Lw(t) < pDenmarkData.ResistanceLine(t) Then

-                    pM = pPriceData.Lw(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            If pDenmarkData.ProjectNumber = 1 Then

-'               P1( tb) = ResistanceLine(tb) + ResistanceLine(t*) - L(t*)

-                pDenmarkData.ProjectPrice = pDenmarkData.ResistanceLine(pPriceData.tC) + pDenmarkData.ResistanceLine(Tm) - pPriceData.Lw(Tm)

-            Else

-                pDenmarkData.ProjectPrice = pDenmarkData.ResistanceLine(pPriceData.tC) + pDenmarkData.ResistanceLine(Tm) - pPriceData.Cls(Tm)

-            End If

-        End If ' pDenmarkData.ProjectNumber >= 1 And pDenmarkData.ProjectNumber <= 2

-   

-'  ----------------------------------------------------------------

-'  Projections 3

-        If pDenmarkData.ProjectNumber = 3 Then

-'           t*  = Arg min { С(t) : t R <= t  <= tb ,  C(t) < ResistanceLine(t)}

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Cls(Tm)

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Cls(t) < pM And pPriceData.Cls(t) < pDenmarkData.ResistanceLine(t) Then

-                    pM = pPriceData.Cls(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            pDenmarkData.ProjectPrice = pDenmarkData.ResistanceLine(pPriceData.tC) + pDenmarkData.ResistanceLine(Tm) - pPriceData.Cls(Tm)

-        End If

-    End If ' pDenmarkData.SignalValue >= 2

-

-'-------------------------------------------------------------------

-'*******************************************************************

-' ПРОЕКЦИЯ ДЛЯ СИГНАЛА ПРОДАЖИ

-    If pDenmarkData.SignalValue <= -2 Then

-        tL = pDenmarkData.SupportPoints(pDenmarkData.SupportPointsCount)  ' tR determination

-        If tL = pPriceData.tC Then

-            tL = pDenmarkData.ResistancePoints(pDenmarkData.SupportPointsCount - 1)

-        End If

-

-'  Projections 1,2 --------------------------------------------

-        If pDenmarkData.ProjectNumber = 1 Or pDenmarkData.ProjectNumber = 2 Then

-'           t* = Arg max {H(t) : t R <= t  <= tb ,  H(t) > SupportLine(t)},

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Hgh(Tm) ' H(t-1) > SupportLine(t-1) for t - break point !

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Hgh(t) > pM And pPriceData.Hgh(t) > pDenmarkData.SupportLine(t) Then

-                    pM = pPriceData.Hgh(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            If pDenmarkData.ProjectNumber = 1 Then

- '              P1( tb) = SupportLine(tb) + SupportLine(t*) - H(t*)

-                pDenmarkData.ProjectPrice = pDenmarkData.SupportLine(pPriceData.tC) + pDenmarkData.SupportLine(Tm) - pPriceData.Hgh(Tm)

-            Else

-'               P2( tb) = SupportLine(tb) + SupportLine(t*) - C(t*)

-                pDenmarkData.ProjectPrice = pDenmarkData.SupportLine(pPriceData.tC) + pDenmarkData.SupportLine(Tm) - pPriceData.Cls(Tm)

-            End If

-        End If

-   

-'  ----------------------------------------------------------------

-'  Projections 3

-        If pDenmarkData.ProjectNumber = 3 Then

-'           t*  = Arg max { С(t) : t R <= t  <= tb ,  C(t) >  SupportLine(t)}

-'           P3( tb) = SupportLine(tb) + SupportLine(t*) - C(t*)

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Cls(Tm)

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pM < pPriceData.Cls(t) And pPriceData.Cls(t) > pDenmarkData.SupportLine(t) Then

-                    pM = pPriceData.Cls(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            pDenmarkData.ProjectPrice = pDenmarkData.SupportLine(pPriceData.tC) + pDenmarkData.SupportLine(Tm) - pPriceData.Cls(Tm)

-        End If

-    End If ' pDenmarkData.SignalValue <= -2

-End Sub

-

-Sub ResLine(pP As TPriceData, tE As Integer, ResistancePointCount As Integer, _

-            ResistanceLine() As Double, s() As Integer, ClosePrev2 As Boolean, CloseSucc1 As Boolean)

-' Определение линии сопротивления по Демарку [1]

-' Основной вариант

-' ИСХОДНЫЕ ДАННЫЕ:

-' High, dom(High) = [1, tE]

-' ClosePrev2 - H(t) > max{ H(t-1), H(t+1)} и  H(t) > Close(t-2)

-' CloseSucc1 - H(t) > max{ H(t-1), H(t+1)}  и  R(t+1) > Close(t+1)

-' РЕЗУЛЬТАТ:

-' 1) линия сопротивления ResistanceLine, dom(ResistanceLine)=[s(1), tE], и

-' 2) s = {s(1), s(2), ..., s(ResistancePointCount)}, s(1) < s(2) < ...< s(ResistancePointCount)

-'   ( s(ResistancePointCount)<= tE )- опорные точки

-' 3) число опорных точек ResistancePointCount.

-' 4) s(1) -  первый момент времени с которого определена SupportLine

-'    то есть dom{Supp} = [s(1), tC]

-' Прим. Если число опорных точек окажется < 2, то линия

-' сопротивления не определяется. В этом случае следует

-' увеличить историю tE !!!

-    Dim t As Integer, i As Integer

-    Dim v As Double

-    Dim IsGoodPoint As Boolean

-  

-'1 определение опорных моментов времени

-    ResistancePointCount = 0

-    For t = 3 To tE - 1

- '      v = max{high(t-1), high(t+1)} < high(t)}

-        v = pP.Hgh(t - 1)

-        If v < pP.Hgh(t + 1) Then

-            v = pP.Hgh(t + 1)

-        End If

-        IsGoodPoint = pP.Hgh(t) > v

-        If IsGoodPoint And ClosePrev2 Then

-            IsGoodPoint = IsGoodPoint And (pP.Cls(t - 2) < pP.Hgh(t))

-        End If

-        

-        If IsGoodPoint Then       'alt.: v >= High(t + 1)

-            s(ResistancePointCount + 1) = t: ResistancePointCount = ResistancePointCount + 1

-        End If

-    Next t

-    

-loop_:

-    

-    If ResistancePointCount < 2 Then

-        GoTo done

-    End If

-

-' 2 определение линии сопротивления

-    ResistanceLine(s(1)) = pP.Hgh(s(1))

-    For i = 2 To ResistancePointCount

-        ResistanceLine(s(i)) = pP.Hgh(s(i))

-        v = (pP.Hgh(s(i)) - pP.Hgh(s(i - 1))) / (s(i) - s(i - 1))

-        For t = s(i - 1) + 1 To s(i) - 1

-            ResistanceLine(t) = pP.Hgh(s(i - 1)) + v * (t - s(i - 1))

-        Next t

-    Next i

-    If s(ResistancePointCount) < tE Then

-        v = (pP.Hgh(s(ResistancePointCount)) - pP.Hgh(s(ResistancePointCount - 1))) / (s(ResistancePointCount) - s(ResistancePointCount - 1))

-        For t = s(ResistancePointCount) + 1 To tE

-            ResistanceLine(t) = pP.Hgh(s(ResistancePointCount - 1)) + v * (t - s(ResistancePointCount - 1))

-        Next t

-    End If

-    If CloseSucc1 Then

-        For t = 1 To ResistancePointCount

-            If ResistanceLine(s(t) + 1) < pP.Cls(s(t) + 1) Then

-                ResistancePointCount = ResistancePointCount - 1

-                ' удалить точку

-                For i = t To ResistancePointCount

-                    s(i) = s(i + 1)

-                Next i

-                s(ResistancePointCount + 1) = 0

-                ' очистить массив линии

-                Dim Lb, Rb As Integer

-                Lb = LBound(ResistanceLine)

-                Rb = UBound(ResistanceLine)

-                Erase ResistanceLine

-                ReDim ResistanceLine(Lb To Rb)

-                GoTo loop_

-            End If

-        Next t

-    End If

-    

-done:

-End Sub

-

-Sub SuppLine(pP As TPriceData, tE As Integer, SupportPointsCount As Integer, _

-               SupportLine() As Double, s() As Integer, ClosePrev2 As Boolean, CloseSucc1 As Boolean)

-' Определение линии поддержки по Демарку [1] (от конца)

-' Исходные данные:

-' Low, dom(Low) = [1, tE]

-' ClosePrev2 - H(t) > max{ H(t-1), H(t+1)} и  H(t) > Close(t-2)

-' CloseSucc1 - H(t) > max{ H(t-1), H(t+1)}  и  R(t+1) > Close(t+1)

-' Результат:

-' 1) линия сопротивления SupportLine, dom(SupportLine)=[s(1), tE],

-' 2) s = {s(1), s(2), ..., s(SupportPointsCount)}, s(1) < s(2) < ...< s(SupportPointsCount) -

-'    опорные точки

-' 3) число опорных точек SupportPointsCount.

-' Прим. Если фактическое число опорных точек окажется < 2, то линия

-' поддержки не определяется.

-    Dim t As Integer, i As Integer

-    Dim v As Double

-    Dim IsGoodPoint As Boolean

-    

-'1 определение опорных моментов времени

-     SupportPointsCount = 0

-    For t = 3 To tE - 1

-'       v = min{Low(t-1), Low(t+1)} > Low(t)

-        v = pP.Lw(t - 1)

-        If v > pP.Lw(t + 1) Then

-            v = pP.Lw(t + 1)

-        End If

-        

-        IsGoodPoint = pP.Lw(t) < v

-        

-        If IsGoodPoint And ClosePrev2 Then

-            IsGoodPoint = IsGoodPoint And (pP.Cls(t - 2) > pP.Lw(t))

-        End If

-        

-        If IsGoodPoint Then     'alt.: v >= High(t + 1)

-            s(SupportPointsCount + 1) = t: SupportPointsCount = SupportPointsCount + 1

-        End If

-    Next t

-

-loop_:

-    If SupportPointsCount < 2 Then

-        GoTo done

-    End If

-' 2 определение линии поддержки

-    

-    SupportLine(s(1)) = pP.Lw(s(1))

-    For i = 2 To SupportPointsCount

-        SupportLine(s(i)) = pP.Lw(s(i))

-        v = (pP.Lw(s(i)) - pP.Lw(s(i - 1))) / (s(i) - s(i - 1))

-        For t = s(i - 1) + 1 To s(i) - 1

-            SupportLine(t) = pP.Lw(s(i - 1)) + v * (t - s(i - 1))

-        Next t

-    Next i

-    If s(1) < tE Then

-        v = (pP.Lw(s(SupportPointsCount)) - pP.Lw(s(SupportPointsCount - 1))) / (s(SupportPointsCount) - s(SupportPointsCount - 1))

-        For t = s(SupportPointsCount) + 1 To tE

-            SupportLine(t) = pP.Lw(s(SupportPointsCount - 1)) + v * (t - s(SupportPointsCount - 1))

-        Next t

-    End If

-    If CloseSucc1 Then

-        For t = 1 To SupportPointsCount

-            If SupportLine(s(t) + 1) > pP.Cls(s(t) + 1) Then

-                SupportPointsCount = SupportPointsCount - 1

-                ' удалить точку

-                For i = t To SupportPointsCount

-                    s(i) = s(i + 1)

-                Next i

-                s(SupportPointsCount + 1) = 0

-                ' очистить массив линии

-                Dim Lb, Rb As Integer

-                Lb = LBound(SupportLine)

-                Rb = UBound(SupportLine)

-                Erase SupportLine

-                ReDim SupportLine(Lb To Rb)

-                GoTo loop_

-            End If

-        Next t

-    End If

-done:

-End Sub

-

-<<<<<<
-======================
-mChart
->>>>>>
-Attribute VB_Name = "mChart"

-Option Explicit

-

-Const CHART_NAME As String = "PriceChart"

-

-Sub Draw_Chart(SignalDefined As Boolean)

-

-    Dim n As Integer

-    Dim theChart As Chart

-    Dim ChartDataAria, szLastNumber As String

-    Dim MinYScale As Double

-    

-    

-    With ThisWorkbook

-' Checking data

-' Disable screen out

-        .Application.Cursor = xlWait

-        .Application.ScreenUpdating = False

-' Create series range

-        n = GetLinesCount(Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE))

-        szLastNumber = n + 1

-        If SignalDefined Then

-            ChartDataAria = "A2:A" + szLastNumber + ",D2:E" + szLastNumber + ",I2:K" + szLastNumber

-        Else

-            ChartDataAria = "A2:A" + szLastNumber + ",D2:E" + szLastNumber + ",I2:J" + szLastNumber

-        End If

-        MinYScale = GetMinValue(.Worksheets(RAW_DATA_SHEET).Range(ChartDataAria))

-' Find and delete old chart

-        .Worksheets(CHART_SHEET).Unprotect

-        Dim WindowWidth, WindowHeight As Integer

-        With .Worksheets(CHART_SHEET)

-            WindowWidth = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-            WindowHeight = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-        End With

-        

-        

-        With .Worksheets(CHART_SHEET).ChartObjects

-            .delete

-            With .Add(5, 5, WindowWidth - 10, WindowHeight - 10)

-                .SendToBack

-                Set theChart = .Chart

-            End With

-' Create a chart

-        End With

-        With theChart

-            .ChartType = xlLine

-            .SetSourceData Source:=Sheets(RAW_DATA_SHEET).Range( _

-                    ChartDataAria), PlotBy:=xlColumns

-            .Location Where:=xlLocationAsObject, name:=CHART_SHEET

-            .HasTitle = True

-            With .ChartTitle

-                .Text = ThisWorkbook.Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE).Value

-                With .Font

-                    .Size = 8

-                    .Bold = True

-                End With

-            End With

-            .HasLegend = True

-            With .Legend

-                .Position = xlTop

-                With .Font

-                    .name = "Arial"

-                    .Size = 8

-                End With

-            End With

-            .HasDataTable = False

-            With .Axes(xlCategory)

-                .HasMajorGridlines = True

-                .HasMinorGridlines = False

-                .TickLabels.Orientation = xlUpward

-                With .MajorGridlines.Border

-                    .ColorIndex = 48

-                    .Weight = xlHairline

-                    .LineStyle = xlDot

-                End With

-                .CrossesAt = 1

-                .TickLabelSpacing = 1

-                .TickMarkSpacing = 1

-                .AxisBetweenCategories = False

-                .ReversePlotOrder = False

-                .TickLabels.AutoScaleFont = True

-                With .TickLabels.Font

-                    .name = "Arial"

-                    .Size = 8

-                End With

-            End With

-            With .Axes(xlValue)

-                .HasMajorGridlines = True

-                .HasMinorGridlines = False

-                With .MajorGridlines.Border

-                    .ColorIndex = 48

-                    .Weight = xlHairline

-                    .LineStyle = xlDot

-                End With

-                .MinimumScale = MinYScale

-                .MaximumScaleIsAuto = True

-                .MinorUnitIsAuto = True

-                .MajorUnitIsAuto = True

-                .Crosses = xlCustom

-                .CrossesAt = MinYScale

-                .ReversePlotOrder = False

-                .ScaleType = xlLinear

-                .TickLabels.AutoScaleFont = True

-                With .TickLabels.Font

-                    .name = "Arial"

-                    .Size = 9

-                End With

-            End With

-            .ChartTitle.Top = 5

-            .ChartTitle.Left = 5

-            With .Legend

-                .Top = 5

-                .Fill.OneColorGradient _

-                    Style:=msoGradientHorizontal, _

-                    Variant:=3, _

-                    Degree:=0.303913939116503

-                .Fill.Visible = True

-                .Fill.ForeColor.SchemeColor = 71

-            End With

-            .PlotArea.Left = 10

-            .PlotArea.Top = .Legend.Top + .Legend.Height + 5

-            .PlotArea.Width = .ChartArea.Width - 20

-            .PlotArea.Height = .ChartArea.Height - .PlotArea.Top

-            

-' Tune OPEN line

-            With .SeriesCollection(1)

-                .Border.LineStyle = xlNone

-                .MarkerBackgroundColorIndex = xlNone

-                .MarkerForegroundColorIndex = 1

-                .MarkerStyle = xlPlus

-                .Smooth = False

-                .MarkerSize = 9

-                .Shadow = False

-            End With

-' Tune CLOSE line

-            With .SeriesCollection(2)

-                .Border.ColorIndex = 10

-                .Border.Weight = xlMedium

-                .Border.LineStyle = xlContinuous

-            End With

-' Tune RESISTANCE line

-            With .SeriesCollection(3)

-                .Border.ColorIndex = 3

-                .Border.Weight = xlThin

-                .Border.LineStyle = xlContinuous

-            End With

-' Tune SUUPORT line

-            With .SeriesCollection(4)

-                .Border.ColorIndex = 25

-                .Border.Weight = xlThin

-                .Border.LineStyle = xlContinuous

-            End With

-            If SignalDefined Then

-                With .SeriesCollection(5)

-                    .Border.ColorIndex = 6

-                    .Border.Weight = xlThin

-                    .Border.LineStyle = xlDot

-                End With

-            End If

-        End With

-        .Application.Cursor = xlDefault

-        With .Worksheets(CHART_SHEET)

-            .Range("A1").Select

-            .Protect userInterfaceOnly:=True

-        End With

-    End With

-End Sub

-

-Function GetMinValue(DataRange As Range) As Double

-    Dim Cell As Range

-    Dim MinValue, MaxValue, RangeValue, CorrectValue, Mult As Double

-    MinValue = MAX_PRICE_VALUE

-    MaxValue = MIN_PRICE_VALUE

-    For Each Cell In DataRange

-        If Not IsEmpty(Cell) And IsNumeric(Cell) Then

-            If Cell > MIN_PRICE_VALUE Then

-                If Cell < MinValue Then

-                    MinValue = Cell

-                End If

-                If Cell > MaxValue Then

-                    MaxValue = Cell

-                End If

-            End If

-        End If

-    Next

-    RangeValue = MaxValue - MinValue

-    If RangeValue < 0 Then

-        MinValue = 0

-    Else

-        CorrectValue = RangeValue / 4

-        Mult = MIN_PRICE_VALUE

-        While MinValue - Int(MinValue * Mult) / Mult > CorrectValue

-            Mult = Mult * 10

-        Wend

-        MinValue = Int(MinValue * Mult) / Mult

-    End If

-    GetMinValue = MinValue

-End Function

-

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub GetState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars("Worksheet Menu Bar").Visible = False

-End Sub

-

-

-Public Sub RestoreState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars("Worksheet Menu Bar").Visible = True

-End Sub

-

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{760A52A5-8475-11D2-B33C-525400DB02FE}{760A5296-8475-11D2-B33C-525400DB02FE}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub CommandButton1_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mWebQeury
->>>>>>
-Attribute VB_Name = "mWebQeury"

-Option Explicit

-

-Public Const Qry_DELETE_ALL As String = "Qry_DELETE_ALL"

-Public Const Qry_PATH_NO_CHANGE As String = "Qry_PATH_NO_CHANGE"

-

-

-Sub QryCreate(QryRange As Range, QryName As String, QryPath As String, Optional RefreshBkgnd = False)

-    Dim WebQuery As QueryTable

-    QryDelete QryRange:=QryRange, QryName:=QryName

-    

-    Set WebQuery = QryRange.Worksheet.QueryTables.Add( _

-            Connection:=QryPath, _

-            Destination:=QryRange)

-    

-    With WebQuery

-        .FieldNames = False

-        .name = QryName

-        .RefreshStyle = xlOverwriteCells

-        .RowNumbers = False

-        .FillAdjacentFormulas = False

-        .RefreshOnFileOpen = False

-        .HasAutoFormat = False

-        .BackgroundQuery = False

-        .TablesOnlyFromHTML = False

-        .Refresh BackgroundQuery:=RefreshBkgnd

-        .SavePassword = False

-        .SaveData = True

-    End With

-End Sub

-

-Function QryRefresh(QryRange As Range, QryName As String, Optional QryPath As String = Qry_PATH_NO_CHANGE, Optional Background As Boolean = False) As Boolean

-    Dim qry_result As Boolean

-    qry_result = False

-    If QryExist(QryRange, QryName) Then

-        With QryRange.Worksheet.QueryTables(QryName)

-            If QryPath <> Qry_PATH_NO_CHANGE Then

-                .Connection = QryPath

-            End If

-            .Refresh BackgroundQuery:=Background

-            qry_result = True

-        End With

-    End If

-    QryRefresh = qry_result

-End Function

-

-Sub QryDelete(QryRange As Range, Optional QryName As String = Qry_DELETE_ALL)

-    Dim WebQuery As QueryTable

-    For Each WebQuery In QryRange.Worksheet.QueryTables

-        If QryName = Qry_DELETE_ALL Or WebQuery.name = QryName Then

-            WebQuery.delete

-        End If

-    Next

-End Sub

-

-Function QryExist(QryRange As Range, QryName As String) As Boolean

-    Dim WebQuery As QueryTable

-    For Each WebQuery In QryRange.Worksheet.QueryTables

-        If WebQuery.name = QryName Then

-            QryExist = True

-            Exit For

-        End If

-    Next

-End Function

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Sub CreateCommandBar(theApp As Application)

-Attribute CreateCommandBar.VB_ProcData.VB_Invoke_Func = "R\n14"

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible + msoBarNoCustomize + msoBarNoMove + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Print"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 4

-                        .OnAction = "cmPrint"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Contents"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 49

-                        .OnAction = "cmHelpContents"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible + msoBarNoCustomize + msoBarNoMove + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(Flag As Boolean)

-    If Flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars("Worksheet Menu Bar")

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim curdate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    curdate = year * 10000

-    curdate = curdate + month * 100

-    curdate = curdate + day

-    If curdate > end_date Then

-        cmAbout

-        cmHelpContents

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mTool
->>>>>>
-Attribute VB_Name = "mTool"

-Option Explicit

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub tool_delete_all_tables()

-    QryDelete ThisWorkbook.Worksheets(RAW_DATA_SHEET).Range("A1")

-End Sub

-

-Sub tool_delete_all_charts(theSheet As Worksheet)

-    Dim theChart As Chart

-    For Each theChart In theSheet

-        theChart.Unprotect

-        theChart.delete

-    Next

-End Sub

-

-Sub DateTimeTest()

-    Dim the_date

-    Dim the_time

-    the_date = DateValue(Now)

-    the_time = TimeValue(Now)

-End Sub

-

-

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{760A52A9-8475-11D2-B33C-525400DB02FE}{760A529E-8475-11D2-B33C-525400DB02FE}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-

-

-Private Sub App_WorkbookOpen(ByVal wb As Workbook)

-    Dim wbname As String

-    If Application.Workbooks.count > 1 Then

-        wbname = wb.FullName

-        wb.Close Savechanges:=False

-        Shell "EXCEL " & wbname

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-Project Name : 'Denmark_method'
-Quirk - duff tag length======================
-MGetWebData
->>>>>>
-Attribute VB_Name = "MGetWebData"

-Option Explicit

-

-Dim mobjAppRunEnable As New cEnableRun

-

-Const QueryDataName As String = "ExternalDenmarkData"

-

-Function UpdateHistoryFromWeb(wb As Workbook) As Boolean

-    Dim DestRangeName As String

-    Dim ResultLength As Integer

-    Dim QryPathStr As String

-    Dim Location As Range

-    Dim denWindow As Integer

-    Dim IsIntraday As Boolean

-    Dim CalcNextTime As Boolean

-        

-    UpdateHistoryFromWeb = False

-    QryPathStr = GetQryPath(wb)

-    With wb

-        .Application.ScreenUpdating = False

-        With .Worksheets(VAR_SHEET)

-            DestRangeName = .Range("DEN_SYMBOL")

-            CalcNextTime = .Range("BOOL_NEXT_TIME")

-            denWindow = .Range("DEN_WINDOW")

-            If CalcNextTime Then

-                denWindow = denWindow + 1

-            End If

-            IsIntraday = IsNumeric(.Range("DEN_TIME"))

-        End With

-        With .Worksheets(RAW_DATA_SHEET)

-            .Range(PRICE_TABLE) = DestRangeName

-            'Clear table and temp area

-            With .Range( _

-                .Cells(RAW_DATA_RANGE_ROW - 1, RAW_DATA_RANGE_COL - 1), _

-                .Cells(65535, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE))

-                .ClearContents

-                .NumberFormat = "General"

-            End With

-            

-            Set Location = .Range(RAW_DATA_RANGE).Offset(-1, 0)

-            If Not QryExist(Location, QueryDataName) Then

-                QryCreate Location, QueryDataName, QryPathStr

-            Else

-                QryRefresh Location, QueryDataName, QryPathStr

-            End If

-            With Location.Worksheet.QueryTables(QueryDataName)

-                DestRangeName = .ResultRange.Name.RefersTo

-                ResultLength = .ResultRange.count

-            End With

-    

-'            .Parent.Application.DisplayAlerts = False

-    

-            If ResultLength < denWindow Then

-                Exit Function

-            End If

-            

-            .Range(DestRangeName).TextToColumns _

-                Destination:=Range(DestRangeName), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=True, _

-                Space:=False, _

-                Other:=False, _

-                OtherChar:="|", _

-                FieldInfo:=Array( _

-                                Array(1, 9), _

-                                Array(2, 2), _

-                                Array(3, 1), _

-                                Array(4, 1), _

-                                Array(5, 1), _

-                                Array(6, 1), _

-                                Array(7, 1), _

-                                Array(8, 9), _

-                                Array(9, 9), _

-                                Array(10, 9), _

-                                Array(11, 9), _

-                                Array(12, 9))

-            

-            .Range(DestRangeName).EntireColumn.AutoFit

-            

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(65536, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-            ).NumberFormat = "General"

-            

-            Dim RawData As Range

-            Dim row_idx As Integer

-            

-            Set RawData = .Range(DestRangeName).Offset(0, 1)

-            RawData.Insert Shift:=xlToRight

-            

-            If Not IsIntraday Then

-                Set RawData = RawData.Offset(0, -1)

-                RawData.Value = "18:00"

-                RawData.Cells(1, 1).FormulaR1C1 = "TIME"

-                Set RawData = RawData.Offset(0, -1)

-            Else

-                Set RawData = RawData.Offset(0, -2)

-                RawData.TextToColumns _

-                    Destination:=RawData, _

-                    DataType:=xlDelimited, _

-                    TextQualifier:=xlDoubleQuote, _

-                    ConsecutiveDelimiter:=False, _

-                    Tab:=False, _

-                    Semicolon:=False, _

-                    Comma:=False, _

-                    Space:=True, _

-                    Other:=False, _

-                    OtherChar:="/", _

-                    FieldInfo:=Array( _

-                                    Array(1, 2), _

-                                    Array(2, 2))

-                RawData.Cells(1, 2).FormulaR1C1 = "TIME"

-            End If

-            

-'            Dim end_date As Date

-'            end_date = RawData.Cells(ResultLength, 1).FormulaR1C1

-

-' Delete unused space

-            

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW + ResultLength, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(65536, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-            ).ClearContents

-            

-            Dim i As Integer

-' Delete blank intervals

-            

-            Set RawData = .Range(RAW_DATA_RANGE).Offset(0, 0)

-            row_idx = 0

-            For i = 1 To ResultLength

-                ' skip virtual prices

-                If RawData.Offset(row_idx, CLOSE_IDX).Value > MIN_PRICE_VALUE Then

-                    row_idx = row_idx + 1

-                Else

-                    Set Location = .Range( _

-                            .Cells(row_idx + RAW_DATA_RANGE_ROW, DATE_IDX + RAW_DATA_RANGE_COL), _

-                            .Cells(row_idx + RAW_DATA_RANGE_ROW, PROJECT_IDX + RAW_DATA_RANGE_COL) _

-                    )

-                    Location.Delete xlShiftUp

-                End If

-            Next i

-            

-            ResultLength = GetLinesCount(.Range(RAW_DATA_RANGE))

-            

-            row_idx = ResultLength - 1

-            If row_idx > denWindow Then

-                row_idx = row_idx - denWindow

-                .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-                ).Delete xlShiftUp

-            Else

-                Exit Function

-            End If

-            

-            Dim TmpStr As String

-                        

-            row_idx = GetLinesCount(.Range(RAW_DATA_RANGE))

-            

-            Set RawData = .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx - 1, RAW_DATA_RANGE_COL + DATE_IDX) _

-                )

-            RawData.TextToColumns _

-                Destination:=.Range(RAW_DATA_RANGE).Offset(0, DATE_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:="-", _

-                FieldInfo:=Array( _

-                                Array(1, 2), _

-                                Array(2, 2), _

-                                Array(3, 2))

-            

-            Set Location = .Range(RAW_DATA_RANGE).Offset(0, -1)

-            

-            If IsIntraday Then

-                Set RawData = .Range( _

-                            .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + TIME_IDX), _

-                            .Cells(RAW_DATA_RANGE_ROW + row_idx - 1, RAW_DATA_RANGE_COL + TIME_IDX) _

-                    )

-                RawData.TextToColumns _

-                    Destination:=.Range(RAW_DATA_RANGE).Offset(0, TIME_STAMP_OFFSET), _

-                    DataType:=xlDelimited, _

-                    TextQualifier:=xlDoubleQuote, _

-                    ConsecutiveDelimiter:=False, _

-                    Tab:=False, _

-                    Semicolon:=False, _

-                    Comma:=False, _

-                    Space:=False, _

-                    Other:=True, _

-                    OtherChar:=":", _

-                    FieldInfo:=Array( _

-                                    Array(1, 2), _

-                                    Array(2, 2), _

-                                    Array(3, 2))

-                                    

-                

-                For i = 0 To row_idx - 1

-                    Location.Offset(i, 0) = "'" & _

-                            .Range(RAW_DATA_RANGE).Offset(i, DATE_STAMP_OFFSET + 1).Value _

-                            & "/" & .Range(RAW_DATA_RANGE).Offset(i, DATE_STAMP_OFFSET + 2).Value _

-                            & "-" & .Range(RAW_DATA_RANGE).Offset(i, TIME_STAMP_OFFSET).Value _

-                            & ":" & .Range(RAW_DATA_RANGE).Offset(i, TIME_STAMP_OFFSET + 1).Value

-                Next

-            Else

-                For i = 0 To row_idx - 1

-                    Location.Offset(i, 0) = "'" & _

-                            .Range(RAW_DATA_RANGE).Offset(i, DATE_STAMP_OFFSET + 2).Value _

-                            & "/" & .Range(RAW_DATA_RANGE).Offset(i, DATE_STAMP_OFFSET + 1).Value _

-                            & "/" & .Range(RAW_DATA_RANGE).Offset(i, DATE_STAMP_OFFSET).Value

-                Next

-            End If

-            .Parent.Application.DisplayAlerts = True

-        End With ' .Worksheets(RAW_DATA_SHEET)

-    End With ' wb

-    UpdateHistoryFromWeb = True

-End Function

-

-Private Function GetQryPath(wb As Workbook) As String

-    Dim QryPathStr As String

-    Dim IsIntradai As Boolean

-    Dim DayCount As Integer

-    Const DataFormat As String = "&data_format=BROWSER"

-    With wb.Worksheets(VAR_SHEET)

-        IsIntradai = IsNumeric(.Range("DEN_TIME"))

-        

-        If IsIntradai Then

-        

-            QryPathStr = "URL;http://export.rbc.ru/export/"

-            QryPathStr = QryPathStr & .Range("DEN_SOURCE")

-            QryPathStr = QryPathStr & "." & .Range("DEN_BOARD")

-            QryPathStr = QryPathStr & "/?"

-            

-            QryPathStr = QryPathStr & "tickers=" & .Range("DEN_SYMBOL")

-            QryPathStr = QryPathStr & "&period=" & .Range("DEN_TIME")

-            QryPathStr = QryPathStr & "&virtual=PASS"

-            DayCount = .Range("DEN_HISTORY") * .Range("DEN_TIME") \ 420 + 1

-            QryPathStr = QryPathStr & "&lastdays=" & DayCount

-            QryPathStr = QryPathStr & "&separator=,"

-            QryPathStr = QryPathStr & DataFormat

-            QryPathStr = QryPathStr & "&header=1"

-        Else

-            QryPathStr = "URL;http://export.rbc.ru/cgi-bin/export/query_version/export.cgi?"

-            QryPathStr = QryPathStr & "&sourcename=" & .Range("DEN_SOURCE")

-            QryPathStr = QryPathStr & "." & .Range("DEN_BOARD")

-            QryPathStr = QryPathStr & "&tickers=" & .Range("DEN_SYMBOL")

-            QryPathStr = QryPathStr & "&period=DAILY"

-            QryPathStr = QryPathStr & "&virtual=PASS"

-            QryPathStr = QryPathStr & "&lastdays=" & .Range("DEN_HISTORY") + 1

-            QryPathStr = QryPathStr & "&separator=,"

-            QryPathStr = QryPathStr & DataFormat

-            QryPathStr = QryPathStr & "&header=1"

-        End If

-    .Range("LAST_HIST_QRY") = QryPathStr

-    End With

-    GetQryPath = QryPathStr

-End Function

-

-Sub UpdateTickerList(wb As Workbook)

-    Dim Idx, n As Integer

-    Dim ResultLength As Integer

-    Dim Location As Range

-    Dim QryPathStr As String

-    Dim QueryDataName As String

-    Dim DestRangeArea As String

-    

-    QryPathStr = GetListPath(wb)

-    With wb

-        With .Worksheets(VAR_SHEET)

-            Idx = .Range("IDX_DEN_LIST")

-            Set Location = .Range("TICKER_TABLES").Offset(0, (Idx - 1) * 2)

-             .Range("IDX_DEN_SYMBOL") = 1

-            QueryDataName = Location.Offset(0, 0)

-            'Clear table

-            .Range(Location.Offset(1, 0), Location.Offset(65535 - Location.Row, 1)).ClearContents

-            

-            If Not QryExist(Location.Offset(1, 0), QueryDataName) Then

-                QryCreate Location.Offset(1, 0), QueryDataName, QryPathStr

-            Else

-                QryRefresh Location.Offset(1, 0), QueryDataName, QryPathStr

-            End If

-            

-            With .QueryTables(QueryDataName)

-                DestRangeArea = .ResultRange.Name.RefersTo

-                ResultLength = .ResultRange.count

-            End With

-        

-            .Parent.Application.DisplayAlerts = False

-                

-            .Range(DestRangeArea).TextToColumns _

-                Destination:=.Range(DestRangeArea), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:=":", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 9))

-        ' Sort Data

-            Set Location = .Range(.Range(DestRangeArea).Offset(0, 0), .Range(DestRangeArea).Offset(ResultLength - 1, 1))

-            Location.Sort _

-                Key1:=.Range(DestRangeArea).Offset(0, 0), _

-                Order1:=xlAscending, _

-                Header:=xlNo, _

-                OrderCustom:=1, _

-                MatchCase:=False, _

-                Orientation:=xlTopToBottom

-        End With

-        ' Setup Ticker List

-         With .Worksheets(VAR_SHEET)

-            DestRangeArea = .Name & "!" & .Range(.Range(DestRangeArea).Cells(1, 1), .Range(DestRangeArea).Cells(ResultLength - 1, 1)).Address

-         End With

-        With .Worksheets(FORM_SHEET).Shapes("cbxTikers").ControlFormat

-            .ListFillRange = DestRangeArea

-            .ListIndex = 1

-        End With

-        ' Setup Name List

-         With .Worksheets(VAR_SHEET)

-            DestRangeArea = .Name & "!" & .Range(.Range(DestRangeArea).Cells(1, 1), .Range(DestRangeArea).Cells(ResultLength - 1, 1)).Offset(0, 1).Address

-         End With

-        With .Worksheets(FORM_SHEET).Shapes("cbxSecName").ControlFormat

-            .ListFillRange = DestRangeArea

-            .ListIndex = 1

-        End With

-        .Parent.Application.DisplayAlerts = True

-    End With

-End Sub

-

-Private Function GetListPath(wb As Workbook) As String

-    Dim QryPathStr As String

-    With wb.Worksheets(VAR_SHEET)

-        QryPathStr = "URL;http://export.rbc.ru/cgi-bin/export/tickers.cgi?"

-        QryPathStr = QryPathStr & "&source=" & .Range("DEN_SOURCE")

-        QryPathStr = QryPathStr & "." & .Range("DEN_BOARD")

-        .Range("LAST_DIR_QRY") = QryPathStr

-    End With

-    GetListPath = QryPathStr

-End Function

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    Set MyAppEvents.app = Application

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    If Application.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEL сейчас будут закрыты!", vbOKCancel, "$" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close Savechanges:=False

-            Exit Sub

-        End If

-    End If

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False

-    cmSetStandaloneMode

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment wb:=ThisWorkbook, DesignMode:=False

-        If ThisWorkbook.Saved = False Then

-            ThisWorkbook.Save

-        End If

-    End If

-    Application.Caption = Empty

-    Application.CommandBars("Worksheet Menu Bar").Reset

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-        Dim MaxX, MaxY As Integer

-        With ThisWorkbook.Worksheets(FORM_SHEET)

-            MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-            MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-        End With

-

-        With ThisWorkbook.Application

-            .ScreenUpdating = False

-            .WindowState = xlNormal

-            .Height = MaxY

-            .Width = MaxX

-        End With

-End Sub

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-<<<<<<
-======================
-mReadWrite
->>>>>>
-Attribute VB_Name = "mReadWrite"

-Option Explicit

-

-Public Const GOOD_LINE_STATUS As String = "Ok"

-Public Const BAD_LINE_STATUS As String = "N/A"

-

-Function ReadPricesData(Location As Range, Hist As Integer, dt As Integer, _

-              pPriceData As TPriceData) As Integer

-    'Инициализация типа TPriceData из таблицы типа - 1

-    'kопируются не более чем hist последних строк

-    'aPoint - начало таблицы

-    'первые две строки таблицы идентифицирует данные (строки)

-    Dim n, i As Integer

-    

-    'Определение числа строк таблицы - n

-    n = GetLinesCount(Location)

-    ReadPricesData = n

-    If n < 9 Then             'обработать ошибку !!!

-        GoTo done

-    End If

-    ' число строк определено ()

-    If Hist > (n - 3) \ dt + 1 Then ' коррекция истории

-        Hist = (n - 3) \ dt + 1 '

-    End If

-    Dim t, s As Integer

-    For t = 0 To Hist - 1

-        s = n - t * dt - 1

-        pPriceData.D(Hist - t) = Location.Offset(s, DATE_IDX).Value

-        pPriceData.Tm(Hist - t) = Location.Offset(s, TIME_IDX).Value

-        pPriceData.Opn(Hist - t) = Location.Offset(s, OPEN_IDX).Value

-        pPriceData.Hgh(Hist - t) = Location.Offset(s, HIGH_IDX).Value

-        pPriceData.Lw(Hist - t) = Location.Offset(s, LOW_IDX).Value

-        pPriceData.Cls(Hist - t) = Location.Offset(s, CLOSE_IDX).Value

-        pPriceData.Vl(Hist - t) = Location.Offset(s, VOLUME_IDX).Value

-    Next t

-    ReadPricesData = t + 1

-done:

-End Function

-

-Sub ResultLinesOut(Location As Range, pPD As TPriceData, pDen As TDenmark)

-    Dim n As Integer

-    

-    n = GetLinesCount(Location)

-    With Location

-        .Offset(-1, RESIST_IDX) = "Resistance"

-        .Offset(-1, SUPPORT_IDX) = "Support"

-        .Offset(-1, PROJECT_IDX) = "Project"

-    End With

-    Dim t, count, Idx, loc_idx As Integer

-    count = pPD.tC

-    For t = 0 To count - 1

-        Idx = count - t

-        loc_idx = n - t - 1

-        If pDen.ResistanceLine(Idx) > MIN_PRICE_VALUE Then

-            Location.Offset(loc_idx, RESIST_IDX).Value = pDen.ResistanceLine(Idx)

-        End If

-        If pDen.SupportLine(Idx) > MIN_PRICE_VALUE Then

-            Location.Offset(loc_idx, SUPPORT_IDX).Value = pDen.SupportLine(Idx)

-        End If

-        If Abs(pDen.SignalValue) > 1 Then

-            Location.Offset(loc_idx, PROJECT_IDX).Value = pDen.ProjectPrice

-        End If

-    Next t

-End Sub

-

-Sub Out_Table_1(TheRange As Range, pDen As TDenmark, LastIdx As Integer)

-    

-    

-    ' Col = 2 - не определен !!!

-    ' Status - Col = 0

-    If pDen.ResistancePointCount >= 2 Then

-        TheRange.Offset(0, 0).Value = GOOD_LINE_STATUS

-    Else

-        TheRange.Offset(0, 0).Value = BAD_LINE_STATUS

-    End If

-    If pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(1, 0).Value = GOOD_LINE_STATUS

-    Else

-        TheRange.Offset(1, 0).Value = BAD_LINE_STATUS

-    End If

-    ' -----------------------------------------

-    ' углы наклонов линии сопротивления и поддержки - Col = 1

-    If pDen.ResistancePointCount >= 2 Then

-        TheRange.Offset(0, 1).Value = pDen.ResistanceAngle

-    End If

-    If pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(1, 1).Value = pDen.SupportAngle

-    End If

-    If pDen.ResistancePointCount >= 2 And pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(2, 1).Value = (pDen.ResistanceAngle + pDen.SupportAngle) / 2

-    End If

-    ' -----------------------------------------

-    ' Опорные цены линий денмарка на текущий момент

-    If pDen.ResistancePointCount >= 2 Then

-        TheRange.Offset(0, 2).Value = pDen.ResistanceLine(LastIdx)

-    End If

-    If pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(1, 2).Value = pDen.SupportLine(LastIdx)

-    End If

-    If pDen.ResistancePointCount >= 2 And pDen.SupportPointsCount >= 2 Then

-        TheRange.Offset(2, 2).Value = _

-            (pDen.ResistanceLine(LastIdx) + pDen.SupportLine(LastIdx)) / 2

-    End If

-    

-End Sub

-

-Sub Out_Table_2(TheRange As Range, TheComment As Range, pPD As TPriceData, pDen As TDenmark)

-    Const ColorIndexBUY = 5

-    Const ColorIndexSELL = 3

-    Const ColorIndexNOTHINK = 14

-    

-    Dim SignalValue_defined, allert_enable  As Boolean

-    Dim Message As String

-    SignalValue_defined = False

-    allert_enable = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_ALLERT_DLG")

-    Message = "Сигнал об изменении тренда не идентифицирован."

-    If pDen.SignalValue >= 2 Then

-        SignalValue_defined = True

-        With TheRange.Offset(0, 0)

-            .Value = "BUY"

-            .Font.Bold = True

-            .Font.ColorIndex = ColorIndexBUY

-        End With

-        TheRange.Offset(0, 1).Value2 = pPD.D(pPD.tC)

-        TheRange.Offset(0, 2).Value2 = pPD.Tm(pPD.tC)

-        TheRange.Offset(0, 3).Value = pDen.SignalValue - 1

-        TheRange.Offset(0, 4).Value = pDen.ProjectPrice

-        Message = "BUY Signal: возможен прорыв вверх нисходящего тренда с уровнем значимости = " & pDen.SignalValue - 1 & " ! "

-    End If

-    If pDen.SignalValue <= -2 Then

-        SignalValue_defined = True

-        With TheRange.Offset(0, 0)

-            .Value = "SELL"

-            .Font.Bold = True

-            .Font.ColorIndex = ColorIndexSELL

-        End With

-        TheRange.Offset(0, 1).Value2 = pPD.D(pPD.tC)

-        TheRange.Offset(0, 2).Value2 = pPD.Tm(pPD.tC)

-        TheRange.Offset(0, 3).Value = pDen.SignalValue + 1

-        TheRange.Offset(0, 4).Value = pDen.ProjectPrice

-        Message = "SELL Signal: возможен прорыв вниз восходящего тренда с уровнем значимости = " & -(pDen.SignalValue + 1) & "!"

-    End If

-    With TheComment

-        .Value = Message

-        .Font.Bold = True

-        Dim color_idx As Integer

-        If SignalValue_defined Then

-            If pDen.SignalValue > 0 Then

-                .Font.ColorIndex = ColorIndexBUY

-            Else

-                .Font.ColorIndex = ColorIndexSELL

-            End If

-        Else

-            .Font.ColorIndex = ColorIndexNOTHINK

-        End If

-    End With

-    If allert_enable And SignalValue_defined Then

-        MsgBox _

-            Prompt:=Message, _

-            Title:=PROGRAM_NAME, _

-            Buttons:=vbOKOnly + vbInformation

-    End If

-End Sub

-

-Sub Out_Table_3(TheRange As Range, pDen As TDenmark)

-    Dim i As Integer

-    For i = 1 To 3

-        TheRange.Offset(i - 1, 0).Value = pDen.Qualificator(i)

-    Next i

-End Sub

-

-Sub Out_Table_4(TheRange As Range, pPD As TPriceData)

-    Dim LastIdx As Integer

-    LastIdx = pPD.tC

-    With TheRange

-        .Offset(0, 0).Value2 = "'" & pPD.D(LastIdx)

-        .Offset(0, 1).Value2 = "'" & pPD.Tm(LastIdx)

-        .Offset(0, 2) = pPD.Opn(LastIdx)

-        .Offset(0, 3) = pPD.Hgh(LastIdx)

-        .Offset(0, 4) = pPD.Lw(LastIdx)

-        .Offset(0, 5) = pPD.Cls(LastIdx)

-        .Offset(0, 6) = pPD.Cls(LastIdx) - pPD.Cls(LastIdx - 1)

-    End With

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Denmark method bar"

-Public Const common_pwd As Long = 31415926

-

-

-Sub SetEnvironment(wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    With Application

-        .Caption = PROGRAM_NAME

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .GetState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-    End With

-    With wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(FORM_SHEET).Select

-    End With

-    CreateCommandBar theApp:=wb.Application

-End Sub

-

-Sub RestoreEnvironment(wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Application.ScreenUpdating = False

-    With wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                     cWindow.DisplayHeadings = True

-                Next

-            End If

-        Next

-        .Worksheets(FORM_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu (True)

-        End If

-        With mobjAppState

-            .RestoreState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(wb As Workbook)

-    With wb

-        .Application.ScreenUpdating = False

-        

-        With .Worksheets(RAW_DATA_SHEET)

-            .Visible = xlVeryHidden

-            .Protect Password:=common_pwd, userInterfaceOnly:=True, Contents:=False

-        End With

-        With .Worksheets(VAR_SHEET)

-            .Visible = xlVeryHidden

-            .Protect Password:=common_pwd, userInterfaceOnly:=True, Contents:=False

-        End With

-        With .Worksheets(FORM_SHEET)

-            .EnableSelection = xlNoSelection

-            .Protect userInterfaceOnly:=True

-            .Select

-        End With

-        With .Worksheets(CHART_SHEET)

-            .EnableSelection = xlNoSelection

-            .Protect userInterfaceOnly:=True

-        End With

-        .Protect Windows:=True

-        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(wb As Workbook)

-    With wb

-        .Unprotect

-        .Application.ScreenUpdating = False

-        With .Worksheets(RAW_DATA_SHEET)

-            .Visible = xlVeryHidden

-            .Unprotect Password:=common_pwd

-        End With

-        With .Worksheets(VAR_SHEET)

-            .Visible = xlVeryHidden

-            .Unprotect Password:=common_pwd

-        End With

-        With .Worksheets(CHART_SHEET)

-            .Select

-            .Unprotect

-        End With

-        With .Worksheets(FORM_SHEET)

-            .Select

-            .Unprotect

-        End With

-        .Application.ScreenUpdating = True

-        

-    End With

-End Sub

-

-<<<<<<
-======================
-mTypes
->>>>>>
-Attribute VB_Name = "mTypes"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Метод г-на Демарка II"

-Public Const PROGRAM_VERSION As String = "version 4.3 Professional"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-

-Public Const ESTIMATION_DATE As Long = 20011215

-'Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "J27"

-

-Public Const RAW_DATA_SHEET As String = "Raw_data"

-Public Const PRICE_TABLE As String = "B1"

-Public Const RAW_DATA_RANGE As String = "B3"

-Public Const RAW_DATA_RANGE_COL As Integer = 2

-Public Const RAW_DATA_RANGE_ROW As Integer = 3

-

-Public Const VAR_SHEET As String = "Var_s"

-

-Public Const CHART_SHEET As String = "Chart"

-

-Public Const MIN_PRICE_VALUE As Double = 0.000001

-Public Const MAX_PRICE_VALUE As Double = 1000000000

-

-' Fields indexes in RAW_DATA_RANGE

-Public Const DATE_IDX As Integer = 0

-Public Const TIME_IDX As Integer = 1

-Public Const OPEN_IDX As Integer = 2

-Public Const HIGH_IDX As Integer = 3

-Public Const LOW_IDX As Integer = 4

-Public Const CLOSE_IDX As Integer = 5

-Public Const VOLUME_IDX As Integer = 6

-Public Const RESIST_IDX As Integer = 7

-Public Const SUPPORT_IDX As Integer = 8

-Public Const PROJECT_IDX As Integer = 9

-

-Public Const DATE_STAMP_OFFSET = PROJECT_IDX + 1

-Public Const TIME_STAMP_OFFSET = PROJECT_IDX + 4

-Public Const DATE_TIME_STAMP_SIZE = 5

-

-Type TPriceData

-    D() As String      ' календарная дата

-    Tm() As String     ' время

-    Opn() As Double    ' Open

-    Hgh() As Double    ' High

-    Lw() As Double     ' Low

-    Cls() As Double    ' Close

-    Vl() As Double     ' Volume

-    tC As Integer      ' Current time

-End Type

-

-Type TDenmark

-   ResistanceLine() As Double           'Resistance line

-   ResistancePoints() As Integer        'Resistance pivot points

-   ResistancePointCount As Integer      'The number of resistance pivot points

-   ResistanceAngle As Double            'Angle of Declination of ResistanceLine

-   

-   SupportLine() As Double              'Support line

-   SupportPoints() As Integer           'Support pivot points

-   SupportPointsCount As Integer        'The number of support pivot points

-   SupportAngle As Double               ' Angle of Declination of SupportLine

-   

-   SignalParameter     As Integer       ' parameter for SignalValue

-   SignalValue      As Integer          'SignalValue

-   

-   

-   Qualificator(1 To 3) As String       ' qualificators

- 

-   ProjectNumber As Integer             ' номер проекции

-   ProjectPrice  As Double              ' проекция цены

-   

-End Type

-

-

-<<<<<<
-======================
-mCommands
->>>>>>
-Attribute VB_Name = "mCommands"

-Option Explicit

-Dim AppRunEnable As New cEnableRun

-

-

-Sub cmViewChart(Optional SwapPage As Boolean = True)

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("BOOL_CHART_READY") = False

-        If .Range("BOOL_DEMARK_READY") <> True Then

-            If .Range("BOOL_AUTORECALC") = True Then

-                evSubmit_Click

-                If .Range("BOOL_DEMARK_READY") <> True Then

-                    Exit Sub

-                End If

-            Else

-                MsgBox _

-                    "График не может быть построен." & vbCrLf & "Исходные данные не обработаны.", _

-                    vbOKOnly + vbExclamation, _

-                    PROGRAM_NAME

-                Exit Sub

-            End If

-        End If

-    End With

-    With ThisWorkbook.Worksheets(FORM_SHEET)

-        With .Range("TABLE_1")

-            Dim test_lines As Boolean

-            test_lines = StrComp(.Cells(1, 1).Value, GOOD_LINE_STATUS)

-            test_lines = test_lines + StrComp(.Cells(2, 1).Value, GOOD_LINE_STATUS)

-            If test_lines <> 0 Then

-                MsgBox _

-                    Prompt:="График не может быть построен." & vbCrLf & "Опорные точки не определены .", _

-                    Title:=PROGRAM_NAME, _

-                    Buttons:=vbOKOnly + vbExclamation

-                Exit Sub

-            End If

-        End With

-        Draw_Chart Not IsEmpty(.Range("TABLE_2").Cells(1, 1))

-    End With

-    With ThisWorkbook

-        .Worksheets(VAR_SHEET).Range("BOOL_CHART_READY") = True

-        If SwapPage Then

-            .Worksheets(CHART_SHEET).Select

-        End If

-    End With

-End Sub

-

-Sub cmViewForm()

-    With ThisWorkbook

-        .Worksheets(FORM_SHEET).Select

-    End With

-End Sub

-

-Sub cmCloseProgram()

-    Dim ResistanceLine

-    ResistanceLine = MsgBox( _

-        Prompt:="Вы желаете завершить программу?", _

-        Buttons:=vbQuestion + vbYesNo, _

-        Title:=PROGRAM_NAME _

-    )

-    If ResistanceLine = vbYes Then

-       Application.Quit

-    End If

-End Sub

-

-Sub cmAbout()

-    dlgAbout.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlgAbout.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlgAbout.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlgAbout.Show

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-        helppath = "hh.exe " & .Path & "\Demark.chm"

-        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub cmSetStandaloneMode()

-    Application.ScreenUpdating = False

-    ProtectionDisable wb:=ThisWorkbook

-    SetEnvironment wb:=ThisWorkbook

-    ProtectionEnable wb:=ThisWorkbook

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    rp = common_pwd

-    dlgGetPwd.edPwd = ""

-    dlgGetPwd.Show

-    If dlgGetPwd.edPwd = rp Then

-        ProtectionDisable wb:=ThisWorkbook

-        RestoreEnvironment wb:=ThisWorkbook, DesignMode:=True

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmPrint()

-    If MsgBox( _

-            Prompt:="Вы желаете распечатать результат?", _

-            Buttons:=vbYesNo + vbQuestion, _

-            Title:=PROGRAM_NAME) = vbNo _

-    Then

-        Exit Sub

-    End If

-    Dim s_ticker, s_name, s_time As String

-    s_ticker = ThisWorkbook.Worksheets(FORM_SHEET).Range("CALC_TICKER_NAME")

-    s_name = ThisWorkbook.Worksheets(FORM_SHEET).Range("CALC_NAME")

-    s_time = Now

-    Application.ScreenUpdating = False

-    cmViewChart SwapPage:=False

-    Application.ScreenUpdating = False

-    With ThisWorkbook.Worksheets(FORM_SHEET).PageSetup

-        .LeftHeader = s_ticker

-        .CenterHeader = PROGRAM_NAME

-        .RightHeader = s_time

-        .LeftFooter = s_name

-        .CenterFooter = "Page &P of &N"

-        .RightFooter = ""

-        .LeftMargin = Application.InchesToPoints(0.75)

-        .RightMargin = Application.InchesToPoints(0.75)

-        .TopMargin = Application.InchesToPoints(0.78)

-        .BottomMargin = Application.InchesToPoints(0.92)

-        .HeaderMargin = Application.InchesToPoints(0.5)

-        .FooterMargin = Application.InchesToPoints(0.5)

-        .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 = 2

-    End With

-    With ThisWorkbook.Worksheets(CHART_SHEET).PageSetup

-        .LeftHeader = s_ticker

-        .CenterHeader = PROGRAM_NAME

-        .RightHeader = s_time

-        .LeftFooter = s_name

-        .CenterFooter = "Page &P of &N"

-        .RightFooter = ""

-        .LeftMargin = Application.InchesToPoints(0.75)

-        .RightMargin = Application.InchesToPoints(0.75)

-        .TopMargin = Application.InchesToPoints(0.78)

-        .BottomMargin = Application.InchesToPoints(0.92)

-        .HeaderMargin = Application.InchesToPoints(0.5)

-        .FooterMargin = Application.InchesToPoints(0.5)

-        .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 = 2

-    End With

-    Application.ScreenUpdating = False

-    ThisWorkbook.Worksheets(Array("MainForm", "Chart")).PrintOut Copies:=1, Collate:=True

-    cmViewForm

-End Sub

-<<<<<<
-======================
-mDemark
->>>>>>
-Attribute VB_Name = "mDemark"

-Option Explicit

-

-Public Const FORM_SHEET As String = "MainForm"

-

-'Form Ranges

-Public Const FILE_NAME As String = "FILE_NAME"

-Public Const TABLE_1 As String = "TABLE_1"

-Public Const TABLE_2 As String = "TABLE_2"

-Public Const TABLE_3 As String = "TABLE_3"

-Public Const TABLE_4 As String = "TABLE_4"

-Public Const TABLE_COMMENT As String = "TABLE_COMMENT"

-

-'Основной тип данных - стандарт 1

-

-'*********************

-Dim PriceDataArray As TPriceData

-Dim DenmarkDataArray As TDenmark

-

-Dim mobjAppRunEnable As New cEnableRun

-

-Sub ClearResultTables()

-    With ThisWorkbook.Worksheets(FORM_SHEET)

-        .Range(TABLE_1).ClearContents ' таблица-1

-        .Range(TABLE_2).ClearContents ' таблица-2

-        .Range(TABLE_3).ClearContents ' таблица-3

-        .Range(TABLE_COMMENT).Value = "" ' коментарий-3

-        .Range(TABLE_4).ClearContents ' таблица-4

-    End With

-End Sub

-

-Function TDenmark_Calc() As Boolean

-    

-    Dim nWindow As Integer

-    Dim bPrevCloseFilter, bSuccCloseFilter As Boolean

-    

-    TDenmark_Calc = False

-    

-    mobjAppRunEnable.EnableRun ESTIMATION_DATE, Now

-    

-    With ThisWorkbook

-        .Application.ScreenUpdating = False

-'1)    Read User data

-        With .Worksheets(VAR_SHEET)

-            DenmarkDataArray.ProjectNumber = .Range("DEN_PROECT").Value

-            DenmarkDataArray.SignalParameter = .Range("DEN_PARAM").Value

-            nWindow = .Range("DEN_WINDOW").Value

-            bPrevCloseFilter = .Range("BOOL_PREV_CLOSE").Value

-            bSuccCloseFilter = .Range("BOOL_SUCC_CLOSE").Value

-        End With

-

-'2)   Memory allocation

-        allocate_memory PriceDataArray, DenmarkDataArray, nWindow

-

-'3)   Read data

-        Dim TheRange As Range

-        Set TheRange = .Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE)

-        Dim LinesCount As Integer

-        LinesCount = ReadPricesData(Location:=TheRange, Hist:=PriceDataArray.tC, dt:=1, pPriceData:=PriceDataArray)

-        

-        'Init function result

-        TDenmark_Calc = LinesCount >= nWindow

-        

-        If LinesCount >= nWindow Then

-        

-'4)   Calculate metod TDenmarkDataArray

-            DetDenmark PriceDataArray, DenmarkDataArray, bPrevCloseFilter, bSuccCloseFilter

-            If Abs(DenmarkDataArray.SignalValue) > 1 Then  'ценовые ориентиры, если есть сигнал

-                DetProj PriceDataArray, DenmarkDataArray

-            End If

-'5)   Write result

-            Application.ScreenUpdating = False

-    

-'6)    Clear interface tables

-            ClearResultTables

-            

-            ResultLinesOut Location:=TheRange.Offset(2, 0), pPD:=PriceDataArray, pDen:=DenmarkDataArray

-            

-            With .Worksheets(FORM_SHEET)

-                Out_Table_1 TheRange:=.Range(TABLE_1).Cells(1, 1), pDen:=DenmarkDataArray, LastIdx:=PriceDataArray.tC

-                Out_Table_2 _

-                        TheRange:=.Range(TABLE_2).Cells(1, 1), _

-                        TheComment:=.Range("TABLE_COMMENT"), _

-                        pPD:=PriceDataArray, _

-                        pDen:=DenmarkDataArray

-                Out_Table_3 TheRange:=.Range(TABLE_3).Cells(1, 1), pDen:=DenmarkDataArray

-                Out_Table_4 TheRange:=.Range(TABLE_4).Cells(1, 1), pPD:=PriceDataArray

-                With .Range(TABLE_1)

-                    .Font.Name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-                With .Range(TABLE_2)

-                    .Font.Name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-                With .Range(TABLE_3)

-                    .Font.Name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-                With .Range(TABLE_4)

-                    .Font.Name = "Arial"

-                    .Font.Size = 9

-                    .HorizontalAlignment = xlCenter

-                    .VerticalAlignment = xlCenter

-                    .WrapText = False

-                    .Orientation = 0

-                    .ShrinkToFit = False

-                    .MergeCells = False

-                End With

-            End With

-            .Worksheets(VAR_SHEET).Range("BOOL_DEMARK_READY") = True

-        Else

-            MsgBox _

-                Prompt:="Недостаточна глубина выборки данных." _

-                    & vbCrLf & "Измените параметры запроса и пробуйте снова.", _

-                Buttons:=vbOKOnly + vbExclamation, _

-                Title:=PROGRAM_NAME

-            .Worksheets(VAR_SHEET).Range("BOOL_DEMARK_READY") = False

-            .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False

-        End If

-'7)   Free unused memory

-        free_unused_memory PriceDataArray, DenmarkDataArray

-    End With

-End Function

-

-Sub allocate_memory(pPriceData As TPriceData, pDenmarkData As TDenmark, memsize As Integer)

-'  Память под TDenmark

-    ReDim pDenmarkData.ResistanceLine(1 To memsize)

-    ReDim pDenmarkData.ResistancePoints(1 To memsize)

-    ReDim pDenmarkData.SupportLine(1 To memsize)

-    ReDim pDenmarkData.SupportPoints(1 To memsize)

-   

-' Инициализация данных по ценам

-    pPriceData.tC = memsize

-    ReDim pPriceData.D(1 To memsize)

-    ReDim pPriceData.Tm(1 To memsize)

-    ReDim pPriceData.Opn(1 To memsize)

-    ReDim pPriceData.Hgh(1 To memsize)

-    ReDim pPriceData.Lw(1 To memsize)

-    ReDim pPriceData.Cls(1 To memsize)

-    ReDim pPriceData.Vl(1 To memsize)

-

-End Sub

-

-Sub free_unused_memory(pP As TPriceData, pD As TDenmark)

-'   Free Prices

-    pP.tC = 0

-    Erase pP.D

-    Erase pP.Tm

-    Erase pP.Opn

-    Erase pP.Hgh

-    Erase pP.Lw

-    Erase pP.Cls

-    Erase pP.Vl

-    

-'Free TDenmark

-    Erase pD.ResistanceLine

-    Erase pD.ResistancePoints

-    Erase pD.SupportLine

-    Erase pD.SupportPoints

-End Sub

-

-

-'*****************************************

-Sub DetDenmark(pPriceData As TPriceData, pDenmarkData As TDenmark, ByVal ClosePrev2 As Boolean, ByVal CloseSucc1 As Boolean)

-' определение элементов данных Денмарка (в цифровой форме)

-' на текущий момент времени времени tC

-' ИСХОДНЫЕ ДАННЫЕ:

-' pPriceData  - окно, стандартная форма данных по ценам (определена)

-' ClosePrev2 - H(t) > max{ H(t-1), H(t+1)} и  H(t) > Close(t-2)

-' CloseSucc1 - H(t) > max{ H(t-1), H(t+1)}  и  R(t+1) > Close(t+1)

-' РЕЗУЛЬТАТ:

-' pDenmarkData - элементы данных Денмарка (память выделена, SignalParameter - определен):

-' линии ResistanceLine,SupportLine их наклоны, опорные точки, сигналы к покупке или продаже

-' SignalValue = 0 сигнал отсутствует

-' SignalValue < 0 прорыв восходящего тренда (сигнал продажи)

-' SignalValue > 0 прорыв нисходящего тренда (сигнал покупки)

-' Если pDenmarkData.ResistancePointCount < 2, то элементы ResistanceLine не определяются

-' Если pDenmarkData.SupportPointsCount < 2, то элементы SupportLine не определяются

-

-' начальная установка

-    Const QUALIFICATOR_DISABLE As String = "-"

-    Const QUALIFICATOR_ENABLE As String = "Signal"

-    

-    Dim UpQual(1 To 3) As String

-    Dim DownQual(1 To 3) As String

-    Dim UpSignal, DownSignal As Integer

-    Dim i As Integer

-    

-    pDenmarkData.SignalValue = 0

-    UpSignal = 0

-    DownSignal = 0

-    

-    For i = 1 To 3

-        pDenmarkData.Qualificator(i) = QUALIFICATOR_DISABLE

-        UpQual(i) = QUALIFICATOR_DISABLE

-        DownQual(i) = QUALIFICATOR_DISABLE

-    Next i

-    

-' определение линии поддержки и сопротивления

-    ResLine _

-        pPriceData, _

-        pPriceData.tC, _

-        pDenmarkData.ResistancePointCount, _

-        pDenmarkData.ResistanceLine, _

-        pDenmarkData.ResistancePoints, _

-        ClosePrev2, _

-        CloseSucc1

-        

-    SuppLine _

-        pPriceData, _

-        pPriceData.tC, _

-        pDenmarkData.SupportPointsCount, _

-        pDenmarkData.SupportLine, _

-        pDenmarkData.SupportPoints, _

-        ClosePrev2, _

-        CloseSucc1

-

-        

-        

-    If pDenmarkData.ResistancePointCount >= 2 Then

-        pDenmarkData.ResistanceAngle = 57.29578 * _

-            Atn(pDenmarkData.ResistanceLine(pPriceData.tC) - _

-                pDenmarkData.ResistanceLine(pPriceData.tC - 1))

-    End If

-    If pDenmarkData.SupportPointsCount >= 2 Then

-        pDenmarkData.SupportAngle = 57.29578 * _

-            Atn(pDenmarkData.SupportLine(pPriceData.tC) - _

-                pDenmarkData.SupportLine(pPriceData.tC - 1))

-    End If

-

-' ФОРМИРОВАНИЕ СИГНАЛА ----------------------------------

-    Dim t As Integer

-' 1. случай нисходящего тренда: ResistanceLine определен и ResistanceLine падает *************

-    If pDenmarkData.ResistancePointCount >= 2 And pDenmarkData.ResistanceAngle < 0 Then

-'    необходимое условие прорыва вверх

-        If pDenmarkData.ResistanceLine(pPriceData.tC) < pPriceData.Cls(pPriceData.tC) Then

-            UpSignal = 1

-            For t = pPriceData.tC - pDenmarkData.SignalParameter To pPriceData.tC - 1

-                If pPriceData.Cls(t) > pDenmarkData.ResistanceLine(t) Then

-                    UpSignal = 0

-                    Exit For

-                End If

-            Next t

-        End If

-        If UpSignal = 1 Then

-'       Qualificator-1: close убывает накануне прорыва

-            If pPriceData.Cls(pPriceData.tC - 2) > pPriceData.Cls(pPriceData.tC - 1) Then

-                UpSignal = UpSignal + 1

-                UpQual(1) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-2: open > ResistanceLine в момент прорыва

-            If pPriceData.Opn(pPriceData.tC) > pDenmarkData.ResistanceLine(pPriceData.tC) Then

-                UpSignal = UpSignal + 1

-                UpQual(2) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-3 - demand value < ResistanceLine(tC)

-            If 2 * pPriceData.Cls(pPriceData.tC - 1) - pPriceData.Lw(pPriceData.tC - 1) < pDenmarkData.ResistanceLine(pPriceData.tC) Then

-                UpSignal = UpSignal + 1

-                UpQual(3) = QUALIFICATOR_ENABLE

-            End If

-        End If

-    End If  ' нисходящий тренд обработан ************************************

-

-' 2. случай восходящего тренда: SupportLine определен и SupportLine растет

-    If pDenmarkData.SupportPointsCount >= 2 And pDenmarkData.SupportAngle > 0 Then

-'    ---------------------------------------------

-'    необходимое условие прорыва вниз

-        If pPriceData.Cls(pPriceData.tC) < pDenmarkData.SupportLine(pPriceData.tC) Then

-            DownSignal = -1

-            For t = pPriceData.tC - pDenmarkData.SignalParameter To pPriceData.tC - 1

-                If pPriceData.Cls(t) < pDenmarkData.SupportLine(t) Then

-                    DownSignal = 0

-                    Exit For

-                End If

-            Next t

-        End If

-        If DownSignal = -1 Then

-'       Qualificator-1: Close растет накануне прорыва

-            If pPriceData.Cls(pPriceData.tC - 2) < pPriceData.Cls(pPriceData.tC - 1) Then

-                DownSignal = DownSignal - 1

-                DownQual(1) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-2: Open ниже ResistanceLine в момент прорыва

-            If pPriceData.Opn(pPriceData.tC) < pDenmarkData.SupportLine(pPriceData.tC) Then

-                DownSignal = DownSignal - 1

-                DownQual(2) = QUALIFICATOR_ENABLE

-            End If

-'       Qualificator-3 - supply value(t-1) > SupportLine(tC)

-            If 2 * pPriceData.Cls(pPriceData.tC - 1) - pPriceData.Hgh(pPriceData.tC - 1) > pDenmarkData.SupportLine(pPriceData.tC) Then

-                DownSignal = DownSignal - 1

-                DownQual(3) = QUALIFICATOR_ENABLE

-            End If

-        End If

-'    ---------------------------------------------

-    End If

-'      Существует преобладание тенденции

-    If Abs(DownSignal) <> UpSignal Then

-        If Abs(DownSignal) > UpSignal Then

-            pDenmarkData.SignalValue = DownSignal

-            For i = 1 To 3

-                pDenmarkData.Qualificator(i) = DownQual(i)

-            Next i

-        Else

-            pDenmarkData.SignalValue = UpSignal

-            For i = 1 To 3

-                pDenmarkData.Qualificator(i) = UpQual(i)

-            Next i

-        End If

-    End If

-End Sub

-

-Sub DetProj(pPriceData As TPriceData, pDenmarkData As TDenmark)

-'Определение проекции при наличии сигнала: |Signal| > 1

-'Услловие применимости |Signal| > 1 !!!

-    Dim pM As Double, t As Integer, Tm As Integer, tL As Integer

-

-    If pDenmarkData.SignalValue >= 2 Then  ' СИГНАЛ ПОКУПКИ

-

-        tL = pDenmarkData.ResistancePoints(pDenmarkData.ResistancePointCount)     ' tR determination

-        If tL = pPriceData.tC Then

-            tL = pDenmarkData.ResistancePoints(pDenmarkData.ResistancePointCount - 1)

-        End If

-

-'  Projections 1,2 --------------------------------------------

-        If pDenmarkData.ProjectNumber >= 1 And pDenmarkData.ProjectNumber <= 2 Then

-'           t* = Arg min {L(t) : t R <= t  <= tb ,  L(t) < ResistanceLine(t)},

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Lw(Tm) ' L(t-1) < ResistanceLine(t-1) for t - break point !

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Lw(t) < pM And pPriceData.Lw(t) < pDenmarkData.ResistanceLine(t) Then

-                    pM = pPriceData.Lw(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            If pDenmarkData.ProjectNumber = 1 Then

-'               P1( tb) = ResistanceLine(tb) + ResistanceLine(t*) - L(t*)

-                pDenmarkData.ProjectPrice = pDenmarkData.ResistanceLine(pPriceData.tC) + pDenmarkData.ResistanceLine(Tm) - pPriceData.Lw(Tm)

-            Else

-                pDenmarkData.ProjectPrice = pDenmarkData.ResistanceLine(pPriceData.tC) + pDenmarkData.ResistanceLine(Tm) - pPriceData.Cls(Tm)

-            End If

-        End If ' pDenmarkData.ProjectNumber >= 1 And pDenmarkData.ProjectNumber <= 2

-   

-'  ----------------------------------------------------------------

-'  Projections 3

-        If pDenmarkData.ProjectNumber = 3 Then

-'           t*  = Arg min { С(t) : t R <= t  <= tb ,  C(t) < ResistanceLine(t)}

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Cls(Tm)

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Cls(t) < pM And pPriceData.Cls(t) < pDenmarkData.ResistanceLine(t) Then

-                    pM = pPriceData.Cls(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            pDenmarkData.ProjectPrice = pDenmarkData.ResistanceLine(pPriceData.tC) + pDenmarkData.ResistanceLine(Tm) - pPriceData.Cls(Tm)

-        End If

-    End If ' pDenmarkData.SignalValue >= 2

-

-'-------------------------------------------------------------------

-'*******************************************************************

-' ПРОЕКЦИЯ ДЛЯ СИГНАЛА ПРОДАЖИ

-    If pDenmarkData.SignalValue <= -2 Then

-        tL = pDenmarkData.SupportPoints(pDenmarkData.SupportPointsCount)  ' tR determination

-        If tL = pPriceData.tC Then

-            tL = pDenmarkData.ResistancePoints(pDenmarkData.SupportPointsCount - 1)

-        End If

-

-'  Projections 1,2 --------------------------------------------

-        If pDenmarkData.ProjectNumber = 1 Or pDenmarkData.ProjectNumber = 2 Then

-'           t* = Arg max {H(t) : t R <= t  <= tb ,  H(t) > SupportLine(t)},

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Hgh(Tm) ' H(t-1) > SupportLine(t-1) for t - break point !

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pPriceData.Hgh(t) > pM And pPriceData.Hgh(t) > pDenmarkData.SupportLine(t) Then

-                    pM = pPriceData.Hgh(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            If pDenmarkData.ProjectNumber = 1 Then

- '              P1( tb) = SupportLine(tb) + SupportLine(t*) - H(t*)

-                pDenmarkData.ProjectPrice = pDenmarkData.SupportLine(pPriceData.tC) + pDenmarkData.SupportLine(Tm) - pPriceData.Hgh(Tm)

-            Else

-'               P2( tb) = SupportLine(tb) + SupportLine(t*) - C(t*)

-                pDenmarkData.ProjectPrice = pDenmarkData.SupportLine(pPriceData.tC) + pDenmarkData.SupportLine(Tm) - pPriceData.Cls(Tm)

-            End If

-        End If

-   

-'  ----------------------------------------------------------------

-'  Projections 3

-        If pDenmarkData.ProjectNumber = 3 Then

-'           t*  = Arg max { С(t) : t R <= t  <= tb ,  C(t) >  SupportLine(t)}

-'           P3( tb) = SupportLine(tb) + SupportLine(t*) - C(t*)

-            Tm = pPriceData.tC - 1

-            pM = pPriceData.Cls(Tm)

-            For t = pPriceData.tC - 2 To tL Step -1

-                If pM < pPriceData.Cls(t) And pPriceData.Cls(t) > pDenmarkData.SupportLine(t) Then

-                    pM = pPriceData.Cls(t): Tm = t

-                End If

-            Next t

-'           t* is defined

-            pDenmarkData.ProjectPrice = pDenmarkData.SupportLine(pPriceData.tC) + pDenmarkData.SupportLine(Tm) - pPriceData.Cls(Tm)

-        End If

-    End If ' pDenmarkData.SignalValue <= -2

-End Sub

-

-Sub ResLine(pP As TPriceData, tE As Integer, ResistancePointCount As Integer, _

-            ResistanceLine() As Double, s() As Integer, ClosePrev2 As Boolean, CloseSucc1 As Boolean)

-' Определение линии сопротивления по Демарку [1]

-' Основной вариант

-' ИСХОДНЫЕ ДАННЫЕ:

-' High, dom(High) = [1, tE]

-' ClosePrev2 - H(t) > max{ H(t-1), H(t+1)} и  H(t) > Close(t-2)

-' CloseSucc1 - H(t) > max{ H(t-1), H(t+1)}  и  R(t+1) > Close(t+1)

-' РЕЗУЛЬТАТ:

-' 1) линия сопротивления ResistanceLine, dom(ResistanceLine)=[s(1), tE], и

-' 2) s = {s(1), s(2), ..., s(ResistancePointCount)}, s(1) < s(2) < ...< s(ResistancePointCount)

-'   ( s(ResistancePointCount)<= tE )- опорные точки

-' 3) число опорных точек ResistancePointCount.

-' 4) s(1) -  первый момент времени с которого определена SupportLine

-'    то есть dom{Supp} = [s(1), tC]

-' Прим. Если число опорных точек окажется < 2, то линия

-' сопротивления не определяется. В этом случае следует

-' увеличить историю tE !!!

-    Dim t As Integer, i As Integer

-    Dim v As Double

-    Dim IsGoodPoint As Boolean

-  

-'1 определение опорных моментов времени

-    ResistancePointCount = 0

-    For t = 3 To tE - 1

- '      v = max{high(t-1), high(t+1)} < high(t)}

-        v = pP.Hgh(t - 1)

-        If v < pP.Hgh(t + 1) Then

-            v = pP.Hgh(t + 1)

-        End If

-        IsGoodPoint = pP.Hgh(t) > v

-        If IsGoodPoint And ClosePrev2 Then

-            IsGoodPoint = IsGoodPoint And (pP.Cls(t - 2) < pP.Hgh(t))

-        End If

-        

-        If IsGoodPoint Then       'alt.: v >= High(t + 1)

-            s(ResistancePointCount + 1) = t: ResistancePointCount = ResistancePointCount + 1

-        End If

-    Next t

-    

-loop_:

-    

-    If ResistancePointCount < 2 Then

-        GoTo done

-    End If

-

-' 2 определение линии сопротивления

-    ResistanceLine(s(1)) = pP.Hgh(s(1))

-    For i = 2 To ResistancePointCount

-        ResistanceLine(s(i)) = pP.Hgh(s(i))

-        v = (pP.Hgh(s(i)) - pP.Hgh(s(i - 1))) / (s(i) - s(i - 1))

-        For t = s(i - 1) + 1 To s(i) - 1

-            ResistanceLine(t) = pP.Hgh(s(i - 1)) + v * (t - s(i - 1))

-        Next t

-    Next i

-    If s(ResistancePointCount) < tE Then

-        v = (pP.Hgh(s(ResistancePointCount)) - pP.Hgh(s(ResistancePointCount - 1))) / (s(ResistancePointCount) - s(ResistancePointCount - 1))

-        For t = s(ResistancePointCount) + 1 To tE

-            ResistanceLine(t) = pP.Hgh(s(ResistancePointCount - 1)) + v * (t - s(ResistancePointCount - 1))

-        Next t

-    End If

-    If CloseSucc1 Then

-        For t = 1 To ResistancePointCount

-            If ResistanceLine(s(t) + 1) < pP.Cls(s(t) + 1) Then

-                ResistancePointCount = ResistancePointCount - 1

-                ' удалить точку

-                For i = t To ResistancePointCount

-                    s(i) = s(i + 1)

-                Next i

-                s(ResistancePointCount + 1) = 0

-                ' очистить массив линии

-                Dim Lb, Rb As Integer

-                Lb = LBound(ResistanceLine)

-                Rb = UBound(ResistanceLine)

-                Erase ResistanceLine

-                ReDim ResistanceLine(Lb To Rb)

-                GoTo loop_

-            End If

-        Next t

-    End If

-    

-done:

-End Sub

-

-Sub SuppLine(pP As TPriceData, tE As Integer, SupportPointsCount As Integer, _

-               SupportLine() As Double, s() As Integer, ClosePrev2 As Boolean, CloseSucc1 As Boolean)

-' Определение линии поддержки по Демарку [1] (от конца)

-' Исходные данные:

-' Low, dom(Low) = [1, tE]

-' ClosePrev2 - H(t) > max{ H(t-1), H(t+1)} и  H(t) > Close(t-2)

-' CloseSucc1 - H(t) > max{ H(t-1), H(t+1)}  и  R(t+1) > Close(t+1)

-' Результат:

-' 1) линия сопротивления SupportLine, dom(SupportLine)=[s(1), tE],

-' 2) s = {s(1), s(2), ..., s(SupportPointsCount)}, s(1) < s(2) < ...< s(SupportPointsCount) -

-'    опорные точки

-' 3) число опорных точек SupportPointsCount.

-' Прим. Если фактическое число опорных точек окажется < 2, то линия

-' поддержки не определяется.

-    Dim t As Integer, i As Integer

-    Dim v As Double

-    Dim IsGoodPoint As Boolean

-    

-'1 определение опорных моментов времени

-     SupportPointsCount = 0

-    For t = 3 To tE - 1

-'       v = min{Low(t-1), Low(t+1)} > Low(t)

-        v = pP.Lw(t - 1)

-        If v > pP.Lw(t + 1) Then

-            v = pP.Lw(t + 1)

-        End If

-        

-        IsGoodPoint = pP.Lw(t) < v

-        

-        If IsGoodPoint And ClosePrev2 Then

-            IsGoodPoint = IsGoodPoint And (pP.Cls(t - 2) > pP.Lw(t))

-        End If

-        

-        If IsGoodPoint Then     'alt.: v >= High(t + 1)

-            s(SupportPointsCount + 1) = t: SupportPointsCount = SupportPointsCount + 1

-        End If

-    Next t

-

-loop_:

-    If SupportPointsCount < 2 Then

-        GoTo done

-    End If

-' 2 определение линии поддержки

-    

-    SupportLine(s(1)) = pP.Lw(s(1))

-    For i = 2 To SupportPointsCount

-        SupportLine(s(i)) = pP.Lw(s(i))

-        v = (pP.Lw(s(i)) - pP.Lw(s(i - 1))) / (s(i) - s(i - 1))

-        For t = s(i - 1) + 1 To s(i) - 1

-            SupportLine(t) = pP.Lw(s(i - 1)) + v * (t - s(i - 1))

-        Next t

-    Next i

-    If s(1) < tE Then

-        v = (pP.Lw(s(SupportPointsCount)) - pP.Lw(s(SupportPointsCount - 1))) / (s(SupportPointsCount) - s(SupportPointsCount - 1))

-        For t = s(SupportPointsCount) + 1 To tE

-            SupportLine(t) = pP.Lw(s(SupportPointsCount - 1)) + v * (t - s(SupportPointsCount - 1))

-        Next t

-    End If

-    If CloseSucc1 Then

-        For t = 1 To SupportPointsCount

-            If SupportLine(s(t) + 1) > pP.Cls(s(t) + 1) Then

-                SupportPointsCount = SupportPointsCount - 1

-                ' удалить точку

-                For i = t To SupportPointsCount

-                    s(i) = s(i + 1)

-                Next i

-                s(SupportPointsCount + 1) = 0

-                ' очистить массив линии

-                Dim Lb, Rb As Integer

-                Lb = LBound(SupportLine)

-                Rb = UBound(SupportLine)

-                Erase SupportLine

-                ReDim SupportLine(Lb To Rb)

-                GoTo loop_

-            End If

-        Next t

-    End If

-done:

-End Sub

-

-<<<<<<
-======================
-mChart
->>>>>>
-Attribute VB_Name = "mChart"

-Option Explicit

-

-Const CHART_NAME As String = "PriceChart"

-

-Sub Draw_Chart(SignalDefined As Boolean)

-

-    Dim n As Integer

-    Dim theChart As Chart

-    Dim ChartDataAria, szLastNumber As String

-    Dim MinYScale As Double

-    

-    

-    With ThisWorkbook

-' Checking data

-' Disable screen out

-        .Application.Cursor = xlWait

-        .Application.ScreenUpdating = False

-' Create series range

-        n = GetLinesCount(Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE))

-        szLastNumber = n + 1

-        If SignalDefined Then

-            ChartDataAria = "A2:A" & szLastNumber _

-                        & ",D2:D" & szLastNumber _

-                        & ",G2:G" & szLastNumber _

-                        & ",I2:K" & szLastNumber

-        Else

-            ChartDataAria = "A2:A" & szLastNumber _

-                        & ",D2:D" & szLastNumber _

-                        & ",G2:G" & szLastNumber _

-                        & ",I2:J" & szLastNumber

-        End If

-        MinYScale = GetMinValue(.Worksheets(RAW_DATA_SHEET).Range(ChartDataAria))

-' Find and delete old chart

-        .Worksheets(CHART_SHEET).Unprotect

-        Dim WindowWidth, WindowHeight As Integer

-        With .Worksheets(CHART_SHEET)

-            WindowWidth = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-            WindowHeight = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-        End With

-        

-        

-        With .Worksheets(CHART_SHEET).ChartObjects

-            .Delete

-            With .Add(5, 5, WindowWidth - 10, WindowHeight - 10)

-                .SendToBack

-                Set theChart = .Chart

-            End With

-' Create a chart

-        End With

-        With theChart

-            .ChartType = xlLine

-            .SetSourceData Source:=Sheets(RAW_DATA_SHEET).Range( _

-                    ChartDataAria), PlotBy:=xlColumns

-'                   .Location Where:=xlLocationAsObject, Name:=CHART_SHEET

-            .HasTitle = True

-            With .ChartTitle

-                .Text = ThisWorkbook.Worksheets(RAW_DATA_SHEET).Range(PRICE_TABLE).Value

-                With .Font

-                    .Size = 8

-                    .Bold = True

-                End With

-            End With

-            .HasLegend = True

-            With .Legend

-                .Position = xlTop

-                With .Font

-                    .Name = "Arial"

-                    .Size = 8

-                End With

-            End With

-            .HasDataTable = False

-            With .Axes(xlCategory)

-                .HasMajorGridlines = True

-                .HasMinorGridlines = False

-                .TickLabels.Orientation = xlUpward

-                With .MajorGridlines.Border

-                    .ColorIndex = 48

-                    .Weight = xlHairline

-                    .LineStyle = xlDot

-                End With

-                .CrossesAt = 1

-                .TickLabelSpacing = 1

-                .TickMarkSpacing = 1

-                .AxisBetweenCategories = False

-                .ReversePlotOrder = False

-                .TickLabels.AutoScaleFont = True

-                With .TickLabels.Font

-                    .Name = "Arial"

-                    .Size = 8

-                End With

-            End With

-            With .Axes(xlValue)

-                .HasMajorGridlines = True

-                .HasMinorGridlines = False

-                With .MajorGridlines.Border

-                    .ColorIndex = 48

-                    .Weight = xlHairline

-                    .LineStyle = xlDot

-                End With

-                .MinimumScale = MinYScale

-                .MaximumScaleIsAuto = True

-                .MinorUnitIsAuto = True

-                .MajorUnitIsAuto = True

-                .Crosses = xlCustom

-                .CrossesAt = MinYScale

-                .ReversePlotOrder = False

-                .ScaleType = xlLinear

-                .TickLabels.AutoScaleFont = True

-                With .TickLabels.Font

-                    .Name = "Arial"

-                    .Size = 9

-                End With

-            End With

-            .ChartTitle.Top = 5

-            .ChartTitle.Left = 5

-            With .Legend

-                .Top = 5

-                .Fill.OneColorGradient _

-                    Style:=msoGradientHorizontal, _

-                    Variant:=3, _

-                    Degree:=0.303913939116503

-                .Fill.Visible = True

-                .Fill.ForeColor.SchemeColor = 71

-            End With

-            .PlotArea.Left = 10

-            .PlotArea.Top = .Legend.Top + .Legend.Height + 5

-            .PlotArea.Width = .ChartArea.Width - 20

-            .PlotArea.Height = .ChartArea.Height - .PlotArea.Top

-            

-' Tune OPEN line

-            With .SeriesCollection(1)

-                .Border.LineStyle = xlNone

-                .MarkerBackgroundColorIndex = xlNone

-                .MarkerForegroundColorIndex = 1

-                .MarkerStyle = xlPlus

-                .Smooth = False

-                .MarkerSize = 9

-                .Shadow = False

-            End With

-' Tune CLOSE line

-            With .SeriesCollection(2)

-                .Border.ColorIndex = 10

-                .Border.Weight = xlMedium

-                .Border.LineStyle = xlContinuous

-            End With

-' Tune RESISTANCE line

-            With .SeriesCollection(3)

-                .Border.ColorIndex = 3

-                .Border.Weight = xlThin

-                .Border.LineStyle = xlContinuous

-            End With

-' Tune SUUPORT line

-            With .SeriesCollection(4)

-                .Border.ColorIndex = 25

-                .Border.Weight = xlThin

-                .Border.LineStyle = xlContinuous

-            End With

-            If SignalDefined Then

-                With .SeriesCollection(5)

-                    .Border.ColorIndex = 6

-                    .Border.Weight = xlThin

-                    .Border.LineStyle = xlDot

-                End With

-            End If

-        End With

-        .Application.Cursor = xlDefault

-        With .Worksheets(CHART_SHEET)

-            .Select

-            .Protect userInterfaceOnly:=True

-        End With

-    End With

-End Sub

-

-Function GetMinValue(DataRange As Range) As Double

-    Dim Cell As Range

-    Dim MinValue, MaxValue, RangeValue, CorrectValue, Mult As Double

-    MinValue = MAX_PRICE_VALUE

-    MaxValue = MIN_PRICE_VALUE

-    For Each Cell In DataRange

-        If Not IsEmpty(Cell) And IsNumeric(Cell) Then

-            If Cell > MIN_PRICE_VALUE Then

-                If Cell < MinValue Then

-                    MinValue = Cell

-                End If

-                If Cell > MaxValue Then

-                    MaxValue = Cell

-                End If

-            End If

-        End If

-    Next

-    RangeValue = MaxValue - MinValue

-    If RangeValue < 0 Then

-        MinValue = 0

-    Else

-        CorrectValue = RangeValue / 4

-        Mult = MIN_PRICE_VALUE

-        While MinValue - Int(MinValue * Mult) / Mult > CorrectValue

-            Mult = Mult * 10

-        Wend

-        MinValue = Int(MinValue * Mult) / Mult

-    End If

-    GetMinValue = MinValue

-End Function

-

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub GetState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.Name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars("Worksheet Menu Bar").Visible = False

-End Sub

-

-

-Public Sub RestoreState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars("Worksheet Menu Bar").Visible = True

-End Sub

-

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{35F0795B-B2D2-4991-B483-85539758086D}{911BB725-D234-48B9-A8AA-300F1C3919E0}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-

-Private Sub CommandButton1_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-mWebQeury
->>>>>>
-Attribute VB_Name = "mWebQeury"

-Option Explicit

-

-Public Const Qry_DELETE_ALL As String = "Qry_DELETE_ALL"

-Public Const Qry_PATH_NO_CHANGE As String = "Qry_PATH_NO_CHANGE"

-

-

-Sub QryCreate(QryRange As Range, QryName As String, QryPath As String, Optional RefreshBkgnd = False)

-    Dim WebQuery As QueryTable

-    QryDelete QryRange:=QryRange, QryName:=QryName

-    

-    Set WebQuery = QryRange.Worksheet.QueryTables.Add( _

-            Connection:=QryPath, _

-            Destination:=QryRange)

-    

-    With WebQuery

-        .FieldNames = False

-        .Name = QryName

-        .RefreshStyle = xlOverwriteCells

-        .RowNumbers = False

-        .FillAdjacentFormulas = False

-        .RefreshOnFileOpen = False

-        .HasAutoFormat = False

-        .BackgroundQuery = False

-        .TablesOnlyFromHTML = False

-        .Refresh BackgroundQuery:=RefreshBkgnd

-        .SavePassword = False

-        .SaveData = True

-    End With

-End Sub

-

-Function QryRefresh(QryRange As Range, QryName As String, Optional QryPath As String = Qry_PATH_NO_CHANGE, Optional Background As Boolean = False) As Boolean

-    Dim qry_result As Boolean

-    qry_result = False

-    If QryExist(QryRange, QryName) Then

-        With QryRange.Worksheet.QueryTables(QryName)

-            If QryPath <> Qry_PATH_NO_CHANGE Then

-                .Connection = QryPath

-            End If

-            .Refresh BackgroundQuery:=Background

-            qry_result = True

-        End With

-    End If

-    QryRefresh = qry_result

-End Function

-

-Sub QryDelete(QryRange As Range, Optional QryName As String = Qry_DELETE_ALL)

-    Dim WebQuery As QueryTable

-    For Each WebQuery In QryRange.Worksheet.QueryTables

-        If QryName = Qry_DELETE_ALL Or WebQuery.Name = QryName Then

-            WebQuery.Delete

-        End If

-    Next

-End Sub

-

-Function QryExist(QryRange As Range, QryName As String) As Boolean

-    Dim WebQuery As QueryTable

-    For Each WebQuery In QryRange.Worksheet.QueryTables

-        If WebQuery.Name = QryName Then

-            QryExist = True

-            Exit For

-        End If

-    Next

-End Function

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Sub CreateCommandBar(theApp As Application)

-Attribute CreateCommandBar.VB_ProcData.VB_Invoke_Func = "R\n14"

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible + msoBarNoCustomize + msoBarNoMove + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Print"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 4

-                        .OnAction = "cmPrint"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Contents"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 49

-                        .OnAction = "cmHelpContents"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible + msoBarNoCustomize + msoBarNoMove + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(Flag As Boolean)

-    If Flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars("Worksheet Menu Bar")

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        cmHelpContents

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mTool
->>>>>>
-Attribute VB_Name = "mTool"

-Option Explicit

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub tool_delete_all_tables()

-    QryDelete ThisWorkbook.Worksheets(RAW_DATA_SHEET).Range("A1")

-End Sub

-

-Sub tool_delete_all_charts(theSheet As Worksheet)

-    Dim theChart As Chart

-    For Each theChart In theSheet

-        theChart.Unprotect

-        theChart.Delete

-    Next

-End Sub

-

-Sub DateTimeTest()

-    Dim the_date

-    Dim the_time

-    the_date = DateValue(Now)

-    the_time = TimeValue(Now)

-End Sub

-

-

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{E1DAA7A0-7005-43C9-A7ED-E642DEA5A0CD}{20C12630-E9D0-4B92-9764-77ACD7C8A4FB}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = True

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-

-

-Private Sub App_WorkbookOpen(ByVal wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If Application.Workbooks.count > 1 Then

-        wbname = wb.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKCancel, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            wb.Close Savechanges:=False

-        End If

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-mDataCommands
->>>>>>
-Attribute VB_Name = "mDataCommands"

-Option Explicit

-

-Sub evFileOpen()

-    Dim fileToOpen As String

-    Dim wb As Workbook

-    Dim Result As Integer

-

-    Set wb = ThisWorkbook

-    With wb

-        If .Worksheets(VAR_SHEET).Range("DEN_SOURCE") <> "file" Then

-            .Worksheets(VAR_SHEET).Range("IDX_DEN_LIST") = 6

-            evGroupChange

-        End If

-        If .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False Or .Worksheets(VAR_SHEET).Range("BOOL_LOAD_DATA") = True Then

-                fileToOpen = .Application.GetOpenFilename( _

-                                  "Text Files (*.txt), *.txt, Data Files (*.csv), *.csv")

-        End If

-          

-        If fileToOpen <> "False" Then

-            .Worksheets(FORM_SHEET).Range(FILE_NAME) = fileToOpen

-            Result = UpdateHistoryFromFile(wb, fileToOpen)

-            .Worksheets(VAR_SHEET).Range("LAST_FILE_QRY") = fileToOpen

-            .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False

-            .Worksheets(VAR_SHEET).Range("BOOL_DEMARK_READY") = False

-            

-            ClearResultTables

-        

-            Select Case Result

-            Case FUNCRES_FILE_OK

-                sbCalcFile

-            Case FUNCRES_FILE_VERY_SMALL

-                .Worksheets(FORM_SHEET).Range("CALC_TICKER_NAME") = MSG_FILE_VERY_SMALL

-                MsgBox MSG_FILE_VERY_SMALL, vbOKOnly, PROGRAM_NAME

-            Case FUNCRES_FILE_INVALID_FORMAT

-                .Worksheets(FORM_SHEET).Range("CALC_TICKER_NAME") = MSG_FILE_INVALID_FORMAT

-                MsgBox MSG_FILE_INVALID_FORMAT, vbOKOnly, PROGRAM_NAME

-            End Select

-'            .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False

-        End If

-    End With 'wb

-End Sub

-

-Sub sbCalcFile()

-    Dim wb As Workbook

-    Dim ticker As String

-    

-    Set wb = ThisWorkbook

-    With wb

-        ClearResultTables

-        

-        .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = True

-        If TDenmark_Calc Then

-            ticker = .Worksheets(RAW_DATA_SHEET).Range("B1")

-            Worksheets(FORM_SHEET).Range("CALC_TICKER_NAME") = ticker

-        End If

-    End With 'wb

-End Sub

-

-Sub sbCalcWeb()

-    Dim wb As Workbook

-    Dim ticker As String

-    Dim Period As String

-    

-    Set wb = ThisWorkbook

-    With wb

-        ticker = .Worksheets(VAR_SHEET).Range("DEN_SYMBOL")

-        Period = .Worksheets(VAR_SHEET).Range("DEN_TIME")

-        If .Worksheets(VAR_SHEET).Range("BOOL_DATA_READY") = False Then

-            MsgBox _

-                Prompt:="Недостаточна глубина выборки данных." _

-                    & vbCrLf & "Измените параметры запроса и пробуйте снова.", _

-                Buttons:=vbOKOnly + vbExclamation, _

-                Title:=PROGRAM_NAME

-            

-            ClearResultTables

-            

-            With .Worksheets(FORM_SHEET)

-                .Range("CALC_TICKER_NAME") = ticker & ", Period=" & Period

-                .Range("FILE_NAME") = ""

-                .Range(TABLE_COMMENT).Value = "Недостаточно данных"

-            End With

-        Else

-            If TDenmark_Calc Then

-                With .Worksheets(FORM_SHEET)

-                    .Range("CALC_TICKER_NAME") = ticker & ", Period=" & Period

-                    .Range("FILE_NAME") = ""

-                End With

-            End If

-        End If

-    End With

-End Sub

-

-

-Sub evSubmit_Click()

-

-    Application.Cursor = xlWait

-    Dim wb As Workbook

-    Set wb = ThisWorkbook

-    With wb

-        With .Worksheets(VAR_SHEET)

-            If .Range("BOOL_DATA_READY") = False Or .Range("BOOL_LOAD_DATA") = True Then

-                If .Range("BOOL_FILE_DATA") = False Then

-                    .Range("BOOL_DATA_READY") = UpdateHistoryFromWeb(wb)

-                Else

-                    evFileOpen

-                    Application.Cursor = xlDefault

-                    Exit Sub

-                End If

-            End If

-            .Range("BOOL_DEMARK_READY") = False

-            If .Range("BOOL_FILE_DATA") = False Then

-                sbCalcWeb

-            Else

-                sbCalcFile

-            End If

-        End With

-    End With

-    Application.Cursor = xlDefault

-End Sub

-

-Sub evTicker_Change()

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("IDX_DEN_SECNAME") = .Range("IDX_DEN_SYMBOL")

-    End With

-    evHistory_Change

-End Sub

-

-Sub evSecName_Change()

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("IDX_DEN_SYMBOL") = .Range("IDX_DEN_SECNAME")

-    End With

-    evHistory_Change

-End Sub

-

-Sub evLastInterval_Change()

-    MsgBox "Не работает в этой версии"

-End Sub

-

-Sub evHistory_Change()

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        .Range("BOOL_DATA_READY") = False

-    End With

-End Sub

-

-Sub evGroupChange()

-    Dim GroupIdx, LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange As String

-    With ThisWorkbook.Worksheets(VAR_SHEET)

-        GroupIdx = .Range("IDX_DEN_LIST")

-        .Range("IDX_DEN_SYMBOL") = 1

-        NewRangeOffsetCol = (GroupIdx - 1) * 2

-        LinesCount = GetLinesCount(.Range("TICKER_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .Name & "!" & .Range(.Range("TICKER_TABLES").Offset(1, NewRangeOffsetCol), .Range("TICKER_TABLES").Offset(LinesCount, NewRangeOffsetCol)).Address

-        ThisWorkbook.Worksheets(FORM_SHEET).Shapes("cbxTikers").ControlFormat.ListFillRange = NewCbxRange

-        NewRangeOffsetCol = NewRangeOffsetCol + 1

-        NewCbxRange = .Name & "!" & .Range(.Range("TICKER_TABLES").Offset(1, NewRangeOffsetCol), .Range("TICKER_TABLES").Offset(LinesCount, NewRangeOffsetCol)).Address

-        ThisWorkbook.Worksheets(FORM_SHEET).Shapes("cbxSecName").ControlFormat.ListFillRange = NewCbxRange

-    End With

-    evTicker_Change

-End Sub

-

-Sub evUpdateTickerList()

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_FILE_DATA") = False Then

-        UpdateTickerList ThisWorkbook

-        evHistory_Change

-    End If

-End Sub

-

-Sub evParamChange()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DEMARK_READY") = False

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_AUTORECALC") = True Then

-        evSubmit_Click

-    End If

-End Sub

-

-<<<<<<
-======================
-mGetFileData
->>>>>>
-Attribute VB_Name = "mGetFileData"

-Option Explicit

-

-Dim mobjAppRunEnable As New cEnableRun

-

-Public Const MAX_LOAD_DATA_LINES As Integer = 16000

-

-Public Const MSG_FILE_VERY_SMALL As String = "В файле недостаточно данных"

-Public Const MSG_FILE_INVALID_FORMAT As String = "Неверный формат файла"

-

-Public Const FUNCRES_FILE_OK As Integer = 0

-Public Const FUNCRES_FILE_VERY_SMALL As Integer = -1

-Public Const FUNCRES_FILE_INVALID_FORMAT As Integer = -2

-

-Function UpdateHistoryFromFile(wb As Workbook, fileToOpen As String) As Integer

-    Dim DestRangeName As String

-    Dim ResultLength As Integer

-    Dim Location As Range

-    Dim denWindow As Integer

-    Dim IsIntraday As Boolean

-    Dim CalcNextTime As Boolean

-        

-    Dim SingleFileLine As String

-    Dim FileHandler As Integer

-    Dim i, j, row_idx As Integer

-    

-    UpdateHistoryFromFile = FUNCRES_FILE_INVALID_FORMAT

-    With wb

-        .Application.ScreenUpdating = False

-        With .Worksheets(VAR_SHEET)

-            CalcNextTime = .Range("BOOL_NEXT_TIME")

-            denWindow = .Range("DEN_WINDOW") + 1

-            If CalcNextTime Then

-                denWindow = denWindow + 1

-            End If

-            IsIntraday = True

-        End With

-        With .Worksheets(RAW_DATA_SHEET)

-            'Clear table include temp area

-            .Parent.Application.DisplayAlerts = False

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW - 1, RAW_DATA_RANGE_COL - 1), _

-                .Cells(65535, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-            ).ClearContents

-            Set Location = .Range(RAW_DATA_RANGE).Offset(-1, 0)

-            

-            ' Reading data from file

-            FileHandler = FreeFile

-            row_idx = 0

-            Open fileToOpen For Input As #FileHandler

-            Do While Not EOF(FileHandler) And row_idx < MAX_LOAD_DATA_LINES

-                Line Input #FileHandler, SingleFileLine

-                .Range(PRICE_TABLE).Offset(row_idx, 0) = SingleFileLine

-                row_idx = row_idx + 1

-            Loop

-            Close #FileHandler

-            

-            ' Parsing data

-            DestRangeName = "=" & RAW_DATA_SHEET & "!$B$1:$B" & row_idx

-            ResultLength = row_idx

-            

-            .Range(DestRangeName).TextToColumns _

-                Destination:=.Range(DestRangeName), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=True, _

-                Semicolon:=True, _

-                Comma:=True, _

-                Space:=False, _

-                Other:=False, _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 1), _

-                                Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1))

-            

-            .Parent.Application.DisplayAlerts = True

-            Dim CurrentDate As String

-            Dim RawData As Range

-            

-            Set RawData = .Range(RAW_DATA_RANGE)

-            

-            If Not CheckFileFormat(RawData.Offset(-1, 0)) Then

-                UpdateHistoryFromFile = FUNCRES_FILE_INVALID_FORMAT

-                Exit Function

-            End If

-            

-            row_idx = 0

-            With RawData

-                CurrentDate = .Value

-                For i = 1 To ResultLength

-                    If Not IsIntraday And CurrentDate = .Offset(i, DATE_IDX).Value Then

-                        ' skip virtual prices

-                        If (.Offset(i, VOLUME_IDX) > MIN_PRICE_VALUE) Then

-                            If .Offset(row_idx, HIGH_IDX).Value < .Offset(i, HIGH_IDX).Value Then

-                                .Offset(row_idx, HIGH_IDX).Value = .Offset(i, HIGH_IDX).Value

-                            End If

-                            If .Offset(row_idx, LOW_IDX).Value > .Offset(i, LOW_IDX).Value Then

-                                .Offset(row_idx, LOW_IDX).Value = .Offset(i, LOW_IDX).Value

-                            End If

-                            .Offset(row_idx, VOLUME_IDX).Value = _

-                                .Offset(row_idx, VOLUME_IDX).Value + .Offset(i, VOLUME_IDX).Value

-                            .Offset(row_idx, TIME_IDX).Value = .Offset(i, TIME_IDX).Value

-                            .Offset(row_idx, CLOSE_IDX).Value = .Offset(i, CLOSE_IDX).Value

-                        End If

-                    Else

-                        ' skip virtual prices

-                        If (.Offset(row_idx, VOLUME_IDX) > MIN_PRICE_VALUE) Then

-                            row_idx = row_idx + 1

-                        End If

-                        For j = DATE_IDX To VOLUME_IDX

-                            .Offset(row_idx, j) = .Offset(i, j)

-                        Next j

-                        CurrentDate = .Offset(i, DATE_IDX)

-                    End If

-                Next i

-            End With ' RawData

-            ' Clear unused Cells

-            .Range( _

-                .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(65536, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-            ).ClearContents

-            

-            If row_idx > denWindow Then

-                row_idx = row_idx - denWindow

-                .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + PROJECT_IDX) _

-                ).Delete xlShiftUp

-            Else

-                UpdateHistoryFromFile = FUNCRES_FILE_VERY_SMALL

-                Exit Function

-            End If

-            

-            row_idx = denWindow + 1

-            

-            Set Location = .Range( _

-                .Cells(RAW_DATA_RANGE_ROW, RAW_DATA_RANGE_COL + DATE_IDX), _

-                .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_IDX) _

-            )

-            

-            Location.TextToColumns _

-                Destination:=Location.Offset(0, DATE_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:="/", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2))

-            

-            Location.Offset(0, TIME_IDX).TextToColumns _

-                Destination:=Location.Offset(0, TIME_STAMP_OFFSET), _

-                DataType:=xlDelimited, _

-                TextQualifier:=xlDoubleQuote, _

-                ConsecutiveDelimiter:=False, _

-                Tab:=False, _

-                Semicolon:=False, _

-                Comma:=False, _

-                Space:=False, _

-                Other:=True, _

-                OtherChar:=":", _

-                FieldInfo:=Array(Array(1, 2), Array(2, 2))

-            

-            ' Check estimation date

-            

-            Dim end_date, end_time As Date

-            Dim year, month, day As Integer

-            Dim hour, minute As Integer

-            Dim next_time_exist As Boolean

-            

-            year = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 3)

-            month = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 2)

-            day = Location.Cells(denWindow - 1, DATE_STAMP_OFFSET + 1)

-            hour = Location.Cells(denWindow - 1, TIME_STAMP_OFFSET + 1)

-            minute = Location.Cells(denWindow - 1, TIME_STAMP_OFFSET + 2)

-            

-            next_time_exist = day + month + year <> 0

-            

-            If next_time_exist Then

-                end_date = DateSerial(year, month, day)

-                end_time = TimeSerial(hour, minute, 0)

-                mobjAppRunEnable.EnableRun ESTIMATION_DATE, end_date

-            End If

-             

-            row_idx = 0

-            Dim temp_str As String

-                    

-            If IsIntraday Then

-                Do While IsEmpty(Location.Cells(1 + row_idx, 1 + DATE_IDX)) = False

-                       temp_str = Location.Cells(1 + row_idx, 1 + PROJECT_IDX + 1)

-                       temp_str = temp_str & "/"

-                       temp_str = temp_str & Location.Cells(1 + row_idx, 1 + PROJECT_IDX + 2)

-                       temp_str = temp_str & "-"

-                       temp_str = temp_str & Location.Cells(1 + row_idx, 1 + TIME_IDX)

-                       Location.Cells(1 + row_idx, DATE_IDX) = temp_str

-                       row_idx = row_idx + 1

-                Loop

-                row_idx = row_idx - 1

-                Dim condition As Boolean

-                condition = Not CalcNextTime And next_time_exist And end_date = DateValue(Now) And end_time > TimeValue(Now)

-                If condition Then

-                    .Range( _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL - 1), _

-                        .Cells(RAW_DATA_RANGE_ROW + row_idx, RAW_DATA_RANGE_COL + DATE_STAMP_OFFSET + DATE_TIME_STAMP_SIZE) _

-                    ).Delete xlShiftUp

-                End If

-            End If

-        End With ' .Worksheets(RAW_DATA_SHEET)

-    End With ' wb

-    UpdateHistoryFromFile = FUNCRES_FILE_OK

-End Function

-

-Function CheckFileFormat(HeaderString As Range) As Boolean

-    With HeaderString

-        CheckFileFormat = _

-            .Offset(0, DATE_IDX) = "Date" And _

-            .Offset(0, TIME_IDX) = "Time" And _

-            .Offset(0, OPEN_IDX) = "Open" And _

-            .Offset(0, CLOSE_IDX) = "Close" And _

-            .Offset(0, LOW_IDX) = "Low" And _

-            .Offset(0, HIGH_IDX) = "High" And _

-            .Offset(0, VOLUME_IDX) = "Volume"

-    End With

-End Function

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Macros
->>>>>>
-Attribute VB_Name = "Macros"

-Sub RangeNorm()

-    Dim src As Range

-    Dim dst As Range

-    

-    Set dst = Selection

-    Selection.DirectPrecedents.Select

-    Set src = Selection

-    RangeNormalize src, dst

-End Sub

-

-Sub RangeNormalize(src As Range, dst As Range)

-    Dim f As Double

-    Dim c As Range

-    f = dst

-    If f <> 0 Then

-        For Each c In src

-            c = c / f

-        Next c

-    End If

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Unprotect "password"

-    ThisWorkbook.Save

-End Sub

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Protect password:="password"

-    Worksheets("Calc").Protect password:="password", userInterfaceonly:=True

-    Worksheets("Calc").Select

-    Worksheets("Calc").Range("A7").Select

-End Sub

-<<<<<<
-======================
-Calc
->>>>>>
-Attribute VB_Name = "Calc"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Sub SelectAll()

-    Dim Sh As Shape

-    For Each Sh In Shapes

-        If InStr(1, Sh.Name, "Check") Then

-            Sh.Select

-            Selection.Value = xlOn

-        End If

-    Next Sh

-    Range("A7").Select

-End Sub

-

-Sub ClearAll()

-    Dim Sh As Shape

-    For Each Sh In Shapes

-        If InStr(1, Sh.Name, "Check") Then

-            Sh.Select

-            Selection.Value = xlOff

-        End If

-    Next Sh

-    Range("A7").Select

-    Worksheets("Data").Range("K2") = 1

-    Worksheets("Calc").Range("E58") = 1

-End Sub

-

-<<<<<<
-======================
-Data
->>>>>>
-Attribute VB_Name = "Data"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Unprotect "password"

-    ThisWorkbook.Save

-End Sub

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Protect password:="password"

-    Worksheets("Calc").Protect password:="password", userInterfaceonly:=True

-    Worksheets("Calc").Select

-    Worksheets("Calc").Range("A7").Select

-End Sub

-<<<<<<
-======================
-Calc
->>>>>>
-Attribute VB_Name = "Calc"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Sub SelectAll()

-    Dim Sh As Shape

-    For Each Sh In Shapes

-        If InStr(1, Sh.Name, "Check") Then

-            Sh.Select

-            Selection.Value = xlOn

-        End If

-    Next Sh

-    Range("A7").Select

-End Sub

-

-Sub ClearAll()

-    Dim Sh As Shape

-    For Each Sh In Shapes

-        If InStr(1, Sh.Name, "Check") Then

-            Sh.Select

-            Selection.Value = xlOff

-        End If

-    Next Sh

-    Range("A7").Select

-    Worksheets("Data").Range("K2") = 1

-    Worksheets("Calc").Range("E58") = 1

-End Sub

-

-<<<<<<
-======================
-Data
->>>>>>
-Attribute VB_Name = "Data"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Unprotect "password"

-    ThisWorkbook.Save

-End Sub

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Protect password:="password"

-    Worksheets("Calc").Protect password:="password", userInterfaceonly:=True

-    Worksheets("Calc").Select

-    Worksheets("Calc").Range("A7").Select

-End Sub

-<<<<<<
-======================
-Calc
->>>>>>
-Attribute VB_Name = "Calc"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Sub SelectAll()

-    Dim Sh As Shape

-    For Each Sh In Shapes

-        If InStr(1, Sh.Name, "Check") Then

-            Sh.Select

-            Selection.Value = xlOn

-        End If

-    Next Sh

-    Range("A7").Select

-End Sub

-

-Sub ClearAll()

-    Dim Sh As Shape

-    For Each Sh In Shapes

-        If InStr(1, Sh.Name, "Check") Then

-            Sh.Select

-            Selection.Value = xlOff

-        End If

-    Next Sh

-    Range("A7").Select

-    Worksheets("Data").Range("K2") = 1

-    Worksheets("Calc").Range("E58") = 1

-End Sub

-

-<<<<<<
-======================
-Data
->>>>>>
-Attribute VB_Name = "Data"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Dec2TS
->>>>>>
-Attribute VB_Name = "Dec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-Dec2Hex
->>>>>>
-Attribute VB_Name = "Dec2Hex"

-Option Explicit

-

-

-Function Dec2Hex(Dec As Long) As String

-

-Const HexNumbers As String = "0123456789ABCDEF"

-Const HexBase As Integer = 16

-    

-    Dim HexStr As String

-    Dim idx As Integer

-    

-    HexStr = ""

-    

-    If Dec = 0 Then

-        HexStr = Mid(HexNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod HexBase

-            HexStr = Mid(HexNumbers, idx + 1, 1) + HexStr

-            Dec = Dec \ HexBase

-        Wend

-    End If

-    Dec2Hex = HexStr

-End Function

-

-

-Function Dec2Thirty(Dec As Long) As String

-

-Const ThirtyNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRST"

-Const ThirtyBase As Integer = 30

-    

-    Dim ThirtyStr As String

-    Dim idx As Integer

-    

-    ThirtyStr = ""

-    

-    If Dec = 0 Then

-        ThirtyStr = Mid(ThirtyNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtyBase

-            ThirtyStr = Mid(ThirtyNumbers, idx + 1, 1) + ThirtyStr

-            Dec = Dec \ ThirtyBase

-        Wend

-    End If

-    Dec2Thirty = ThirtyStr

-End Function

-

-<<<<<<
-======================
-Serial
->>>>>>
-Attribute VB_Name = "Serial"

-Option Explicit

-

-Function LeadingNull(FmtStr As String, Dec As Integer) As String

-    Dim s As String

-        

-    LeadingNull = s

-End Function

-

-Function HowDigits(Dec As Integer) As Integer

-    Dim n As Integer

-    n = 0

-    While Dec <> 0

-         Dec = Dec \ 10

-         n = n + 1

-    Wend

-    HowDigits = n

-End Function

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Macros
->>>>>>
-Attribute VB_Name = "Macros"

-Sub RangeNorm()

-    Dim src As Range

-    Dim dst As Range

-    

-    Set dst = Selection

-    Selection.DirectPrecedents.Select

-    Set src = Selection

-    RangeNormalize src, dst

-End Sub

-

-Sub RangeNormalize(src As Range, dst As Range)

-    Dim f As Double

-    Dim c As Range

-    f = dst

-    If f <> 0 Then

-        For Each c In src

-            c = c / f

-        Next c

-    End If

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ClientContact
->>>>>>
-Attribute VB_Name = "ClientContact"

-Attribute VB_Base = "0{D082ACDB-DC01-4BAC-B1F3-E7AB4DF09CA4}{65A5E819-AC4C-46D3-923F-BCD8180C1EB7}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Private Sub Workbook_Open()

-    Dim edit_mode As Boolean

-    edit_mode = Worksheets(SHEET_OEM_DATA).Range("EditAppMode")

-    If edit_mode Then

-        btEditApp_Click

-    End If

-    Worksheets(SHEET_OEM_KEY).Select

-End Sub

-<<<<<<
-======================
-xTEST_NUM
->>>>>>
-Attribute VB_Name = "xTEST_NUM"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-xFACE
->>>>>>
-Attribute VB_Name = "xFACE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    setup_interface

-End Sub

-

-Sub setup_interface()

-    Dim listsize As Integer

-    Dim r As Range

-    Dim NewCbxRange As String

-    Dim NewCbxSelection As String

-    

-    NewCbxRange = Get_OEM_Names_Range_Address

-    NewCbxSelection = Worksheets(SHEET_OEM_DATA).Name & "!" & _

-                        Worksheets(SHEET_OEM_DATA).Range(RANGE_OEM_IDX).Address

-    Unprotect

-    ActiveSheet.Shapes("oemList").Select

-    With Selection

-        .ListFillRange = NewCbxRange

-        .LinkedCell = NewCbxSelection

-        .DropDownLines = 8

-        .Display3DShading = True

-    End With

-    

-    NewCbxRange = Get_SYS_Names_Range_Address

-    NewCbxSelection = Worksheets(SHEET_OEM_DATA).Name & "!" & _

-                        Worksheets(SHEET_OEM_DATA).Range(RANGE_SYS_IDX).Address

-                        

-    Worksheets(SHEET_OEM_KEY).Shapes("sysList").Select

-    With Selection

-        .ListFillRange = NewCbxRange

-        .LinkedCell = NewCbxSelection

-        .DropDownLines = 8

-        .Display3DShading = True

-    End With

-    

-    NewCbxRange = Get_SOFT_Names_Range_Address

-    NewCbxSelection = Worksheets(SHEET_OEM_DATA).Name & "!" & _

-                        Worksheets(SHEET_OEM_DATA).Range(RANGE_SOFT_IDX).Address

-                        

-    Worksheets(SHEET_OEM_KEY).Shapes("softList").Select

-    With Selection

-        .ListFillRange = NewCbxRange

-        .LinkedCell = NewCbxSelection

-        .DropDownLines = 8

-        .Display3DShading = True

-    End With

-    

-    Range("Version").Select

-    If Not Worksheets(SHEET_OEM_DATA).Range("EditAppMode") Then

-        Protect UserInterfaceonly:=True

-    End If

-End Sub

-<<<<<<
-======================
-xTEST_SER
->>>>>>
-Attribute VB_Name = "xTEST_SER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Dec2TS
->>>>>>
-Attribute VB_Name = "Dec2TS"

-Option Explicit

-

-'Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-'Const ThirtySixBase As Integer = 36

-

-Public Const ThirtySixNumbers As String = "123456789ABCDEFGHIJKLMNPQRSTUVWXYZ"

-Public Const ThirtySixBase As Integer = 34

-

-Function Dec2ThirtySix(ByVal Dec As Long) As String

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Double

-    

-    ThirtySixStr = TS

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If ThirtySixStr = "" Then

-        Dec = 0

-    Else

-        While ThirtySixStr <> ""

-            lastdigit = Right(ThirtySixStr, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            ThirtySixStr = Mid(ThirtySixStr, 1, Len(ThirtySixStr) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-

-Function ThirtySix2ChkSum(TS As String) As Integer

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim chksum As Integer

-    

-    ThirtySixStr = TS

-

-    chksum = 0

-    

-    If ThirtySixStr = "" Then

-        chksum = 0

-    Else

-        While ThirtySixStr <> ""

-            lastdigit = Right(ThirtySixStr, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit) - 1

-            chksum = (chksum + idx) Mod ThirtySixBase

-            ThirtySixStr = Left(ThirtySixStr, Len(ThirtySixStr) - 1)

-        Wend

-    End If

-

-    ThirtySix2ChkSum = chksum

-End Function

-<<<<<<
-======================
-newItemDlg
->>>>>>
-Attribute VB_Name = "newItemDlg"

-Attribute VB_Base = "0{C677F1A4-9481-4111-8411-6942E8A48078}{F44556AE-89CF-426B-B97B-86777B210E93}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub AddSYS_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub resetSYS_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-<<<<<<
-======================
-xTEST_SN
->>>>>>
-Attribute VB_Name = "xTEST_SN"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-xDATA
->>>>>>
-Attribute VB_Name = "xDATA"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mSerial
->>>>>>
-Attribute VB_Name = "mSerial"

-Option Explicit

-

-Public Const SN_MAX_ROOT As Integer = ThirtySixBase - 1

-Public Const SN_MAX_NUM2 As Integer = ThirtySixBase ^ 2

-Public Const SN_MAX_NUM4 As Long = ThirtySixBase ^ 3

-Public Const SN_MAX_PREFIX_NOISE As Integer = (ThirtySixBase ^ 2) \ 2

-Public Const SN_MAX_SERIA As Long = 50000

-Public Const SN_MAX_VERSION As Long = 999

-

-Public Const SN_MIN_OEM_ID As Integer = 100

-Public Const SN_MIN_SYS_ID As Integer = 100

-Public Const SN_MIN_SOFT_ID As Integer = 100

-

-Public Const SN_MAX_OEM_ID As Integer = 300

-Public Const SN_MAX_SYS_ID As Integer = 300

-Public Const SN_MAX_SOFT_ID As Integer = 300

-

-Public Const SN_TOP_SERIA As Long = 100000

-Public Const SN_TOP_VER As Long = 1000

-Public Const SN_LEN_T As Integer = 25

-Public Const SN_LEN_1 As Integer = 5

-Public Const SN_LEN_2 As Integer = 5

-Public Const SN_LEN_3 As Integer = 6

-Public Const SN_LEN_4 As Integer = 5

-

-Function serial_check_id_sum(id_sn As String) As Integer

-    Dim i As Integer

-    Dim s As String

-    Dim chk As Integer

-    

-    s = id_sn

-    chk = 0

-    While s <> ""

-        i = Left(s, 1)

-        chk = (chk + i) Mod 10

-        s = Right(s, Len(s) - 1)

-    Wend

-    serial_check_id_sum = chk

-End Function

-

-Function get_sn_root(sn As String) As Integer

-    If sn = "" Or Len(sn) < SN_LEN_T Then

-        get_sn_root = 0

-        Exit Function

-    End If

-    

-    Dim s As String

-    s = Right(sn, 1)

-    get_sn_root = ThirtySix2Dec(s)

-End Function

-

-Function serial_check_id(sn As String) As Boolean

-    Dim chk_id As Integer

-    Dim s As String

-    

-    chk_id = get_sn_check_id(sn)

-    s = get_sn_1(sn)

-    s = s & get_sn_2(sn)

-    s = s & Left(get_sn_3(sn), Len("" & SN_TOP_SERIA))

-    s = s & Right(get_sn_3(sn), 3) & get_sn_4(sn)

-    Dim ci As Integer

-    ci = serial_check_id_sum(s)

-    serial_check_id = ci = chk_id

-End Function

-

-Function serial_check(sn As String) As Boolean

-    If sn = "" Or Len(sn) < SN_LEN_T Then

-        serial_check = False

-        Exit Function

-    End If

-    

-    Dim chk As Integer

-    chk = ThirtySix2Dec(Left(sn, 1))

-    

-    Dim bool As Boolean

-    bool = Len(sn) = SN_LEN_T

-    bool = bool And ThirtySix2ChkSum(get_sn_noise(sn)) = chk

-    bool = bool And serial_check_id(sn)

-

-    serial_check = bool

-End Function

-

-Function get_sn_noise(sn As String) As String

-    If sn = "" Or Len(sn) < SN_LEN_T Then

-        get_sn_noise = ""

-        Exit Function

-    End If

-        

-    Dim root As Integer

-    Dim s As String

-    root = get_sn_root(sn)

-    s = Mid(sn, 2, Len(sn) - 2)

-    get_sn_noise = ROT_Right(s, root)

-End Function

-

-Function get_sn_clear(sn As String) As String

-    If sn = "" Or Len(sn) < SN_LEN_T Then

-        get_sn_clear = ""

-        Exit Function

-    End If

-        

-    Dim s As String

-    s = get_sn_noise(sn)

-    get_sn_clear = Right(s, Len(s) - 2)

-End Function

-

-Function get_sn_1(sn As String) As String

-    If sn = "" Or Len(sn) < SN_LEN_T Then

-        get_sn_1 = ""

-        Exit Function

-    End If

-        

-    get_sn_1 = "" & ThirtySix2Dec(Left(get_sn_clear(sn), SN_LEN_1))

-End Function

-

-Function get_sn_oem_id(sn As String) As Integer

-    If sn = "" Or Len(sn) < SN_LEN_T Then

-        get_sn_oem_id = -1

-        Exit Function

-    End If

-    

-    get_sn_oem_id = Right(get_sn_1(sn), 3)

-End Function

-

-Function get_sn_oem_name(sn As String) As String

-    If sn = "" Or Len(sn) < SN_LEN_T Then

-        get_sn_oem_name = ""

-        Exit Function

-    End If

-    

-    Dim oem_id As Integer

-    Dim r As Range

-    Dim c As Range

-    Dim s As String

-    oem_id = get_sn_oem_id(sn)

-    s = Get_OEM_ID_Range_Address

-    Set r = Range(s)

-    s = ""

-    For Each c In r

-        If c = oem_id Then

-            s = c.Offset(0, 1)

-            Exit For

-        End If

-    Next c

-    get_sn_oem_name = s

-End Function

-

-Function get_sn_date(sn As String) As Long

-    If sn = "" Or Len(sn) < SN_LEN_T Then

-        get_sn_date = -1

-        Exit Function

-    End If

-    

-    Dim s1 As String

-    s1 = get_sn_1(sn)

-    get_sn_date = Left(s1, 5)

-End Function

-

-Function get_sn_2(sn As String) As String

-    If sn = "" Or Len(sn) < SN_LEN_T Then

-        get_sn_2 = ""

-        Exit Function

-    End If

-    get_sn_2 = "" & ThirtySix2Dec(Mid(get_sn_clear(sn), SN_LEN_1 + 1, SN_LEN_2))

-End Function

-

-Function get_sn_version(sn As String) As Integer

-    If sn = "" Or Len(sn) < SN_LEN_T Then

-        get_sn_version = -1

-        Exit Function

-    End If

-    get_sn_version = Right(get_sn_2(sn), 4) - SN_TOP_VER

-End Function

-

-Function get_sn_3(sn As String) As String

-    If sn = "" Or Len(sn) < SN_LEN_T Then

-        get_sn_3 = ""

-        Exit Function

-    End If

-    get_sn_3 = "" & ThirtySix2Dec(Mid(get_sn_clear(sn), _

-                                        SN_LEN_1 + SN_LEN_2 + 1, _

-                                        SN_LEN_3) _

-                                    )

-End Function

-

-Function get_sn_soft_id(sn As String) As Integer

-    If sn = "" Or Len(sn) < SN_LEN_T Then

-        get_sn_soft_id = -1

-        Exit Function

-    End If

-    get_sn_soft_id = Right(get_sn_3(sn), 3)

-End Function

-

-Function get_sn_check_id(sn As String) As Integer

-    If sn = "" Or Len(sn) < SN_LEN_T Then

-        get_sn_check_id = 0

-        Exit Function

-    End If

-    get_sn_check_id = Mid(get_sn_3(sn), 7, 1)

-End Function

-

-Function get_sn_soft_name(sn As String) As String

-    If sn = "" Or Len(sn) < SN_LEN_T Then

-        get_sn_soft_name = ""

-        Exit Function

-    End If

-    

-    Dim soft_id As Integer

-    Dim r As Range

-    Dim c As Range

-    Dim s As String

-    soft_id = get_sn_soft_id(sn)

-    s = Get_SOFT_ID_Range_Address

-    Set r = Range(s)

-    s = ""

-    For Each c In r

-        If c = soft_id Then

-            s = c.Offset(0, 1)

-            Exit For

-        End If

-    Next c

-    get_sn_soft_name = s

-End Function

-

-Function get_sn_seria(sn As String) As Long

-    If sn = "" Or Len(sn) < SN_LEN_T Then

-        get_sn_seria = -1

-        Exit Function

-    End If

-    

-    Dim s3 As String

-    s3 = get_sn_3(sn)

-    get_sn_seria = Left(s3, 6) - SN_TOP_SERIA + 1

-End Function

-

-Function get_sn_4(sn As String) As String

-    If sn = "" Or Len(sn) < SN_LEN_T Then

-        get_sn_4 = ""

-        Exit Function

-    End If

-    

-    get_sn_4 = "" & ThirtySix2Dec(Mid(get_sn_clear(sn), _

-                                        SN_LEN_1 + SN_LEN_2 + SN_LEN_3 + 1, _

-                                        SN_LEN_4) _

-                                    )

-End Function

-

-Function get_sn_sys_id(sn As String) As Integer

-    If sn = "" Or Len(sn) < SN_LEN_T Then

-        get_sn_sys_id = -1

-        Exit Function

-    End If

-    

-    get_sn_sys_id = Left(get_sn_4(sn), 3)

-End Function

-

-Function get_sn_sys_name(sn As String) As String

-    If sn = "" Or Len(sn) < SN_LEN_T Then

-        get_sn_sys_name = ""

-        Exit Function

-    End If

-    

-    Dim sys_id As Integer

-    Dim r As Range

-    Dim c As Range

-    Dim s As String

-    sys_id = get_sn_sys_id(sn)

-    s = Get_SYS_ID_Range_Address

-    Set r = Range(s)

-    s = ""

-    

-    For Each c In r

-        If c = sys_id Then

-            s = c.Offset(0, 1)

-            Exit For

-        End If

-    Next c

-    get_sn_sys_name = s

-End Function

-

-Function set_sn_root() As Long

-    set_sn_root = Int(Rnd() * SN_MAX_ROOT) + 1

-End Function

-

-Function set_sn_num2() As Long

-    set_sn_num2 = SN_MAX_NUM2 + Int(Rnd() * (SN_MAX_NUM2))

-End Function

-

-Function set_sn_num4() As Long

-    set_sn_num4 = SN_MAX_NUM4 + Int(Rnd() * (SN_MAX_NUM4))

-End Function

-

-Function set_prefix_noise() As Long

-    set_prefix_noise = SN_MAX_PREFIX_NOISE + _

-                        Int(Rnd() * (SN_MAX_PREFIX_NOISE - 1)) + 1

-End Function

-

-Function set_sn_date() As Long

-    Dim d_date As Long

-    d_date = (Year(Now()) Mod 10)

-    d_date = d_date * 10000

-    d_date = d_date + Month(Now()) * 100

-    d_date = d_date + Day(Now())

-    set_sn_date = d_date

-End Function

-

-Function set_sn_1(oem_id As Integer) As String

-    set_sn_1 = set_sn_date & oem_id

-End Function

-

-Function set_sn_2(ByVal version As Integer) As String

-    version = version + SN_TOP_VER

-    set_sn_2 = set_sn_num2 & version

-End Function

-

-Function set_sn_3(soft_id As Integer, seria As Long, cs As String) As String

-    set_sn_3 = (seria - 1 + SN_TOP_SERIA) & cs & soft_id

-End Function

-

-Function set_sn_4(sys_id As Integer) As String

-    set_sn_4 = sys_id & set_sn_num4

-End Function

-

-Function serial_generate(oem_id As Integer, soft_id As Integer, ver As Integer, sys_id As Integer, seria As Long)

-    Dim sn As String

-    Dim chk As String

-    Dim root As Integer

-    Dim s1 As String

-    Dim s2 As String

-    Dim s4 As String

-    

-    s1 = set_sn_1(oem_id)

-    s2 = set_sn_2(ver)

-    s4 = set_sn_4(sys_id)

-    

-    sn = s1 & s2 & set_sn_3(soft_id, seria, "") & s4

-    

-    chk = serial_check_id_sum(sn)

-     

-    sn = Dec2ThirtySix(set_prefix_noise) & _

-            Dec2ThirtySix(s1) & _

-            Dec2ThirtySix(s2) & _

-            Dec2ThirtySix(set_sn_3(soft_id, seria, chk)) & _

-            Dec2ThirtySix(s4)

-    

-    chk = Dec2ThirtySix(ThirtySix2ChkSum(sn))

-    root = set_sn_root

-    sn = chk & ROT_Left(sn, root) & Dec2ThirtySix(root)

-

-    serial_generate = sn

-End Function

-

-Function serial_format(sn As String, deliver As String) As String

-    serial_format = Left(sn, 5) _

-            & deliver & Mid(sn, 6, 5) _

-            & deliver & Mid(sn, 11, 5) _

-            & deliver & Mid(sn, 16, 5) _

-            & deliver & Right(sn, Len(sn) - 20)

-End Function

-

-Function Rotate_Left(r As Range, position As Integer) As String

-    Dim r_str As String

-    r_str = r

-    Rotate_Left = ROT_Left(r_str, position)

-End Function

-

-Function Rotate_Right(r As Range, position As Integer) As String

-    Dim r_str As String

-    r_str = r

-    Rotate_Right = ROT_Right(r_str, position)

-End Function

-

-Function ROT_Left(s As String, position As Integer) As String

-    Dim i As Integer

-    Dim slen As Integer

-    

-    Dim r_str As String

-    Dim ch As String

-    

-    r_str = s

-    

-    slen = Len(r_str)

-    For i = 1 To position

-        ch = Left(r_str, 1)

-        r_str = Right(r_str, slen - 1)

-        r_str = r_str + ch

-    Next i

-    

-    ROT_Left = r_str

-End Function

-

-Function ROT_Right(s As String, position As Integer) As String

-    Dim i As Integer

-    Dim slen As Integer

-    

-    Dim r_str As String

-    Dim ch As String

-    

-    r_str = s

-    

-    slen = Len(r_str)

-    For i = 1 To position

-        ch = Right(r_str, 1)

-        r_str = Left(r_str, slen - 1)

-        r_str = ch + r_str

-    Next i

-    

-    ROT_Right = r_str

-End Function

-

-<<<<<<
-======================
-mInterface
->>>>>>
-Attribute VB_Name = "mInterface"

-Option Explicit

-

-Public Const SHEET_OEM_DATA As String = "xDATA"

-Public Const SHEET_OEM_KEY As String = "zFACE"

-

-Public Const RANGE_OEM_IDX As String = "OEM_IDX"

-Public Const RANGE_OEM_ID As String = "OEM_ID"

-Public Const RANGE_OEM_NAME As String = "OEM_NAME"

-

-Public Const RANGE_SYS_IDX As String = "SYS_IDX"

-Public Const RANGE_SYS_ID As String = "SYS_ID"

-Public Const RANGE_SYS_NAME As String = "SYS_NAME"

-

-Public Const RANGE_SOFT_IDX As String = "SOFT_IDX"

-Public Const RANGE_SOFT_ID As String = "SOFT_ID"

-Public Const RANGE_SOFT_NAME As String = "SOFT_NAME"

-

-Const ITEM_ADDED As String = " added to DB :)"

-Const ITEM_IGNORED As String = " nothing :("

-

-Sub btEditApp_Click()

-    Dim mode As Range

-    Set mode = Worksheets(SHEET_OEM_DATA).Range("EditAppMode")

-    mode.Worksheet.Unprotect

-    If mode = True Then

-        mode = False

-    Else

-        mode = True

-    End If

-    With Worksheets(SHEET_OEM_KEY)

-        .Select

-        .Unprotect

-        .Shapes("btEditApp").Select

-        With Selection

-            If mode Then

-                .Characters.Text = "Run"

-                show_sheets

-            Else

-                .Characters.Text = "EditApp"

-                hide_sheets

-            End If

-        End With

-        .Range("Version").Select

-        If Not mode Then

-            .Protect UserInterfaceonly:=True

-        End If

-    End With

-End Sub

-

-Sub snClear_Click()

-    Worksheets(SHEET_OEM_KEY).Range("C15,E15,G15,I15,K15").ClearContents

-End Sub

-

-Sub snCreate_Click()

-    Dim d_date As Long

-    Dim seria As Long

-    Dim version As Integer

-    Dim oem_id As Integer

-    Dim sys_id As Integer

-    Dim soft_id As Integer

-    Dim oem_name As String

-    Dim sys_name As String

-    Dim soft_name As String

-    Dim i As Long

-    Dim r As Range

-    

-    With Worksheets(SHEET_OEM_KEY)

-        version = .Range("Version")

-        seria = .Range("Seria")

-        

-        If version > SN_MAX_VERSION Or version < 1 Then

-            MsgBox "Версия не может быть меньше 1 и больше 999"

-            .Range("Version").Select

-            Exit Sub

-        End If

-    

-        If seria > SN_MAX_SERIA Or seria < 1 Then

-            MsgBox "Серия не может быть меньше 1 и больше 50 000"

-            .Range("Seria").Select

-            Exit Sub

-        End If

-    End With

-    

-    

-    Dim calc_type As Integer

-    calc_type = Application.Calculation

-    Application.Calculation = xlCalculationManual

-    

-    With Worksheets(SHEET_OEM_DATA)

-        oem_id = .Range(RANGE_OEM_IDX)

-        oem_name = .Range(RANGE_OEM_NAME).Offset(oem_id - 1, 0)

-        oem_id = .Range(RANGE_OEM_ID).Offset(oem_id - 1, 0)

-        

-        sys_id = .Range(RANGE_SYS_IDX)

-        sys_name = .Range(RANGE_SYS_NAME).Offset(sys_id - 1, 0)

-        sys_id = .Range(RANGE_SYS_ID).Offset(sys_id - 1, 0)

-        

-        soft_id = .Range(RANGE_SOFT_IDX)

-        soft_name = .Range(RANGE_SOFT_NAME).Offset(soft_id - 1, 0)

-        soft_id = .Range(RANGE_SOFT_ID).Offset(soft_id - 1, 0)

-    End With

-    

-    Dim s As String

-    s = get_new_oem_serial_range

-    Set r = Range(s)

-    

-    r.Worksheet.Unprotect

-    

-    s = Get_OEM_Names_Range_Address

-    r.Offset(0, 0) = oem_id

-    r.Offset(1, 0) = set_sn_date

-    r.Offset(2, 0) = soft_id

-    r.Offset(3, 0) = version

-    r.Offset(4, 0) = sys_name

-    r.Offset(5, 0) = seria

-    

-    Set r = r.Offset(5, 0)

-    

-    Randomize

-    

-    For i = 1 To seria

-        r.Offset(i, 0) = serial_format( _

-                            serial_generate(oem_id, soft_id, version, sys_id, seria), _

-                            " " _

-                        )

-    Next i

-    With r.EntireColumn

-        .AutoFit

-        .HorizontalAlignment = xlCenter

-        .VerticalAlignment = xlBottom

-        .WrapText = False

-    End With

-    r.Worksheet.Select

-    r.Select

-    Application.Calculation = calc_type

-    Application.Calculate

-End Sub

-

-Sub exportSerial()

-    Dim fs As Object

-    Dim a As Object

-    Dim fpath As String

-    Dim fname As String

-    Dim r As Range

-    

-    fpath = GetWBPath(ThisWorkbook.FullName)

-    fname = get_serial_exp_filename()

-    If fname = "" Then

-        MsgBox ("=8-(")

-        Exit Sub

-    End If

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    fname = fpath & fname & ".txt"

-    Set a = fs.CreateTextFile(fname, True)

-    

-    Set r = Range(get_last_oem_serial_range).Offset(5, 0)

-    While r <> ""

-        a.WriteLine (r)

-        Set r = r.Offset(1, 0)

-    Wend

-    a.Close

-    MsgBox ("saved in:" & fname & " ;-)")

-End Sub

-

-Function get_last_oem_serial_range() As String

-    Dim r As Range

-    Set r = Worksheets(get_oem_sheet_name).Range("A1")

-    While r.Offset(0, 1) <> ""

-        Set r = r.Offset(0, 1)

-    Wend

-    get_last_oem_serial_range = r.Worksheet.Name & "!" & r.Address

-End Function

-

-Function get_new_oem_serial_range() As String

-    Dim r As Range

-    Set r = Range(get_last_oem_serial_range)

-    get_new_oem_serial_range = r.Worksheet.Name & "!" & r.Offset(0, 1).Address

-End Function

-

-Function get_serial_exp_filename() As String

-    Dim s As String

-    Dim r As Range

-    s = ""

-    Set r = Range(get_last_oem_serial_range)

-    If r <> ActiveSheet.Range("A1") Then

-        s = r & "_" _

-            & r.Offset(1, 0) & "_" _

-            & r.Offset(2, 0) & "_" _

-            & r.Offset(3, 0) & "_" _

-            & r.Offset(4, 0) & "_" _

-            & r.Offset(5, 0)

-    End If

-    get_serial_exp_filename = s

-End Function

-

-Function get_oem_sheet_name() As String

-    Dim oem_id As Integer

-    With Worksheets(SHEET_OEM_DATA)

-        oem_id = .Range(RANGE_OEM_IDX)

-        oem_id = .Range(RANGE_OEM_ID).Offset(oem_id - 1, 0)

-    End With

-    get_oem_sheet_name = "OEM_" & oem_id

-End Function

-

-Sub to_oem()

-    With Worksheets(get_oem_sheet_name)

-        .Select

-        .Range("A1").Select

-        .Protect UserInterfaceonly:=True

-    End With

-End Sub

-

-Sub to_home()

-    Worksheets(SHEET_OEM_KEY).Select

-End Sub

-

-Sub softAdd_Click()

-    Dim dlg As newItemDlg

-    Set dlg = New newItemDlg

-    

-    dlg.Caption = "Add new Software"

-    dlg.l_ItemName = "Name:"

-    

-    dlg.Show

-

-    Dim msg As String

-    msg = ITEM_IGNORED

-    

-    If dlg.Tag = vbOK Then

-        Dim s As String

-        

-        s = dlg.edItemVal

-        If s <> "" Then

-            AddNewSoft (s)

-            msg = s + ITEM_ADDED

-        End If

-        MsgBox msg

-    End If

-End Sub

-

-Sub oemAdd_Click()

-    Dim dlg As newItemDlg

-    Set dlg = New newItemDlg

-    

-    dlg.Caption = "Add new OEM"

-    dlg.l_ItemName = "Name:"

-    

-    dlg.Show

-    

-    Dim msg As String

-    msg = ITEM_IGNORED

-    

-    If dlg.Tag = vbOK Then

-        Dim s As String

-        

-        s = dlg.edItemVal

-        If s <> "" Then

-            AddNewOEM (s)

-            msg = s + ITEM_ADDED

-        End If

-        MsgBox msg

-    End If

-End Sub

-

-Sub sysAdd_Click()

-    Dim dlg As newItemDlg

-    Set dlg = New newItemDlg

-    

-    dlg.Caption = "Add new System"

-    dlg.l_ItemName = "Name:"

-    

-    dlg.Show

-

-    Dim msg As String

-    msg = ITEM_IGNORED

-    

-    If dlg.Tag = vbOK Then

-        Dim s As String

-        

-        s = dlg.edItemVal

-        If s <> "" Then

-            AddNewSYS (s)

-            msg = s + ITEM_ADDED

-        End If

-        MsgBox msg

-    End If

-End Sub

-

-Sub AddNewOEM(s As String)

-    Dim r_oem_id As Range

-    Dim r_oem_name As Range

-    Dim r As Range

-    Dim idx As Integer

-    Dim id As Integer

-    Dim ws_name As String

-    

-    With Worksheets(SHEET_OEM_DATA)

-        Set r_oem_id = .Range(RANGE_OEM_ID)

-        Set r_oem_name = .Range(RANGE_OEM_NAME)

-        idx = GetLinesCount(r_oem_id)

-        If idx > 0 Then

-            id = r_oem_id.Offset(idx - 1, 0)

-            r_oem_id.Offset(idx, 0) = id + 1

-        Else

-            r_oem_id = SN_MIN_OEM_ID

-        End If

-        r_oem_name.Offset(idx, 0) = s

-        .Range(RANGE_OEM_IDX) = idx + 1

-        ws_name = "OEM_" & r_oem_id.Offset(idx, 0)

-    End With

-    With Sheets.Add

-        .Name = ws_name

-        With .Buttons.Add(3, 83.25, 39, 16)

-            .OnAction = "to_home"

-            .Characters.Text = "home"

-            .Name = "btHome"

-        End With

-        With .Buttons.Add(3, 101.25, 39, 16)

-            .OnAction = "exportSerial"

-            .Characters.Text = "export"

-            .Name = "btSave"

-        End With

-        .Range("A1") = "OEM"

-        .Range("A2") = "DATE"

-        .Range("A3") = "SOFT"

-        .Range("A4") = "VER"

-        .Range("A5") = "SYS"

-        .Range("A6") = "SERIA"

-        With Cells.Font

-            .Name = "Courier"

-            .Size = 10

-        End With

-        .Protect UserInterfaceonly:=True

-    End With

-    

-    Dim ws As Worksheet

-    Set ws = Worksheets(ws_name)

-    ws.Move After:=Worksheets(Worksheets.Count)

-    

-    Worksheets(SHEET_OEM_KEY).Select

-    Worksheets(SHEET_OEM_DATA).Range(RANGE_OEM_IDX) = idx + 1

-End Sub

-

-Sub AddNewSoft(s As String)

-    Dim r_soft_id As Range

-    Dim r_soft_name As Range

-    Dim r As Range

-    Dim idx As Integer

-    Dim id As Integer

-    

-    With Worksheets(SHEET_OEM_DATA)

-        Set r_soft_id = .Range(RANGE_SOFT_ID)

-        Set r_soft_name = .Range(RANGE_SOFT_NAME)

-        idx = GetLinesCount(r_soft_id)

-        If idx > 0 Then

-            id = r_soft_id.Offset(idx - 1, 0)

-            r_soft_id.Offset(idx, 0) = id + 1

-        Else

-            r_soft_id = SN_MIN_SOFT_ID

-        End If

-        r_soft_name.Offset(idx, 0) = s

-    End With

-    Worksheets(SHEET_OEM_KEY).setup_interface

-    Worksheets(SHEET_OEM_DATA).Range(RANGE_SOFT_IDX) = idx + 1

-End Sub

-

-Sub AddNewSYS(s As String)

-    Dim r_sys_id As Range

-    Dim r_sys_name As Range

-    Dim r As Range

-    Dim idx As Integer

-    Dim id As Integer

-    

-    With Worksheets(SHEET_OEM_DATA)

-        Set r_sys_id = .Range(RANGE_SYS_ID)

-        Set r_sys_name = .Range(RANGE_SYS_NAME)

-        idx = GetLinesCount(r_sys_id)

-        If idx > 0 Then

-            id = r_sys_id.Offset(idx - 1, 0)

-            r_sys_id.Offset(idx, 0) = id + 1

-        Else

-            r_sys_id = SN_MIN_SYS_ID

-        End If

-        r_sys_name.Offset(idx, 0) = s

-    End With

-    Worksheets(SHEET_OEM_KEY).setup_interface

-    Worksheets(SHEET_OEM_DATA).Range(RANGE_SYS_IDX) = idx + 1

-End Sub

-

-Function Get_OEM_Names_Range_Address() As String

-    Dim r As Range

-    Dim s As String

-    Dim l As Long

-

-    With Worksheets(SHEET_OEM_DATA)

-        Set r = .Range(RANGE_OEM_ID)

-        l = GetLinesCount(r) - 1

-        If l < 0 Then

-            l = 0

-        End If

-        

-        s = .Name & "!" & _

-            .Range(.Range(RANGE_OEM_NAME), _

-            .Range(RANGE_OEM_NAME).Offset(l, 0)).Address

-

-    End With

-    Get_OEM_Names_Range_Address = s

-End Function

-

-Function Get_SYS_Names_Range_Address() As String

-    Dim r As Range

-    Dim s As String

-    Dim l As Long

-

-    With Worksheets(SHEET_OEM_DATA)

-        Set r = .Range(RANGE_SYS_ID)

-        l = GetLinesCount(r) - 1

-        If l < 0 Then

-            l = 0

-        End If

-    

-        s = .Name & "!" & _

-            .Range(.Range(RANGE_SYS_NAME), _

-            .Range(RANGE_SYS_NAME).Offset(l, 0)).Address

-    End With

-    Get_SYS_Names_Range_Address = s

-End Function

-

-Function Get_SOFT_Names_Range_Address() As String

-    Dim r As Range

-    Dim s As String

-    Dim l As Long

-

-    With Worksheets(SHEET_OEM_DATA)

-        Set r = .Range(RANGE_SOFT_ID)

-        l = GetLinesCount(r) - 1

-        If l < 0 Then

-            l = 0

-        End If

-        s = .Name & "!" & _

-                .Range(.Range(RANGE_SOFT_NAME), _

-                .Range(RANGE_SOFT_NAME).Offset(l, 0)).Address

-    End With

-    Get_SOFT_Names_Range_Address = s

-End Function

-

-Function Get_OEM_ID_Range_Address() As String

-    Dim r As Range

-    Dim s As String

-    Dim l As Long

-

-    With Worksheets(SHEET_OEM_DATA)

-        Set r = .Range(RANGE_OEM_ID)

-        l = GetLinesCount(r) - 1

-        If l < 0 Then

-            l = 0

-        End If

-        s = .Name & "!" & _

-                .Range(.Range(RANGE_OEM_ID), _

-                .Range(RANGE_OEM_ID).Offset(l, 0)).Address

-    End With

-    Get_OEM_ID_Range_Address = s

-End Function

-

-Function Get_SYS_ID_Range_Address() As String

-    Dim r As Range

-    Dim s As String

-    Dim l As Long

-

-    With Worksheets(SHEET_OEM_DATA)

-        Set r = .Range(RANGE_SYS_ID)

-        l = GetLinesCount(r) - 1

-        If l < 0 Then

-            l = 0

-        End If

-        s = .Name & "!" & _

-            .Range(.Range(RANGE_SYS_ID), _

-            .Range(RANGE_SYS_ID).Offset(l, 0)).Address

-    End With

-    Get_SYS_ID_Range_Address = s

-End Function

-

-Function Get_SOFT_ID_Range_Address() As String

-    Dim r As Range

-    Dim s As String

-    Dim l As Long

-

-    With Worksheets(SHEET_OEM_DATA)

-        Set r = .Range(RANGE_SOFT_ID)

-        l = GetLinesCount(r) - 1

-        If l < 0 Then

-            l = 0

-        End If

-        s = .Name & "!" & _

-            .Range(.Range(RANGE_SOFT_ID), _

-            .Range(RANGE_SOFT_ID).Offset(l, 0)).Address

-    End With

-    Get_SOFT_ID_Range_Address = s

-End Function

-

-

-

-<<<<<<
-======================
-Tools
->>>>>>
-Attribute VB_Name = "Tools"

-Option Explicit

-

-Function GetLinesCount(ByVal Location As Range) As Long

-    Dim n As Long

-    n = 0

-    Do While Location.Offset(n, 0) <> ""

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Sub hide_sheets()

-    Dim ws As Worksheet

-    Dim wsname As String

-    For Each ws In ThisWorkbook.Worksheets

-        wsname = ws.Name

-        ws.Protect UserInterfaceonly:=True

-        If Left(wsname, 1) = "x" Then

-            ws.EnableCalculation = False

-            ws.Visible = xlSheetVeryHidden

-        End If

-    Next ws

-End Sub

-

-Sub show_sheets()

-    Dim ws As Worksheet

-    Dim wsname As String

-    For Each ws In ThisWorkbook.Worksheets

-        ws.Unprotect

-        wsname = ws.Name

-        If Left(wsname, 1) = "x" Then

-            ws.EnableCalculation = True

-            ws.Visible = xlSheetVisible

-        End If

-    Next ws

-End Sub

-

-Sub check_sn_seria()

-    Dim r1 As Range

-    Dim r2 As Range

-    Dim i As Long

-    Dim j As Long

-    

-    Dim calc_type As Integer

-    calc_type = Application.Calculation

-    Application.Calculation = xlCalculationManual

-    

-    Set r1 = Worksheets("OEM_100").Range("B7")

-    Set r2 = Worksheets("OEM_100").Range("C7")

-        

-    i = GetLinesCount(r1)

-    j = GetLinesCount(r2)

-    

-    Dim as1() As String

-    Dim as2() As String

-    

-    ReDim as1(i)

-    ReDim as2(j)

-    

-    i = 1

-    While r1 <> ""

-        as1(i) = r1

-        as2(i) = r2

-        Set r1 = r1.Offset(1, 0)

-        Set r2 = r2.Offset(1, 0)

-        i = i + 1

-    Wend

-    

-    Set r1 = Worksheets("OEM_100").Range("E6")

-    Set r2 = Worksheets("OEM_100").Range("E7")

-    

-    r1.EntireColumn.ClearContents

-    r1.Offset(0, 1).EntireColumn.ClearContents

-    r1.Select

-    

-    For i = 1 To UBound(as1)

-        r1 = i

-        For j = 1 To UBound(as2)

-            If as1(i) = as2(j) Then

-                r2 = i

-                r2.Offset(0, 1) = j

-                r1.Offset(0, 1) = r1.Offset(0, 1) + 1

-            End If

-        Next j

-    Next i

-    If r2.Row = 7 Then

-        r2 = ";-)"

-    End If

-    Application.Calculation = calc_type

-    Application.Calculate

-End Sub

-

-

-<<<<<<
-======================
-Dec2Hex
->>>>>>
-Attribute VB_Name = "Dec2Hex"

-Option Explicit

-

-

-Const HexNumbers As String = "0123456789ABCDEF"

-Const HexBase As Integer = 16

-Const ThirtyNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRST"

-Const ThirtyBase As Integer = 30

-

-Function sDec2Hex(Dec As Long) As String

-    Dim HexStr As String

-    Dim idx As Integer

-    

-    HexStr = ""

-    

-    If Dec = 0 Then

-        HexStr = Mid(HexNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod HexBase

-            HexStr = Mid(HexNumbers, idx + 1, 1) + HexStr

-            Dec = Dec \ HexBase

-        Wend

-    End If

-    sDec2Hex = HexStr

-End Function

-

-Function Hex2Dec(HexString As String) As Long

-    Dim digit As Integer

-    Dim ch As String

-    Dim hexpower As Integer

-    Dim hexnum As String

-    Dim decnumber As Long

-    

-    hexnum = UCase(HexString)

-    hexpower = 0

-    decnumber = 0

-    

-    While hexnum <> ""

-        ch = Right(hexnum, 1)

-        hexnum = Left(hexnum, Len(hexnum) - 1)

-        digit = InStr(1, HexNumbers, ch, vbBinaryCompare)

-        decnumber = decnumber + digit ' power(hexbase, hexpower)

-        hexpower = hexpower + 1

-    Wend

-    Hex2Dec = decnumber

-End Function

-

-

-

-Function Dec2Thirty(Dec As Long) As String

-

-    

-    Dim ThirtyStr As String

-    Dim idx As Integer

-    

-    ThirtyStr = ""

-    

-    If Dec = 0 Then

-        ThirtyStr = Mid(ThirtyNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtyBase

-            ThirtyStr = Mid(ThirtyNumbers, idx + 1, 1) + ThirtyStr

-            Dec = Dec \ ThirtyBase

-        Wend

-    End If

-    Dec2Thirty = ThirtyStr

-End Function

-

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-OEM_Key
->>>>>>
-Attribute VB_Name = "OEM_Key"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    setup_interface

-End Sub

-

-Sub setup_interface()

-    Dim listsize As Integer

-    Dim r As Range

-    Dim NewCbxRange As String

-    Dim NewCbxSelection As String

-    

-    NewCbxRange = Get_OEM_Names_Range_Address

-    

-    NewCbxSelection = Worksheets(SHEET_OEM_DATA).Name & "!" & _

-                        Worksheets(SHEET_OEM_DATA).Range(RANGE_OEM_IDX).Address

-    Unprotect

-    ActiveSheet.Shapes("oemList").Select

-    With Selection

-        .ListFillRange = NewCbxRange

-        .LinkedCell = NewCbxSelection

-        .DropDownLines = 8

-        .Display3DShading = True

-    End With

-    

-    NewCbxRange = Get_SYS_Names_Range_Address

-    NewCbxSelection = Worksheets(SHEET_OEM_DATA).Name & "!" & _

-                        Worksheets(SHEET_OEM_DATA).Range(RANGE_SYS_IDX).Address

-                        

-    Worksheets(SHEET_OEM_KEY).Shapes("sysList").Select

-    With Selection

-        .ListFillRange = NewCbxRange

-        .LinkedCell = NewCbxSelection

-        .DropDownLines = 8

-        .Display3DShading = True

-    End With

-    Range("Version").Select

-    Protect UserInterfaceOnly:=True

-End Sub

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Dec2TS
->>>>>>
-Attribute VB_Name = "Dec2TS"

-Option Explicit

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Double

-    

-    ThirtySixStr = TS

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If ThirtySixStr = "" Then

-        Dec = 0

-    Else

-        While ThirtySixStr <> ""

-            lastdigit = Right(ThirtySixStr, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            ThirtySixStr = Mid(ThirtySixStr, 1, Len(ThirtySixStr) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-

-Function ThirtySix2ChkSum(TS As String) As Integer

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim Dec As Integer

-    

-    ThirtySixStr = TS

-

-    Dec = 0

-    

-    If ThirtySixStr = "" Then

-        Dec = 0

-    Else

-        While ThirtySixStr <> ""

-            lastdigit = Right(ThirtySixStr, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit) - 1

-            Dec = Dec + idx \ 10 + idx Mod 10

-            While Dec > 9

-                Dec = Dec \ 10 + Dec Mod 10

-            Wend

-            ThirtySixStr = Left(ThirtySixStr, Len(ThirtySixStr) - 1)

-        Wend

-    End If

-

-    ThirtySix2ChkSum = Dec

-End Function

-<<<<<<
-======================
-Dec2Hex
->>>>>>
-Attribute VB_Name = "Dec2Hex"

-Option Explicit

-

-

-Const HexNumbers As String = "0123456789ABCDEF"

-Const HexBase As Integer = 16

-Const ThirtyNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRST"

-Const ThirtyBase As Integer = 30

-

-Function sDec2Hex(Dec As Long) As String

-    Dim HexStr As String

-    Dim idx As Integer

-    

-    HexStr = ""

-    

-    If Dec = 0 Then

-        HexStr = Mid(HexNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod HexBase

-            HexStr = Mid(HexNumbers, idx + 1, 1) + HexStr

-            Dec = Dec \ HexBase

-        Wend

-    End If

-    sDec2Hex = HexStr

-End Function

-

-Function Hex2Dec(HexString As String) As Long

-    Dim digit As Integer

-    Dim ch As String

-    Dim hexpower As Integer

-    Dim hexnum As String

-    Dim decnumber As Long

-    

-    hexnum = UCase(HexString)

-    hexpower = 0

-    decnumber = 0

-    

-    While hexnum <> ""

-        ch = Right(hexnum, 1)

-        hexnum = Left(hexnum, Len(hexnum) - 1)

-        digit = InStr(1, HexNumbers, ch, vbBinaryCompare)

-        decnumber = decnumber + digit ' power(hexbase, hexpower)

-        hexpower = hexpower + 1

-    Wend

-    Hex2Dec = decnumber

-End Function

-

-

-

-Function Dec2Thirty(Dec As Long) As String

-

-    

-    Dim ThirtyStr As String

-    Dim idx As Integer

-    

-    ThirtyStr = ""

-    

-    If Dec = 0 Then

-        ThirtyStr = Mid(ThirtyNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtyBase

-            ThirtyStr = Mid(ThirtyNumbers, idx + 1, 1) + ThirtyStr

-            Dec = Dec \ ThirtyBase

-        Wend

-    End If

-    Dec2Thirty = ThirtyStr

-End Function

-

-<<<<<<
-======================
-Serial
->>>>>>
-Attribute VB_Name = "Serial"

-Option Explicit

-

-Function gen_serial() As Long

-    gen_serial = 10000 + Int(Rnd() * 9999) + 1

-End Function

-

-Function gen_root() As Long

-    gen_root = (Rnd() * 8) + 1

-End Function

-

-Function gen_ts_end() As Long

-    gen_ts_end = (Rnd() * 34) + 1

-End Function

-

-Function sn_is_valid_date(dt As String) As Boolean

-    Dim m As Integer

-    Dim d As Integer

-    

-    m = Mid(dt, 2, 2)

-    d = Right(dt, 2)

-    

-    sn_is_valid_date = m < 13 And d < 32

-End Function

-

-Function sn_is_valid_oem(id As Integer) As Boolean

-    Dim r As Range

-    Dim c As Range

-    Dim b As Boolean

-    

-    Set r = Range(Get_OEM_ID_Range_Address)

-    

-    sn_is_valid_oem = False

-    

-    For Each c In r

-        If c = id Then

-            sn_is_valid_oem = True

-            Exit Function

-        End If

-    Next c

-End Function

-

-Function sn_is_valid_sys(id As Integer) As Boolean

-    Dim r As Range

-    Dim c As Range

-    Dim b As Boolean

-    

-    Set r = Range(Get_SYS_ID_Range_Address)

-    

-    sn_is_valid_sys = False

-    

-    For Each c In r

-        If c = id Then

-            sn_is_valid_sys = True

-            Exit Function

-        End If

-    Next c

-End Function

-

-Function sn_check(sn As String) As Boolean

-    Dim s As String

-    Dim chksum As Integer

-    Dim r As Range

-    

-    chksum = Right(sn, 1)

-    s = Left(sn, Len(sn) - 1)

-    

-    Dim cs As Integer

-    cs = ThirtySix2ChkSum(s)

-    

-    sn_check = chksum = cs _

-                And sn_is_valid_date(sn_get_date(sn)) _

-                And sn_is_valid_oem(sn_get_oem_id(sn)) _

-                And sn_is_valid_sys(sn_get_sys_id(sn))

-End Function

-

-Function sn_prefix(sn As String) As String

-    sn_prefix = Left(sn, 3)

-End Function

-

-Function sn_number(sn As String) As String

-    Dim g As Integer

-    Dim g1 As Integer

-    Dim g2 As Integer

-    Dim g3 As Integer

-    g = sn_group(sn)

-    g1 = g \ 100

-    g2 = (g Mod 100) \ 10

-    g3 = g Mod 10

-    Dim s As String

-    s = sn_prefix(sn)

-    s = Mid(sn, Len(s) + 1, g1 + g2 + g3)

-    sn_number = s

-End Function

-

-Function sn_group_one(sn As String) As String

-    Dim s As String

-    Dim r As Integer

-    Dim g As Integer

-    Dim g1 As Integer

-    Dim g2 As Integer

-    Dim g3 As Integer

-    g = sn_group(sn)

-    g1 = g \ 100

-    g2 = (g Mod 100) \ 10

-    g3 = g Mod 10

-    r = sn_root(sn)

-    g = sn_group(sn)

-    s = ROT_Right(sn_number(sn), r)

-    sn_group_one = ThirtySix2Dec(Left(s, g1))

-End Function

-

-Function sn_group_two(sn As String) As String

-    Dim s As String

-    Dim g As Integer

-    Dim r As Integer

-    r = sn_root(sn)

-    s = ROT_Right(sn_number(sn), r)

-    g = sn_group(sn)

-    Dim g1 As Integer

-    Dim g2 As Integer

-    Dim g3 As Integer

-    g1 = g \ 100

-    g2 = (g Mod 100) \ 10

-    g3 = g Mod 10

-    sn_group_two = ThirtySix2Dec(Mid(s, g1 + 1, g2))

-End Function

-

-Function sn_group_three(sn As String) As String

-    Dim s As String

-    Dim g As Integer

-    Dim r As Integer

-    r = sn_root(sn)

-    s = ROT_Right(sn_number(sn), r)

-    g = sn_group(sn)

-    Dim g1 As Integer

-    Dim g2 As Integer

-    Dim g3 As Integer

-    g1 = g \ 100

-    g2 = (g Mod 100) \ 10

-    g3 = g Mod 10

-    sn_group_three = ThirtySix2Dec(Mid(s, g1 + g2 + 1, g3))

-End Function

-

-Function sn_get_sys_id(sn As String) As String

-    Dim s As String

-    Dim d As Long

-    s = sn_group_two(sn)

-    sn_get_sys_id = Right(s, 3)

-End Function

-

-Function sn_get_sys_name(sn As String) As String

-    Dim sys_id As Integer

-    Dim r As Range

-    Dim c As Range

-    Dim s As String

-    sys_id = sn_get_sys_id(sn)

-    s = Get_SYS_ID_Range_Address

-    Set r = Range(s)

-    s = ""

-    

-    For Each c In r

-        If c = sys_id Then

-            s = c.Offset(0, 1)

-            Exit For

-        End If

-    Next c

-    sn_get_sys_name = s

-End Function

-

-Function sn_get_oem_id(sn As String) As String

-    Dim s As String

-    s = sn_group_one(sn)

-    sn_get_oem_id = Left(s, 3)

-End Function

-

-Function sn_get_oem_name(sn As String) As String

-    Dim oem_id As Integer

-    Dim r As Range

-    Dim c As Range

-    Dim s As String

-    oem_id = sn_get_oem_id(sn)

-    s = Get_OEM_ID_Range_Address

-    Set r = Range(s)

-    s = ""

-    

-    For Each c In r

-        If c = oem_id Then

-            s = c.Offset(0, 1)

-            Exit For

-        End If

-    Next c

-    sn_get_oem_name = s

-End Function

-

-Function sn_get_date(sn As String) As String

-    Dim s As String

-    s = sn_group_one(sn)

-    s = Right(s, Len(s) - 3)

-    sn_get_date = s

-End Function

-

-Function sn_get_ver(sn As String) As String

-    Dim s As String

-    s = sn_group_three(sn)

-    s = Left(s, 3)

-    sn_get_ver = s

-End Function

-

-Function sn_get_seria(sn As String) As String

-    Dim s As String

-    s = sn_group_three(sn)

-    s = Right(s, Len(s) - 3)

-    sn_get_seria = s

-End Function

-

-Function sn_root(sn As String) As Integer

-    sn_root = Left(ThirtySix2Dec(sn_prefix(sn)), 1)

-End Function

-

-Function sn_group(sn As String) As Integer

-    Dim s As String

-    s = ThirtySix2Dec(sn_prefix(sn))

-    sn_group = Right(s, Len(s) - 1)

-End Function

-

-Function Rotate_Left(r As Range, position As Integer) As String

-    Dim r_str As String

-    r_str = r

-    Rotate_Left = ROT_Left(r_str, position)

-End Function

-

-Function ROT_Left(s As String, position As Integer) As String

-    Dim i As Integer

-    Dim slen As Integer

-    

-    Dim r_str As String

-    Dim ch As String

-    

-    r_str = s

-    

-    slen = Len(r_str)

-    For i = 1 To position

-        ch = Left(r_str, 1)

-        r_str = Right(r_str, slen - 1)

-        r_str = r_str + ch

-    Next i

-    

-    ROT_Left = r_str

-End Function

-

-Function Rotate_Right(r As Range, position As Integer) As String

-    Dim r_str As String

-    r_str = r

-    Rotate_Right = ROT_Right(r_str, position)

-End Function

-

-Function ROT_Right(s As String, position As Integer) As String

-    Dim i As Integer

-    Dim slen As Integer

-    

-    Dim r_str As String

-    Dim ch As String

-    

-    r_str = s

-    

-    slen = Len(r_str)

-    For i = 1 To position

-        ch = Right(r_str, 1)

-        r_str = Left(r_str, slen - 1)

-        r_str = ch + r_str

-    Next i

-    

-    ROT_Right = r_str

-End Function

-

-

-<<<<<<
-======================
-OEM_DATA
->>>>>>
-Attribute VB_Name = "OEM_DATA"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-newOEMdlg
->>>>>>
-Attribute VB_Name = "newOEMdlg"

-Attribute VB_Base = "0{39393DC9-744B-4C17-88BD-5C508F5FD702}{EAA9566B-3F9C-455E-908D-B3794AD3044C}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub AddOEM_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub resetOEM_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-<<<<<<
-======================
-interface
->>>>>>
-Attribute VB_Name = "interface"

-Option Explicit

-

-Public Const SHEET_OEM_DATA As String = "OEM_DATA"

-Public Const SHEET_OEM_KEY As String = "OEM_Key"

-

-Public Const RANGE_OEM_IDX As String = "OEM_IDX"

-Public Const RANGE_OEM_ID As String = "OEM_ID"

-Public Const RANGE_OEM_NAME As String = "OEM_NAME"

-

-Public Const RANGE_SYS_IDX As String = "SYS_IDX"

-Public Const RANGE_SYS_ID As String = "SYS_ID"

-Public Const RANGE_SYS_NAME As String = "SYS_NAME"

-

-Sub export()

-    Dim fs As Object

-    Dim a As Object

-    Dim fpath As String

-    Dim fname As String

-    Dim r As Range

-    

-    fpath = GetWBPath(ThisWorkbook.FullName)

-    fname = GetExFileName()

-    If fname = "" Then

-        MsgBox ("=8-(")

-        Exit Sub

-    End If

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    fname = fpath & fname & ".txt"

-    Set a = fs.CreateTextFile(fname, True)

-    

-    Set r = Range(GetLastRange).Offset(4, 0)

-    While r <> ""

-        a.WriteLine (r)

-        Set r = r.Offset(1, 0)

-    Wend

-    a.Close

-    MsgBox ("saved in:" & fname & " ;-)")

-End Sub

-

-Function GetLastRange() As String

-    Dim r As Range

-    Set r = ActiveSheet.Range("A1")

-    While r.Offset(0, 1) <> ""

-        Set r = r.Offset(0, 1)

-    Wend

-    GetLastRange = r.Address

-End Function

-

-Function GetExFileName() As String

-    Dim s As String

-    Dim r As Range

-    s = ""

-    Set r = Range(GetLastRange)

-    If r <> ActiveSheet.Range("A1") Then

-        s = r & "_" _

-            & r.Offset(1, 0) & "_" _

-            & r.Offset(2, 0) & "_" _

-            & r.Offset(3, 0) & "_" _

-            & r.Offset(4, 0)

-    End If

-    GetExFileName = s

-End Function

-

-Function get_oem_sheet_name() As String

-    Dim oem_id As Integer

-    With Worksheets(SHEET_OEM_DATA)

-        oem_id = .Range(RANGE_OEM_IDX)

-        oem_id = .Range(RANGE_OEM_ID).Offset(oem_id - 1, 0)

-    End With

-    get_oem_sheet_name = "OEM_" & oem_id

-End Function

-

-Sub gotooem()

-    With Worksheets(get_oem_sheet_name)

-        .Select

-        .Range("A1").Select

-        .Protect UserInterfaceOnly:=True

-    End With

-End Sub

-

-Sub home()

-    Worksheets(SHEET_OEM_KEY).Select

-End Sub

-

-Sub oemAdd_Click()

-    Dim dlg As newOEMdlg

-    Set dlg = New newOEMdlg

-    

-    dlg.Show

-

-    If dlg.Tag = vbOK Then

-        Dim s As String

-        s = dlg.edOEM_Name

-        AddNewOEM (s)

-        MsgBox ":)"

-    End If

-End Sub

-

-Sub sysAdd_Click()

-    Dim dlg As newSYSdlg

-    Set dlg = New newSYSdlg

-    

-    dlg.Show

-

-    If dlg.Tag = vbOK Then

-        Dim s As String

-        s = dlg.edSYS_Name

-        AddNewSYS (s)

-        MsgBox ":)"

-    End If

-End Sub

-

-Sub AddNewOEM(s As String)

-    Dim r_oem_id As Range

-    Dim r_oem_name As Range

-    Dim r As Range

-    Dim idx As Integer

-    Dim id As Integer

-    

-    With Worksheets(SHEET_OEM_DATA)

-        Set r_oem_id = .Range(RANGE_OEM_ID)

-        Set r_oem_name = .Range(RANGE_OEM_NAME)

-        idx = GetLinesCount(r_oem_id)

-        id = r_oem_id.Offset(idx - 1, 0)

-        r_oem_id.Offset(idx, 0) = id + 1

-        r_oem_name.Offset(idx, 0) = s

-    End With

-    With Sheets.Add

-        .Name = "OEM_" & r_oem_id.Offset(idx, 0)

-        With .Buttons.Add(3, 69.75, 39, 16)

-            .OnAction = "home"

-            .Characters.Text = "home"

-            .Name = "btHome"

-        End With

-        With .Buttons.Add(3, 87.75, 39, 16)

-            .OnAction = "export"

-            .Characters.Text = "export"

-            .Name = "btSave"

-        End With

-        .Range("A1") = "OEM"

-        .Range("A2") = "DATE"

-        .Range("A3") = "VER"

-        .Range("A4") = "SYS"

-        .Range("A5") = "SERIA"

-        With Cells.Font

-            .Name = "Courier"

-            .Size = 10

-        End With

-        .Protect UserInterfaceOnly:=True

-    End With

-    Worksheets(SHEET_OEM_KEY).Select

-    Worksheets(SHEET_OEM_KEY).setup_interface

-End Sub

-

-Sub AddNewSYS(s As String)

-    Dim r_sys_id As Range

-    Dim r_sys_name As Range

-    Dim r As Range

-    Dim idx As Integer

-    Dim id As Integer

-    

-    With Worksheets(SHEET_OEM_DATA)

-        Set r_sys_id = .Range(RANGE_SYS_ID)

-        Set r_sys_name = .Range(RANGE_SYS_NAME)

-        idx = GetLinesCount(r_sys_id)

-        id = r_sys_id.Offset(idx - 1, 0)

-        r_sys_id.Offset(idx, 0) = id + 1

-        r_sys_name.Offset(idx, 0) = s

-    End With

-    Worksheets(SHEET_OEM_KEY).setup_interface

-End Sub

-

-Function Get_OEM_Names_Range_Address() As String

-    Dim r As Range

-    Dim s As String

-

-    With Worksheets(SHEET_OEM_DATA)

-        Set r = .Range(RANGE_OEM_ID)

-        s = .Name & "!" & _

-            .Range(.Range(RANGE_OEM_NAME), _

-            .Range(RANGE_OEM_NAME).Offset(GetLinesCount(r) - 1, 0)).Address

-

-    End With

-    Get_OEM_Names_Range_Address = s

-End Function

-

-Function Get_SYS_Names_Range_Address() As String

-    Dim r As Range

-    Dim s As String

-

-    With Worksheets(SHEET_OEM_DATA)

-        Set r = .Range(RANGE_SYS_ID)

-    

-        s = .Name & "!" & _

-            .Range(.Range(RANGE_SYS_NAME), _

-            .Range(RANGE_SYS_NAME).Offset(GetLinesCount(r) - 1, 0)).Address

-    End With

-    Get_SYS_Names_Range_Address = s

-End Function

-

-Function Get_OEM_ID_Range_Address() As String

-    Dim r As Range

-    Dim s As String

-

-    With Worksheets(SHEET_OEM_DATA)

-        Set r = .Range(RANGE_OEM_ID)

-        s = .Name & "!" & _

-            .Range(.Range(RANGE_OEM_ID), _

-            .Range(RANGE_OEM_ID).Offset(GetLinesCount(r) - 1, 0)).Address

-

-    End With

-    Get_OEM_ID_Range_Address = s

-End Function

-

-Function Get_SYS_ID_Range_Address() As String

-    Dim r As Range

-    Dim s As String

-

-    With Worksheets(SHEET_OEM_DATA)

-        Set r = .Range(RANGE_SYS_ID)

-    

-        s = .Name & "!" & _

-            .Range(.Range(RANGE_SYS_ID), _

-            .Range(RANGE_SYS_ID).Offset(GetLinesCount(r) - 1, 0)).Address

-    End With

-    Get_SYS_ID_Range_Address = s

-End Function

-

-<<<<<<
-======================
-Tools
->>>>>>
-Attribute VB_Name = "Tools"

-Option Explicit

-

-Function GetLinesCount(ByVal Location As Range) As Long

-    Dim n As Long

-    n = 0

-    Do While Location.Offset(n, 0) <> ""

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Sub check_sn_seria()

-    Dim r1 As Range

-    Dim r2 As Range

-    Dim i As Long

-    Dim j As Long

-    

-    Dim calc_type As Integer

-    calc_type = Application.Calculation

-    Application.Calculation = xlCalculationManual

-    

-    Set r1 = Worksheets("OEM_100").Range("B6")

-    Set r2 = Worksheets("OEM_100").Range("C6")

-        

-    i = GetLinesCount(r1)

-    j = GetLinesCount(r2)

-    

-    Dim as1() As String

-    Dim as2() As String

-    

-    ReDim as1(i)

-    ReDim as2(j)

-    

-    i = 1

-    While r1 <> ""

-        as1(i) = r1

-        as2(i) = r2

-        Set r1 = r1.Offset(1, 0)

-        Set r2 = r2.Offset(1, 0)

-        i = i + 1

-    Wend

-    

-    

-    Set r1 = Worksheets("OEM_100").Range("E5")

-    Set r2 = Worksheets("OEM_100").Range("E6")

-    

-    r1.EntireColumn.ClearContents

-    r1.Offset(0, 1).EntireColumn.ClearContents

-    r1.Select

-    

-    For i = 1 To UBound(as1)

-        r1 = i

-        For j = 1 To UBound(as2)

-            If as1(i) = as2(j) Then

-                r2 = i

-                r2.Offset(0, 1) = j

-                r1.Offset(0, 1) = r1.Offset(0, 1) + 1

-                Set r2 = r2.Offset(1, 0)

-            End If

-        Next j

-    Next i

-    If r2.Row = 6 Then

-        r2 = ";-)"

-    End If

-    Application.Calculation = calc_type

-    Application.Calculate

-End Sub

-

-<<<<<<
-======================
-Generator
->>>>>>
-Attribute VB_Name = "Generator"

-Option Explicit

-

-Sub snCreate_Click()

-    Dim d_date As Long

-    Dim seria As Long

-    Dim version As Integer

-    Dim oem_id As Integer

-    Dim sys_id As Integer

-    Dim i As Long

-    Dim r As Range

-    

-    With Worksheets(SHEET_OEM_KEY)

-        version = .Range("Version")

-        seria = .Range("Seria")

-    End With

-

-    With Worksheets(SHEET_OEM_DATA)

-        oem_id = .Range(RANGE_OEM_IDX)

-        oem_id = .Range(RANGE_OEM_ID).Offset(oem_id - 1, 0)

-        sys_id = .Range(RANGE_SYS_IDX)

-        sys_id = .Range(RANGE_SYS_ID).Offset(sys_id - 1, 0)

-    End With

-    

-    d_date = (Year(Now()) Mod 10)

-    d_date = d_date * 10000

-    d_date = d_date + Month(Now()) * 100

-    d_date = d_date + Day(Now())

-    

-    Dim calc_type As Integer

-    calc_type = Application.Calculation

-    Application.Calculation = xlCalculationManual

-    

-    Dim oem_wks As String

-    oem_wks = get_oem_sheet_name

-    Set r = Worksheets(oem_wks).Range("A1")

-    While r <> ""

-        Set r = r.Offset(0, 1)

-    Wend

-    

-    r.Offset(0, 0) = oem_id

-    r.Offset(1, 0) = d_date

-    r.Offset(2, 0) = version

-    r.Offset(3, 0) = sys_id

-    r.Offset(4, 0) = seria

-    

-    Randomize

-    

-    For i = 1 To seria

-        r.Offset(4 + i) = SN_Generate(d_date, oem_id, sys_id, version, seria)

-    Next i

-    r.EntireColumn.AutoFit

-    r.Worksheet.Select

-    r.Select

-    

-    Application.Calculation = calc_type

-    Application.Calculate

-End Sub

-

-Function SN_Generate(d_date As Long, oem_id As Integer, sys_id As Integer, version As Integer, seria As Long) As String

-    Dim sn_number As Long

-    Dim s_one As String

-    Dim s_two As String

-    Dim s_three As String

-    Dim s_sn As String

-    Dim s_idx As String

-    Dim sn_root As Integer

-    Dim sn_chk As Integer

-    

-    sn_number = gen_serial

-    sn_root = gen_root

-    

-    s_one = oem_id & d_date

-    s_two = sn_number & sys_id

-    s_three = version & seria

-    

-    s_one = Dec2ThirtySix(Format(s_one, "#"))

-    s_two = Dec2ThirtySix(Format(s_two, "#"))

-    s_three = Dec2ThirtySix(Format(s_three, "#"))

-    

-    s_sn = s_one & s_two & s_three

-    

-    s_sn = ROT_Left(s_sn, sn_root)

-    

-    s_idx = sn_root & Len(s_one) & Len(s_two) & Len(s_three)

-    

-    s_idx = Dec2ThirtySix(Format(s_idx, "#"))

-    

-    s_sn = s_idx & s_sn

-    

-    While Len(s_sn) < 19

-        Dim s As String

-        s = Dec2ThirtySix(gen_ts_end)

-        s_sn = s_sn & s

-    Wend

-    

-    sn_chk = ThirtySix2ChkSum(s_sn)

-    

-    s_sn = s_sn & sn_chk

-    

-    SN_Generate = Left(s_sn, 5) _

-            & " " & Mid(s_sn, 6, 5) _

-            & " " & Mid(s_sn, 11, 5) _

-            & " " & Right(s_sn, Len(s_sn) - 15)

-End Function

-<<<<<<
-======================
-newSYSdlg
->>>>>>
-Attribute VB_Name = "newSYSdlg"

-Attribute VB_Base = "0{059C105D-BD13-41AB-9A28-A61478F592F8}{830FC1D2-6497-4B79-BC07-D219C00B138A}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub AddSYS_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub resetSYS_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-L112
->>>>>>
-Attribute VB_Name = "L112"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-templ
->>>>>>
-Attribute VB_Name = "templ"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LabPrn
->>>>>>
-Attribute VB_Name = "LabPrn"

-Option Explicit

-

-Sub printLab()

-    On Error GoTo handleCancel

-    Application.EnableCancelKey = xlErrorHandler

-    Dim x As Integer

-    Dim x_stop As Integer

-    Dim SerIdx As Range

-    Dim SerLen As Range

-    Dim PrintSeria As Range

-    Dim PrintIdx As Range

-    Dim NextGen As Range

-    Dim snlist As Range

-        

-    With ThisWorkbook.Worksheets("SERIA")

-        Set SerIdx = .Range("SeriaIdx")

-        Set SerLen = .Range("SeriaLen")

-        Set snlist = .Range("SeriaList")

-    End With

-    With ThisWorkbook.Worksheets("templ")

-        Set PrintSeria = .Range("PrintSeria")

-        Set PrintIdx = .Range("PrintIdx")

-        Set NextGen = .Range("NextGen")

-    End With

-    

-    x_stop = SerIdx + NextGen

-    For x = SerIdx To x_stop

-        PrintSeria = snlist.Item(x, 1)

-        PrintIdx = x

-        SerIdx = x + 1

-        ThisWorkbook.Worksheets("templ").PrintOut Copies:=1, Collate:=True

-    Next x

-

-handleCancel:

-    If Err = 18 Then

-    End If

-    

-    ThisWorkbook.Save

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Const bak As String = "backup"

-

-Private Sub Workbook_Open()

-    Dim n As String

-    Dim e As String

-    Dim d As String

-    n = ThisWorkbook.FullName

-    e = Right(n, 4)

-    n = Left(n, Len(n) - 4)

-    Dim nt As String

-    nt = Right(n, Len(bak))

-    If nt <> bak Then

-        d = Date$

-        n = n + "_" + d + "_" + bak + e

-        ThisWorkbook.SaveCopyAs n

-    End If

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet19
->>>>>>
-Attribute VB_Name = "Sheet19"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet22
->>>>>>
-Attribute VB_Name = "Sheet22"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet23
->>>>>>
-Attribute VB_Name = "Sheet23"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet24
->>>>>>
-Attribute VB_Name = "Sheet24"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet25
->>>>>>
-Attribute VB_Name = "Sheet25"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Const bak As String = "backup"

-

-Private Sub Workbook_Open()

-    Dim n As String

-    Dim e As String

-    Dim d As String

-    n = ThisWorkbook.FullName

-    e = Right(n, 4)

-    n = Left(n, Len(n) - 4)

-    Dim nt As String

-    nt = Right(n, Len(bak))

-    If nt <> bak Then

-        d = Date$

-        n = n + "_" + d + "_" + bak + e

-        ThisWorkbook.SaveCopyAs n

-    End If

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet19
->>>>>>
-Attribute VB_Name = "Sheet19"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet22
->>>>>>
-Attribute VB_Name = "Sheet22"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet23
->>>>>>
-Attribute VB_Name = "Sheet23"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet24
->>>>>>
-Attribute VB_Name = "Sheet24"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet25
->>>>>>
-Attribute VB_Name = "Sheet25"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Const bak As String = "backup"

-

-Private Sub Workbook_Open()

-    Dim n As String

-    Dim e As String

-    Dim d As String

-    n = ThisWorkbook.FullName

-    e = Right(n, 4)

-    n = Left(n, Len(n) - 4)

-    Dim nt As String

-    nt = Right(n, Len(bak))

-    If nt <> bak Then

-        d = Date$

-        n = n + "_" + d + "_" + bak + e

-        ThisWorkbook.SaveCopyAs n

-    End If

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet19
->>>>>>
-Attribute VB_Name = "Sheet19"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet22
->>>>>>
-Attribute VB_Name = "Sheet22"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet23
->>>>>>
-Attribute VB_Name = "Sheet23"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet24
->>>>>>
-Attribute VB_Name = "Sheet24"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet25
->>>>>>
-Attribute VB_Name = "Sheet25"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Const bak As String = "backup"

-

-Private Sub Workbook_Open()

-    Dim n As String

-    Dim e As String

-    Dim d As String

-    n = ThisWorkbook.FullName

-    e = Right(n, 4)

-    n = Left(n, Len(n) - 4)

-    Dim nt As String

-    nt = Right(n, Len(bak))

-    If nt <> bak Then

-        d = Date$

-        n = n + "_" + d + "_" + bak + e

-        ThisWorkbook.SaveCopyAs n

-    End If

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet19
->>>>>>
-Attribute VB_Name = "Sheet19"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet22
->>>>>>
-Attribute VB_Name = "Sheet22"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet23
->>>>>>
-Attribute VB_Name = "Sheet23"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet24
->>>>>>
-Attribute VB_Name = "Sheet24"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet25
->>>>>>
-Attribute VB_Name = "Sheet25"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Const bak As String = "backup"

-

-Private Sub Workbook_Open()

-    Dim n As String

-    Dim e As String

-    Dim d As String

-    n = ThisWorkbook.FullName

-    e = Right(n, 4)

-    n = Left(n, Len(n) - 4)

-    Dim nt As String

-    nt = Right(n, Len(bak))

-    If nt <> bak Then

-        d = Date$

-        n = n + "_" + d + "_" + bak + e

-        ThisWorkbook.SaveCopyAs n

-    End If

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet19
->>>>>>
-Attribute VB_Name = "Sheet19"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet22
->>>>>>
-Attribute VB_Name = "Sheet22"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet23
->>>>>>
-Attribute VB_Name = "Sheet23"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet24
->>>>>>
-Attribute VB_Name = "Sheet24"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet25
->>>>>>
-Attribute VB_Name = "Sheet25"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Const bak As String = "backup"

-

-Private Sub Workbook_Open()

-    Dim n As String

-    Dim e As String

-    Dim d As String

-    n = ThisWorkbook.FullName

-    e = Right(n, 4)

-    n = Left(n, Len(n) - 4)

-    Dim nt As String

-    nt = Right(n, Len(bak))

-    If nt <> bak Then

-        d = Date$

-        n = n + "_" + d + "_" + bak + e

-        ThisWorkbook.SaveCopyAs n

-    End If

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet19
->>>>>>
-Attribute VB_Name = "Sheet19"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet22
->>>>>>
-Attribute VB_Name = "Sheet22"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet23
->>>>>>
-Attribute VB_Name = "Sheet23"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet24
->>>>>>
-Attribute VB_Name = "Sheet24"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet25
->>>>>>
-Attribute VB_Name = "Sheet25"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet19
->>>>>>
-Attribute VB_Name = "Sheet19"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet22
->>>>>>
-Attribute VB_Name = "Sheet22"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet23
->>>>>>
-Attribute VB_Name = "Sheet23"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet24
->>>>>>
-Attribute VB_Name = "Sheet24"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet25
->>>>>>
-Attribute VB_Name = "Sheet25"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Unprotect "password"

-    ThisWorkbook.Save

-End Sub

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Protect password:="password"

-    Worksheets("Calc").Protect password:="password", userInterfaceonly:=True

-    Worksheets("Calc").Select

-    Worksheets("Calc").Range("A7").Select

-End Sub

-<<<<<<
-======================
-Calc
->>>>>>
-Attribute VB_Name = "Calc"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Sub SelectAll()

-    Dim Sh As Shape

-    For Each Sh In Shapes

-        If InStr(1, Sh.Name, "Check") Then

-            Sh.Select

-            Selection.Value = xlOn

-        End If

-    Next Sh

-    Range("A7").Select

-End Sub

-

-Sub ClearAll()

-    Dim Sh As Shape

-    For Each Sh In Shapes

-        If InStr(1, Sh.Name, "Check") Then

-            Sh.Select

-            Selection.Value = xlOff

-        End If

-    Next Sh

-    Range("A7").Select

-    Worksheets("Data").Range("K2") = 1

-    Worksheets("Calc").Range("E58") = 1

-End Sub

-

-<<<<<<
-======================
-Data
->>>>>>
-Attribute VB_Name = "Data"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Const bak As String = "backup"

-

-Private Sub Workbook_Open()

-    Dim n As String

-    Dim e As String

-    Dim d As String

-    n = ThisWorkbook.FullName

-    e = Right(n, 4)

-    n = Left(n, Len(n) - 4)

-    Dim nt As String

-    nt = Right(n, Len(bak))

-    If nt <> bak Then

-        d = Date$

-        n = n + "_" + d + "_" + bak + e

-        ThisWorkbook.SaveCopyAs n

-    End If

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet19
->>>>>>
-Attribute VB_Name = "Sheet19"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet22
->>>>>>
-Attribute VB_Name = "Sheet22"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet23
->>>>>>
-Attribute VB_Name = "Sheet23"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet24
->>>>>>
-Attribute VB_Name = "Sheet24"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet25
->>>>>>
-Attribute VB_Name = "Sheet25"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Const bak As String = "backup"

-

-Private Sub Workbook_Open()

-    Dim n As String

-    Dim e As String

-    Dim d As String

-    n = ThisWorkbook.FullName

-    e = Right(n, 4)

-    n = Left(n, Len(n) - 4)

-    Dim nt As String

-    nt = Right(n, Len(bak))

-    If nt <> bak Then

-        d = Date$

-        n = n + "_" + d + "_" + bak + e

-        ThisWorkbook.SaveCopyAs n

-    End If

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet19
->>>>>>
-Attribute VB_Name = "Sheet19"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet22
->>>>>>
-Attribute VB_Name = "Sheet22"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet23
->>>>>>
-Attribute VB_Name = "Sheet23"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet24
->>>>>>
-Attribute VB_Name = "Sheet24"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet25
->>>>>>
-Attribute VB_Name = "Sheet25"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Const bak As String = "backup"

-

-Private Sub Workbook_Open()

-    Dim n As String

-    Dim e As String

-    Dim d As String

-    n = ThisWorkbook.FullName

-    e = Right(n, 4)

-    n = Left(n, Len(n) - 4)

-    Dim nt As String

-    nt = Right(n, Len(bak))

-    If nt <> bak Then

-        d = Date$

-        n = n + "_" + d + "_" + bak + e

-        ThisWorkbook.SaveCopyAs n

-    End If

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet19
->>>>>>
-Attribute VB_Name = "Sheet19"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet22
->>>>>>
-Attribute VB_Name = "Sheet22"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet23
->>>>>>
-Attribute VB_Name = "Sheet23"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet24
->>>>>>
-Attribute VB_Name = "Sheet24"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet25
->>>>>>
-Attribute VB_Name = "Sheet25"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Const bak As String = "backup"

-

-Private Sub Workbook_Open()

-    Dim n As String

-    Dim e As String

-    Dim d As String

-    n = ThisWorkbook.FullName

-    e = Right(n, 4)

-    n = Left(n, Len(n) - 4)

-    Dim nt As String

-    nt = Right(n, Len(bak))

-    If nt <> bak Then

-        d = Date$

-        n = n + "_" + d + "_" + bak + e

-        ThisWorkbook.SaveCopyAs n

-    End If

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet19
->>>>>>
-Attribute VB_Name = "Sheet19"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet22
->>>>>>
-Attribute VB_Name = "Sheet22"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet23
->>>>>>
-Attribute VB_Name = "Sheet23"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet24
->>>>>>
-Attribute VB_Name = "Sheet24"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet25
->>>>>>
-Attribute VB_Name = "Sheet25"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Const bak As String = "backup"

-

-Private Sub Workbook_Open()

-    Dim n As String

-    Dim e As String

-    Dim d As String

-    n = ThisWorkbook.FullName

-    e = Right(n, 4)

-    n = Left(n, Len(n) - 4)

-    Dim nt As String

-    nt = Right(n, Len(bak))

-    If nt <> bak Then

-        d = Date$

-        n = n + "_" + d + "_" + bak + e

-        ThisWorkbook.SaveCopyAs n

-    End If

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet19
->>>>>>
-Attribute VB_Name = "Sheet19"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet22
->>>>>>
-Attribute VB_Name = "Sheet22"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet23
->>>>>>
-Attribute VB_Name = "Sheet23"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet24
->>>>>>
-Attribute VB_Name = "Sheet24"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet25
->>>>>>
-Attribute VB_Name = "Sheet25"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Const bak As String = "backup"

-

-Private Sub Workbook_Open()

-    Dim n As String

-    Dim e As String

-    Dim d As String

-    n = ThisWorkbook.FullName

-    e = Right(n, 4)

-    n = Left(n, Len(n) - 4)

-    Dim nt As String

-    nt = Right(n, Len(bak))

-    If nt <> bak Then

-        d = Date$

-        n = n + "_" + d + "_" + bak + e

-        ThisWorkbook.SaveCopyAs n

-    End If

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet19
->>>>>>
-Attribute VB_Name = "Sheet19"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet22
->>>>>>
-Attribute VB_Name = "Sheet22"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet23
->>>>>>
-Attribute VB_Name = "Sheet23"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet24
->>>>>>
-Attribute VB_Name = "Sheet24"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet25
->>>>>>
-Attribute VB_Name = "Sheet25"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Const bak As String = "backup"

-

-Private Sub Workbook_Open()

-    Dim n As String

-    Dim e As String

-    Dim d As String

-    n = ThisWorkbook.FullName

-    e = Right(n, 4)

-    n = Left(n, Len(n) - 4)

-    Dim nt As String

-    nt = Right(n, Len(bak))

-    If nt <> bak Then

-        d = Date$

-        n = n + "_" + d + "_" + bak + e

-        ThisWorkbook.SaveCopyAs n

-    End If

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet19
->>>>>>
-Attribute VB_Name = "Sheet19"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet22
->>>>>>
-Attribute VB_Name = "Sheet22"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet23
->>>>>>
-Attribute VB_Name = "Sheet23"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet24
->>>>>>
-Attribute VB_Name = "Sheet24"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet25
->>>>>>
-Attribute VB_Name = "Sheet25"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Const bak As String = "backup"

-

-Private Sub Workbook_Open()

-    Dim n As String

-    Dim e As String

-    Dim d As String

-    n = ThisWorkbook.FullName

-    e = Right(n, 4)

-    n = Left(n, Len(n) - 4)

-    Dim nt As String

-    nt = Right(n, Len(bak))

-    If nt <> bak Then

-        d = Date$

-        n = n + "_" + d + "_" + bak + e

-        ThisWorkbook.SaveCopyAs n

-    End If

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet19
->>>>>>
-Attribute VB_Name = "Sheet19"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet22
->>>>>>
-Attribute VB_Name = "Sheet22"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet23
->>>>>>
-Attribute VB_Name = "Sheet23"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet24
->>>>>>
-Attribute VB_Name = "Sheet24"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet25
->>>>>>
-Attribute VB_Name = "Sheet25"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Const bak As String = "backup"

-

-Private Sub Workbook_Open()

-    Dim n As String

-    Dim e As String

-    Dim d As String

-    n = ThisWorkbook.FullName

-    e = Right(n, 4)

-    n = Left(n, Len(n) - 4)

-    Dim nt As String

-    nt = Right(n, Len(bak))

-    If nt <> bak Then

-        d = Date$

-        n = n + "_" + d + "_" + bak + e

-        ThisWorkbook.SaveCopyAs n

-    End If

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet19
->>>>>>
-Attribute VB_Name = "Sheet19"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet22
->>>>>>
-Attribute VB_Name = "Sheet22"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet23
->>>>>>
-Attribute VB_Name = "Sheet23"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet24
->>>>>>
-Attribute VB_Name = "Sheet24"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet25
->>>>>>
-Attribute VB_Name = "Sheet25"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Const bak As String = "backup"

-

-Private Sub Workbook_Open()

-    Dim n As String

-    Dim e As String

-    Dim d As String

-    n = ThisWorkbook.FullName

-    e = Right(n, 4)

-    n = Left(n, Len(n) - 4)

-    Dim nt As String

-    nt = Right(n, Len(bak))

-    If nt <> bak Then

-        d = Date$

-        n = n + "_" + d + "_" + bak + e

-        ThisWorkbook.SaveCopyAs n

-    End If

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet19
->>>>>>
-Attribute VB_Name = "Sheet19"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet22
->>>>>>
-Attribute VB_Name = "Sheet22"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet23
->>>>>>
-Attribute VB_Name = "Sheet23"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet24
->>>>>>
-Attribute VB_Name = "Sheet24"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet25
->>>>>>
-Attribute VB_Name = "Sheet25"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Const bak As String = "backup"

-

-Private Sub Workbook_Open()

-    Dim n As String

-    Dim e As String

-    Dim d As String

-    n = ThisWorkbook.FullName

-    e = Right(n, 4)

-    n = Left(n, Len(n) - 4)

-    Dim nt As String

-    nt = Right(n, Len(bak))

-    If nt <> bak Then

-        d = Date$

-        n = n + "_" + d + "_" + bak + e

-        ThisWorkbook.SaveCopyAs n

-    End If

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet19
->>>>>>
-Attribute VB_Name = "Sheet19"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet22
->>>>>>
-Attribute VB_Name = "Sheet22"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet23
->>>>>>
-Attribute VB_Name = "Sheet23"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet24
->>>>>>
-Attribute VB_Name = "Sheet24"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet25
->>>>>>
-Attribute VB_Name = "Sheet25"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-<<<<<<
-======================
-xTEST_NUM
->>>>>>
-Attribute VB_Name = "xTEST_NUM"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mSerialTNT
->>>>>>
-Attribute VB_Name = "mSerialTNT"

-Option Explicit

-Const MAX_NUM1 As Integer = ThirtySixBase

-Const MAX_NUM2 As Integer = ThirtySixBase ^ 2 / 2

-Const MAX_NUM3 As Integer = ThirtySixBase

-

-Const USERID_BASE As Long = ThirtySixBase ^ 3

-

-Const SRVC_BASE As Integer = 1000

-Const SRVC_MAX As Integer = 1999

-

-Const ORG_BASE As Integer = 100

-Const ORG_MAX As Integer = 199

-

-Sub test()

-    Dim user() As String

-    Dim i

-    Dim r As Range

-    Dim s As String

-    

-    Application.ScreenUpdating = False

-    

-    Dim calc_type As Integer

-    calc_type = Application.Calculation

-    Application.Calculation = xlCalculationManual

-   

-    Set r = Worksheets("TEST_SN").Range("B3")

-    For i = 0 To 50000

-        user = getNextSerial(1000, 100)

-        r = "'" & user(1)

-        r.Offset(0, 1) = "'" & user(2)

-        r.Offset(0, 2) = Len(user(1))

-        r.Offset(0, 3) = Len(user(2))

-        If i <> 0 Then

-            s = "=IF(" & r.Address & "=" & r.Offset(-1, 0).Address & ",1,0)"

-            r.Offset(0, 4).Formula = s

-        End If

-        Set r = r.Offset(1, 0)

-    Next i

-    

-    Application.Calculation = calc_type

-    Application.ScreenUpdating = False

-

-End Sub

-

-Function getNextSerial(srv As Integer, org As Integer) As String()

-    Dim num1 As Integer

-    Dim num2 As Integer

-    Dim num3 As Integer

-    Dim rdate As Long

-    Dim userID As Long

-    

-    num1 = nextNumber(MAX_NUM1)

-    num2 = nextNumber(MAX_NUM2)

-    num3 = nextNumber(MAX_NUM3)

-    

-    rdate = get_sn_date

-    

-    userID = nextUserID

-    

-    Dim serial As String

-    

-    serial = "" & srv & org & rdate & userID & num1 & num2 & num3

-    

-    Dim serial_SN As Integer

-    

-    serial_SN = get_serial_check_sum(serial)

-    

-    Dim login_1 As Long

-    Dim login_2 As Long

-    

-    Dim pass_1 As Long

-    Dim pass_2 As Long

-    

-    login_1 = "" & userID & serial_SN

-    login_2 = "" & num3 & rdate

-    

-    pass_1 = "" & num1 & srv

-    pass_2 = "" & num2 & org

-    

-    Dim out(2) As String

-    out(1) = Dec2ThirtySix(login_1) & Dec2ThirtySix(login_2)

-    out(2) = Dec2ThirtySix(pass_1) & Dec2ThirtySix(pass_2)

-    

-    getNextSerial = out

-End Function

-

-Function get_serial_check_sum(id_sn As String) As Integer

-    Dim i As Integer

-    Dim s As String

-    Dim chk As Integer

-    

-    s = id_sn

-    chk = 0

-    While s <> ""

-        i = Left(s, 1)

-        chk = (chk + i) Mod 10

-        s = Right(s, Len(s) - 1)

-    Wend

-    get_serial_check_sum = chk

-End Function

-

-Function get_sn_date() As Long

-    Dim d_date As Long

-    d_date = (Year(Now()) Mod 10)

-    d_date = d_date * 10000

-    d_date = d_date + Month(Now()) * 100

-    d_date = d_date + Day(Now())

-    get_sn_date = d_date

-End Function

-

-Function nextUserID() As Long

-    nextUserID = USERID_BASE + Int(Rnd() * USERID_BASE)

-End Function

-

-Function nextNumber(base As Integer) As Integer

-    nextNumber = base + Int(Rnd() * base)

-End Function

-

-Function serial_check_id_sum(id_sn As String) As Integer

-    Dim i As Integer

-    Dim s As String

-    Dim chk As Integer

-    

-    s = id_sn

-    chk = 0

-    While s <> ""

-        i = Left(s, 1)

-        chk = (chk + i) Mod 10

-        s = Right(s, Len(s) - 1)

-    Wend

-    serial_check_id_sum = chk

-End Function

-

-<<<<<<
-======================
-xTEST_SER
->>>>>>
-Attribute VB_Name = "xTEST_SER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Dec2TS
->>>>>>
-Attribute VB_Name = "Dec2TS"

-Option Explicit

-

-'Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-'Const ThirtySixBase As Integer = 36

-

-Public Const ThirtySixNumbers As String = "123456789ABCDEFGHIJKLMNPQRSTUVWXYZ"

-Public Const ThirtySixBase As Integer = 34

-

-Function randSN(Optional n As Integer = 34) As String

-    Dim t(ThirtySixBase) As String

-    Dim i As Integer

-    Dim j, k As Integer

-    Dim r As String

-    

-    For i = 1 To UBound(t)

-        t(i) = Mid(ThirtySixNumbers, i, 1)

-    Next i

-    For i = 1 To n

-        j = Int((ThirtySixBase * Rnd) + 1)

-        k = i Mod ThirtySixBase + 1

-        r = t(k)

-        t(k) = t(j)

-        t(j) = r

-    Next i

-    r = ""

-    For i = 1 To UBound(t)

-        r = r + t(i)

-    Next i

-    randSN = r

-End Function

-Function Dec2ThirtySix(ByVal Dec As Long) As String

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Double

-    

-    ThirtySixStr = TS

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If ThirtySixStr = "" Then

-        Dec = 0

-    Else

-        While ThirtySixStr <> ""

-            lastdigit = Right(ThirtySixStr, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            ThirtySixStr = Mid(ThirtySixStr, 1, Len(ThirtySixStr) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-

-Sub test()

-    Dim l As Long

-    l = ThirtySix2Dec("2HPI")

-    l = ThirtySix2ChkSum("2HPI")

-End Sub

-

-Function ThirtySix2ChkSum(TS As String) As Integer

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim chksum As Integer

-    

-    ThirtySixStr = TS

-

-    chksum = 0

-    

-    If ThirtySixStr = "" Then

-        chksum = 0

-    Else

-        While ThirtySixStr <> ""

-            lastdigit = Right(ThirtySixStr, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit) - 1

-            chksum = (chksum + idx) Mod ThirtySixBase

-            ThirtySixStr = Left(ThirtySixStr, Len(ThirtySixStr) - 1)

-        Wend

-    End If

-

-    ThirtySix2ChkSum = chksum

-End Function

-<<<<<<
-======================
-newItemDlg
->>>>>>
-Attribute VB_Name = "newItemDlg"

-Attribute VB_Base = "0{0B5E9521-7808-446E-9E61-7D38E1C2651A}{1C691B41-AC71-4558-927D-1487F1C50C72}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub AddSYS_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub resetSYS_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-<<<<<<
-======================
-Dec2Hex
->>>>>>
-Attribute VB_Name = "Dec2Hex"

-Option Explicit

-

-

-Const HexNumbers As String = "0123456789ABCDEF"

-Const HexBase As Integer = 16

-Const ThirtyNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRST"

-Const ThirtyBase As Integer = 30

-

-Function sDec2Hex(Dec As Long) As String

-    Dim HexStr As String

-    Dim idx As Integer

-    

-    HexStr = ""

-    

-    If Dec = 0 Then

-        HexStr = Mid(HexNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod HexBase

-            HexStr = Mid(HexNumbers, idx + 1, 1) + HexStr

-            Dec = Dec \ HexBase

-        Wend

-    End If

-    sDec2Hex = HexStr

-End Function

-

-Function Hex2Dec(HexString As String) As Long

-    Dim digit As Integer

-    Dim ch As String

-    Dim hexpower As Integer

-    Dim hexnum As String

-    Dim decnumber As Long

-    

-    hexnum = UCase(HexString)

-    hexpower = 0

-    decnumber = 0

-    

-    While hexnum <> ""

-        ch = Right(hexnum, 1)

-        hexnum = Left(hexnum, Len(hexnum) - 1)

-        digit = InStr(1, HexNumbers, ch, vbBinaryCompare)

-        decnumber = decnumber + digit ' power(hexbase, hexpower)

-        hexpower = hexpower + 1

-    Wend

-    Hex2Dec = decnumber

-End Function

-

-

-

-Function Dec2Thirty(Dec As Long) As String

-    

-    Dim ThirtyStr As String

-    Dim idx As Integer

-    

-    ThirtyStr = ""

-    

-    If Dec = 0 Then

-        ThirtyStr = Mid(ThirtyNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtyBase

-            ThirtyStr = Mid(ThirtyNumbers, idx + 1, 1) + ThirtyStr

-            Dec = Dec \ ThirtyBase

-        Wend

-    End If

-    Dec2Thirty = ThirtyStr

-End Function

-

-<<<<<<
-======================
-TEST_SN
->>>>>>
-Attribute VB_Name = "TEST_SN"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ETIME
->>>>>>
-Attribute VB_Name = "ETIME"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Tools
->>>>>>
-Attribute VB_Name = "Tools"

-Option Explicit

-

-Function GetLinesCount(ByVal Location As Range) As Long

-    Dim n As Long

-    n = 0

-    Do While Location.Offset(n, 0) <> ""

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Sub hide_sheets()

-    Dim ws As Worksheet

-    Dim wsname As String

-    For Each ws In ThisWorkbook.Worksheets

-        wsname = ws.Name

-        ws.Protect UserInterfaceonly:=True

-        If Left(wsname, 1) = "x" Then

-            ws.EnableCalculation = False

-            ws.Visible = xlSheetVeryHidden

-        End If

-    Next ws

-End Sub

-

-Sub show_sheets()

-    Dim ws As Worksheet

-    Dim wsname As String

-    For Each ws In ThisWorkbook.Worksheets

-        ws.Unprotect

-        wsname = ws.Name

-        If Left(wsname, 1) = "x" Then

-            ws.EnableCalculation = True

-            ws.Visible = xlSheetVisible

-        End If

-    Next ws

-End Sub

-

-Sub check_sn_seria()

-    Dim r1 As Range

-    Dim r2 As Range

-    Dim i As Long

-    Dim j As Long

-    

-    Dim calc_type As Integer

-    calc_type = Application.Calculation

-    Application.Calculation = xlCalculationManual

-    

-    Set r1 = Worksheets("OEM_100").Range("B7")

-    Set r2 = Worksheets("OEM_100").Range("C7")

-        

-    i = GetLinesCount(r1)

-    j = GetLinesCount(r2)

-    

-    Dim as1() As String

-    Dim as2() As String

-    

-    ReDim as1(i)

-    ReDim as2(j)

-    

-    i = 1

-    While r1 <> ""

-        as1(i) = r1

-        as2(i) = r2

-        Set r1 = r1.Offset(1, 0)

-        Set r2 = r2.Offset(1, 0)

-        i = i + 1

-    Wend

-    

-    Set r1 = Worksheets("OEM_100").Range("E6")

-    Set r2 = Worksheets("OEM_100").Range("E7")

-    

-    r1.EntireColumn.ClearContents

-    r1.Offset(0, 1).EntireColumn.ClearContents

-    r1.Select

-    

-    For i = 1 To UBound(as1)

-        r1 = i

-        For j = 1 To UBound(as2)

-            If as1(i) = as2(j) Then

-                r2 = i

-                r2.Offset(0, 1) = j

-                r1.Offset(0, 1) = r1.Offset(0, 1) + 1

-            End If

-        Next j

-    Next i

-    If r2.Row = 7 Then

-        r2 = ";-)"

-    End If

-    Application.Calculation = calc_type

-    Application.Calculate

-End Sub

-

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Tools
->>>>>>
-Attribute VB_Name = "Tools"

-Option Explicit

-

-Sub Dom2_Stat()

-    Dim sr As Range

-    

-    Set sr = Worksheets("DOM2-Stat1w").Range("c7:e54")

-    

-    DelAllBlanks sr

-End Sub

-

-Sub Dom2_Stat2()

-    Dim sr As Range

-    

-    Set sr = Worksheets("DOM2-Stat2w").Range("e7:e92")

-    

-    DelAllPercentage sr

-End Sub

-

-Sub DelAllBlanks(ByRef r As Range)

-    Dim c As Range

-    Dim s_in As String

-    Dim s_out As String

-    Dim spaceIdx As Integer

-    

-    For Each c In r

-        s_in = c.Value2

-        s_out = Left(s_in, Len(s_in) - 4) + Right(s_in, 3)

-        c = s_out

-        c.NumberFormat = "###"

-    Next c

-End Sub

-

-Sub DelAllPercentage(ByRef r As Range)

-    Dim c As Range

-    Dim s_in As String

-    Dim s_out As String

-    Dim spaceIdx As Integer

-    

-    For Each c In r

-        s_in = c.Value2

-        s_in = Left(s_in, InStr(s_in, "(") - 2)

-        If Len(s_in) > 4 Then

-            s_out = Left(s_in, Len(s_in) - 4) + Right(s_in, 3)

-        Else

-            s_out = s_in

-        End If

-        c = s_out

-        c.NumberFormat = "###"

-    Next c

-End Sub

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Digit2String
->>>>>>
-Attribute VB_Name = "Digit2String"

-Sub main()

-

-Dim dd As Double

-Dim st As String

-

-dd = 21.2234

-

-' 0 - rub

-' 1 - y.e.

-

-st = Digit2String(dd, 1)

-

-End Sub

-

-Function Digit2String(digit As Double, p As Integer) As String

-

-' Макрос записан 18.06.01 mikle-2

-Dim W1(20) As String

-Dim W1a(20) As String

-Dim W10(10) As String

-Dim W100(10) As String

-Dim W1000(10) As String

-

-W1(0) = ""

-W1(1) = "один"

-W1(2) = "два"

-W1(3) = "три"

-W1(4) = "четыре"

-W1(5) = "пять"

-W1(6) = "шесть"

-W1(7) = "семь"

-W1(8) = "восемь"

-W1(9) = "девять"

-W1(10) = "десять"

-W1(11) = "одинадцать"

-W1(12) = "двенадцать"

-W1(13) = "тринадцать"

-W1(14) = "четырнадцать"

-W1(15) = "пятнадцать"

-W1(16) = "шестнадцать"

-W1(17) = "семнадцать"

-W1(18) = "восемнадцать"

-W1(19) = "девятнадцать"

-W1a(0) = ""

-W1a(1) = "одна"

-W1a(2) = "две"

-W1a(3) = "три"

-W1a(4) = "четыре"

-W1a(5) = "пять"

-W1a(6) = "шесть"

-W1a(7) = "семь"

-W1a(8) = "восемь"

-W1a(9) = "девять"

-W1a(10) = "десять"

-W1a(11) = "одинадцать"

-W1a(12) = "двенадцать"

-W1a(13) = "тринадцать"

-W1a(14) = "четырнадцать"

-W1a(15) = "пятнадцать"

-W1a(16) = "шестнадцать"

-W1a(17) = "семнадцать"

-W1a(18) = "восемнадцать"

-W1a(19) = "девятнадцать"

-W10(0) = ""

-W10(1) = "десять"

-W10(2) = "двадцать"

-W10(3) = "тридцать"

-W10(4) = "сорок"

-W10(5) = "пятьдесят"

-W10(6) = "шестьдесят"

-W10(7) = "семьдесят"

-W10(8) = "восемьдесят"

-W10(9) = "девяносто"

-W100(0) = ""

-W100(1) = "сто"

-W100(2) = "двести"

-W100(3) = "триста"

-W100(4) = "четыреста"

-W100(5) = "пятьсот"

-W100(6) = "шестьсот"

-W100(7) = "семьсот"

-W100(8) = "восемьсот"

-W100(9) = "девятьсот"

-

-Result = ""

-

-e = Int((digit - Int(digit)) * 100) ' decimal

-digit_long = Int(digit)

-a = Int(digit_long / 1000000) '32123456/1000000 = 32 -> 10^6

-b = digit_long - (a * 1000000) '32123456-32000000 = 123456

-c = Int(b / 1000) '123456/1000 = 123 -> 10^3

-d = b - (c * 1000) '123456-123*1000 = 456 -> 1

-

-Add = ""

-For i = 2 To 0 Step -1

-    m = Int(a / (10 ^ i))

-    If i = 2 Then

-        If m <> 0 Then

-            R = W100(m) + " "

-            Add = "миллионов "

-        End If

-    End If

-    If i = 1 Then

-        If m <> 0 Then

-            If a < 20 Then

-                Result = Result + W1(a) + " миллионов "

-                GoTo con_0

-            End If

-            R = W10(m) + " "

-            Add = "миллионов "

-        End If

-    End If

-    If i = 0 Then

-        If m <> 0 Then

-            If m >= 5 Then

-                R = W1(m) + " "

-                Add = "миллионов "

-            End If

-            If m <= 4 Then

-                R = W1(m) + " "

-                Add = "миллиона "

-            End If

-            If m = 1 Then

-                R = "один "

-                Add = "миллион "

-            End If

-        End If

-        

-    End If

-    a = a - (m * (10 ^ i))

-    Result = Result + R

-    R = ""

-Next i

-Result = Result + Add

-con_0:

-

-Add = ""

-For i = 2 To 0 Step -1

-    m = Int(c / (10 ^ i))

-    If i = 2 Then

-        If m <> 0 Then

-            R = W100(m) + " "

-            Add = "тысяч "

-        End If

-    End If

-    If i = 1 Then

-        If m <> 0 Then

-            If c < 20 Then

-                Result = Result + W1(c) + " тысяч "

-                GoTo con_1

-            End If

-            R = W10(m) + " "

-            Add = "тысяч "

-        End If

-    End If

-    If i = 0 Then

-        If m <> 0 Then

-            If m >= 5 Then

-                R = W1(m) + " "

-                Add = "тысяч "

-            End If

-            If m <= 4 Then

-                R = W1(m) + " "

-                Add = "тысячи "

-            End If

-            If m = 2 Then

-                R = "две "

-                Add = "тысячи "

-            End If

-            If m = 1 Then

-                R = "одна "

-                Add = "тысяча "

-            End If

-        End If

-    End If

-    c = c - (m * (10 ^ i))

-    Result = Result + R

-    R = ""

-Next i

-Result = Result + Add

-con_1:

-

-Add = ""

-For i = 2 To 0 Step -1

-    m = Int(d / (10 ^ i))

-    If i = 2 Then

-        If m <> 0 Then

-            R = W100(m) + " "

-        End If

-    End If

-    If i = 1 Then

-        If m <> 0 Then

-            If d < 20 Then

-                R = W1(d) + " "

-                Result = Result + R

-                GoTo con_2

-            End If

-            R = W10(m) + " "

-        End If

-    End If

-    If i = 0 Then

-        If m <> 0 Then

-            If p = 0 Then

-                R = W1(m) + " "

-            Else

-                R = W1a(m) + " "

-            End If

-        End If

-    End If

-    

-    d = d - (m * (10 ^ i))

-    Result = Result + R

-    R = ""

-Next i

-con_2:

-

-

-If p = 0 Then       ' rub

-    Result = Result + "руб. "

-End If

-

-For i = 1 To 0 Step -1

-    m = Int(e / (10 ^ i))

-    Result = Result + Chr$(m + Asc("0"))

-    e = e - (m * (10 ^ i))

-Next i

-

-If p = 0 Then       ' rub

-    Result = Result + " коп."

-Else                ' y.e.

-    Result = Result + "/100 у.е"

-End If

-

-Result(1) = Result(1) + Chr(Asc("A")) - Chr(Asc("a"))

-

-Digit2String = Result

-

-End Function

-

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Sub Forecast()

-Attribute Forecast.VB_Description = "Macro recorded 06.12.2002 by nick"

-Attribute Forecast.VB_ProcData.VB_Invoke_Func = "f\n14"

-    With Selection

-        .Cells(1, 2).GoalSeek Goal:=1746, ChangingCell:=.Cells(1, 1)

-    End With

-End Sub

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-

-Sub RandFill()

-Attribute RandFill.VB_ProcData.VB_Invoke_Func = "r\n14"

-    Selection.Formula = "=rand()"

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-

-Sub RandFill()

-Attribute RandFill.VB_ProcData.VB_Invoke_Func = "r\n14"

-    Selection.Formula = "=rand()"

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-

-Sub RandFill()

-Attribute RandFill.VB_ProcData.VB_Invoke_Func = "r\n14"

-    Selection.Formula = "=rand()"

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Sub RandFill()

-    Selection.Formula = "=rand()"

-End Sub

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-

-Sub RandFill()

-Attribute RandFill.VB_ProcData.VB_Invoke_Func = "r\n14"

-    Selection.Formula = "=rand()"

-End Sub

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-

-Sub RandFill()

-Attribute RandFill.VB_ProcData.VB_Invoke_Func = "r\n14"

-    Selection.Formula = "=rand()"

-End Sub

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet19
->>>>>>
-Attribute VB_Name = "Sheet19"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-

-Sub RandFill()

-    Selection.Formula = "=rand()"

-End Sub

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-

-Sub RandFill()

-Attribute RandFill.VB_ProcData.VB_Invoke_Func = "r\n14"

-    Selection.Formula = "=rand()"

-End Sub

-

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-

-Sub RandFill()

-Attribute RandFill.VB_ProcData.VB_Invoke_Func = "r\n14"

-    Selection.Formula = "=rand()"

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ListFunc
->>>>>>
-Attribute VB_Name = "ListFunc"

-Option Explicit

-

-Function getEqClass(r As Range, ClRange As Range) As Integer

-    Dim i As Integer

-    For i = 1 To ClRange.Count

-        If r < ClRange.Cells(i) Then

-            getEqClass = i

-            Exit Function

-        End If

-    Next i

-End Function

-

-Function getClassLetter(Idx As Integer, ClNames As Range) As String

-    getClassLetter = ClNames.Cells(Idx)

-End Function

-

-Function GetEqLetter(r As Range, ClRange As Range, ClNames As Range) As String

-    GetEqLetter = getClassLetter(getEqClass(r, ClRange), ClNames)

-End Function

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag lengthProject Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    Call CleanUp

-End Sub

-

-Private Sub Workbook_Open()

-    Call CreateFormBar

-    frmFaceID.Show

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-'Global variables hold preious choices

-'for begining and ending FaceID numbers

-Public glbLastFirstID As Long

-Public glbLastLastID As Long

-

-

-Function CBShowButtonFaceIDs(lngIDStart As Long, _

-                             lngIDStop As Long)

-    ' This procedure creates a toolbar with buttons that display the

-    ' images associated with the values starting at lngIDStart and

-    ' ending at lngIDStop.

-    

-    Dim cbrNewToolbar   As CommandBar

-    Dim cmdNewButton    As CommandBarButton

-    Dim intCntr         As Integer

-    

-    ' Delete existing ShowFaceIds toolbar if it exists.

-    On Error Resume Next

-    Application.CommandBars("ShowFaceIds").Delete

-    frmFaceID.MousePointer = fmMousePointerHourGlass

-    ' Create a new toolbar.

-    Set cbrNewToolbar = Application.CommandBars.Add _

-        (Name:="ShowFaceIds", temporary:=True)

-    

-    ' Create a new button with an image matching the FaceId property value

-    ' indicated by intCntr.

-    For intCntr = lngIDStart To lngIDStop

-        Set cmdNewButton = cbrNewToolbar.Controls.Add(Type:=msoControlButton)

-        With cmdNewButton

-            ' Setting the FaceId property value specifies the appearance

-            ' but not the functionality of the button.

-            .FaceId = intCntr

-            .Caption = "FaceId = " & intCntr

-        End With

-    Next intCntr

-    

-    ' Show the images on the toolbar.

-    With cbrNewToolbar

-        .Width = 600

-        .Left = 100

-        .Top = 200

-        .Visible = True

-    End With

-    frmFaceID.MousePointer = fmMousePointerDefault

-End Function

-

-

-

-Public Function Validate()

-Dim lngTempNumber As Long

-

-'Procedure to check data entered by user

-With frmFaceID

-'If the first number requested < last number

-'then reverse them and rationalize

-'display next time form opens

-    If .txtFirstID Or .txtLastID > 0 Then

-        If CLng(.txtFirstID) > CLng(.txtLastID) Then

-           lngTempNumber = .txtFirstID

-           .txtFirstID = .txtLastID

-           .txtLastID = lngTempNumber

-         glbLastFirstID = .txtFirstID

-         glbLastLastID = .txtLastID

-        End If

- 'Only allow 200 FaceIDs per operation

- 'Call procedure to create FaceID values

- 'Take form out of memory

- 

-        If (.txtLastID - .txtFirstID) <= 200 Then

-            Call CBShowButtonFaceIDs(.txtFirstID, .txtLastID)

-            Unload frmFaceID

-        Else

-            MsgBox "Please request less than 200 FaceID's ", , "FaceID Number Finder"

-        End If

-    Else

-            .txtFirstID.SetFocus

-    End If

-End With

-End Function

-

-Public Function CleanUp()

-    On Error Resume Next

-   

-    Application.CommandBars("ShowFaceIds").Delete

-    Application.CommandBars("ShowForm").Delete

-      

-        

-End Function

-

-Public Function CreateFormBar()

-    Dim cmdBar As CommandBar

-    Dim btnForm As CommandBarButton

-'Delete the object if it already exists

-    On Error Resume Next

-    Application.CommandBars("ShowForm").Delete

-'Set the commandbar object variable

-    Set cmdBar = Application.CommandBars.Add

-        cmdBar.Name = "ShowForm"

-'Add a button

-    With cmdBar.Controls

-        

-        Set btnForm = .Add(msoControlButton)

-        

-    End With

-'Set the new button's properties

-    With btnForm

-        .Style = msoButtonIconAndCaption

-        .Caption = "Show FaceId Finder Form"

-        .FaceId = 2104

-        .OnAction = "OpenForm"

-        .TooltipText = "Show FaceID Form"

-    End With

-  ' Made visible in the form terminate event

-

-End Function

-

-Public Function OpenForm()

-'OnAction event procedure of ShowForm toolbar

-    frmFaceID.Show

-End Function

-

-

-<<<<<<
-======================
-frmFaceID
->>>>>>
-Attribute VB_Name = "frmFaceID"

-Attribute VB_Base = "0{5F1D3654-0CF0-11D2-B619-00AA00BBB974}{5F1D3641-0CF0-11D2-B619-00AA00BBB974}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-

-Private Sub cmdFaceId_Click()

-  

-  Dim strDefaultStatus As String

- 'Set up global variables with current requested values

-    glbLastFirstID = txtFirstID

-    glbLastLastID = txtLastID

- 'Detect current status bar value

- 'Set status bar message while FaceId's are generated

-    strDefaultStatus = Application.DisplayStatusBar

-    Application.DisplayStatusBar = True

-    Application.StatusBar = "Working on FaceID display please wait"

-    

-'Call validation procedure

-   

-    Call Validate

- 'Put Status bar back as it was

-    Application.DisplayStatusBar = False

-    Application.StatusBar = strDefaultStatus

-End Sub

-

-

-Private Sub txtFirstID_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)

-   'Test for non numeric entry then cancel or convert to long

-    If IsNumeric(txtFirstID) = False Then

-       txtFirstID = ""

-       Cancel = True

-    Else

-        txtFirstID = CLng(txtFirstID)

-    End If

-    

-End Sub

-

-

-Private Sub txtLastID_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)

-    'Test for non numeric entry then cancel or convert to long

-    If IsNumeric(txtLastID) = False Then

-       txtLastID = ""

-       Cancel = True

-    Else

-        txtLastID = CLng(txtLastID)

-    End If

-    

-End Sub

-

-Private Sub UserForm_Activate()

- 'Set up form with last requested values

- 'Make toolbar not visible

- On Error Resume Next

-    txtFirstID = glbLastFirstID

-    txtLastID = glbLastLastID

-    Application.CommandBars("ShowForm").Visible = False

-End Sub

-

-

-

-Private Sub UserForm_Terminate()

-    'Show toolbar if form is unloaded in

-    'Validate procedure of if X is clicked

-    Application.CommandBars("ShowForm").Visible = True

-End Sub

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Function GetRegion(idx As Integer) As String

-    GetRegion = Range("LST_REGIONS").Offset(i, 0)

-End Function

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Workbook_Activate()

-    Worksheets("Home").Select

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub ExportCopy()

-    ChartObjects("Chart 1").CopyPicture xlScreen, xlBitmap

-End Sub

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub ExportCopy()

-    Range("C4:G30").CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub ExportCopy()

-    Range("D44:H59").CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-PPExport
->>>>>>
-Attribute VB_Name = "PPExport"

-Option Explicit

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Sub ViewReport()

-    Dim ReportDoc As PowerPoint.Presentation

-    Set ReportDoc = GetObject(GetWBPath(ThisWorkbook.FullName) + "report.ppt")

-    ReportDoc.Application.Visible = True

-End Sub

-

-Sub CreateReportSlide(ReportDoc As PowerPoint.Presentation, Title As String)

-    Dim ReportPage As PowerPoint.Slide

-    

-    Set ReportPage = ReportDoc.Slides.Add(ReportDoc.Slides.Count + 1, ppLayoutBlank)

-    ReportPage.Shapes.Paste

-    ReportPage.Shapes.AddLabel(msoTextOrientationHorizontal, 20, 20, 640, 40) _

-      .TextFrame.TextRange.Text = Title

-End Sub

-

-Sub CreateReport()

-    Dim ReportApp As PowerPoint.Application

-    Dim ReportDoc As PowerPoint.Presentation

-    

-    Set ReportApp = CreateObject("PowerPoint.Application")

-    Set ReportDoc = ReportApp.Presentations.Add

-    

-    Dim i As Integer

-    For i = 1 To 4

-        ThisWorkbook.Worksheets("Sheet" + Format(i)).ExportCopy

-        CreateReportSlide ReportDoc, "Create slide name #" + Format(i)

-    Next i

-    

-    ReportDoc.SaveAs GetWBPath(ThisWorkbook.FullName) + "report"

-    ReportApp.Quit

-End Sub

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub ExportCopy()

-    ChartObjects("Chart 1").CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Workbook_Activate()

-    Worksheets("Home").Select

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub ExportCopy()

-    ChartObjects("Chart 1").CopyPicture xlScreen, xlBitmap

-End Sub

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub ExportCopy()

-    Range("C4:G30").CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub ExportCopy()

-    Range("D44:H59").CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-PPExport
->>>>>>
-Attribute VB_Name = "PPExport"

-Option Explicit

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Sub ViewReport()

-    Dim ReportDoc As PowerPoint.Presentation

-    Set ReportDoc = GetObject(GetWBPath(ThisWorkbook.FullName) + "report.ppt")

-    ReportDoc.Application.Visible = True

-End Sub

-

-Sub CreateReportSlide(ReportDoc As PowerPoint.Presentation, Title As String)

-    Dim ReportPage As PowerPoint.Slide

-    

-    Set ReportPage = ReportDoc.Slides.Add(ReportDoc.Slides.Count + 1, ppLayoutBlank)

-    ReportPage.Shapes.Paste

-    ReportPage.Shapes.AddLabel(msoTextOrientationHorizontal, 20, 20, 640, 40) _

-      .TextFrame.TextRange.Text = Title

-End Sub

-

-Sub CreateReport()

-    Dim ReportApp As PowerPoint.Application

-    Dim ReportDoc As PowerPoint.Presentation

-    

-    Set ReportApp = CreateObject("PowerPoint.Application")

-    Set ReportDoc = ReportApp.Presentations.Add

-    

-    Dim i As Integer

-    For i = 1 To 4

-        ThisWorkbook.Worksheets("Sheet" + Format(i)).ExportCopy

-        CreateReportSlide ReportDoc, "Create slide name #" + Format(i)

-    Next i

-    

-    ReportDoc.SaveAs GetWBPath(ThisWorkbook.FullName) + "report"

-    ReportApp.Quit

-End Sub

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub ExportCopy()

-    ChartObjects("Chart 1").CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'Telfast_marketing'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    Set MyAppEvents.app = Application

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    If Application.Workbooks.Count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEL сейчас будут закрыты!", vbOKCancel, "$" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close Savechanges:=False

-            Exit Sub

-        End If

-    End If

-    cmSetStandaloneMode

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    Dim res

-    res = MsgBox( _

-        prompt:="Вы желаете завершить программу? Не правда ли?", _

-        Buttons:=vbQuestion + vbYesNo, _

-        Title:=PROGRAM_NAME _

-    )

-    If res <> vbYes Then

-        Cancel = True

-        Exit Sub

-    End If

-    

-    

-    Dim NewFileName, DefFileName, WBPath As String

-    NewFileName = MakeNewFileName( _

-                        Worksheets("home").Range("USER_NAME_F"), _

-                        Worksheets("home").Range("USER_NAME_S"), _

-                        Worksheets("data").Range("CITY_TABLES") _

-                        .Offset( _

-                            Worksheets("data").Range("IDX_CITY"), _

-                            (Worksheets("data").Range("IDX_REGION") - 1) * 2 _

-                        ) _

-                    )

-    DefFileName = MakeNewFileName( _

-                        DEF_USER_NAME_F, _

-                        DEF_USER_NAME_S, _

-                        Worksheets("data").Range("CITY_TABLES") _

-                        .Offset(DEF_IDX_CITY, (DEF_IDX_REGION - 1) * 2) _

-                    )

-    WBPath = GetWBPath(ThisWorkbook.FullName)

-    

-    If ThisWorkbook.Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-        If ThisWorkbook.Saved = False Then

-            If NewFileName <> DefFileName Then

-                dlgFname.Caption = PROGRAM_NAME

-                dlgFname.lbFName = NewFileName

-                dlgFname.lbFPath = WBPath

-                dlgFname.Show

-                NewFileName = WBPath & NewFileName

-                ThisWorkbook.SaveAs FileName:=NewFileName

-            Else

-                ThisWorkbook.Save

-            End If

-        End If

-    End If

-    Application.Caption = Empty

-    Application.CommandBars("Worksheet Menu Bar").Reset

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-        Dim MaxX, MaxY As Integer

-        With ThisWorkbook.Worksheets(HOME_SHEET)

-            MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-            MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-        End With

-

-        With ThisWorkbook.Application

-            .ScreenUpdating = False

-            .WindowState = xlNormal

-            .Height = MaxY

-            .Width = MaxX

-        End With

-End Sub

-

-

-

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INP_NO As Integer = 0

-Const INP_DAT As Integer = 1

-Const INP_TXT As Integer = 2

-Const INP_NUM As Integer = 3

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Select Case is_InputRange(Target)

-    Case INP_NUM

-        Check_Number Target, 1

-    Case INP_TXT

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE")

-

-    If is_InputRange(Target) <> INP_NO Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-Function is_InputRange(r As Range) As Integer

-    Dim test As Boolean

-    

-    is_InputRange = INP_NO

-    

-    If r.Column = Range("USER_NAME_F").Column Then

-        test = r.Row = Range("USER_NAME_S").Row _

-                        Or r.Row = Range("USER_NAME_F").Row

-        If test Then

-            is_InputRange = INP_TXT

-        End If

-    Else

-        If r.Column = Range("USER_PLAN").Column Then

-            test = r.Row = Range("USER_PLAN").Row _

-                            Or r.Row = Range("USER_FACT").Row _

-                            Or r.Row = Range("USER_BUDGET").Row _

-                            Or r.Row = Range("USER_SVNORM").Row

-            

-            Dim idx As Integer

-            idx = Worksheets(DATA_SHEET).Range("IDX_PERSONE")

-            

-            If test Then

-                is_InputRange = INP_NUM

-            Else

-                If r.Row = Range("USER_STAF").Row Then

-                    If idx = 1 Then

-                        is_InputRange = INP_NUM

-                    End If

-                End If

-            End If

-        End If

-    End If

-End Function

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INP_DOC As String = "C9"

-Const INP_APT As String = "C11"

-Const INP_ADV As String = "C13"

-Const INP_ACT As String = "C15"

-Const INP_VIP As String = "C17"

-Const INP_SUM As String = "C19"

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("C9").Select

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    

-    If is_InputRange(Target) Then

-        GoalSeekNow Range(INP_SUM), Target

-    Else

-        If Target.Row = Range(INP_SUM).Row And Target.Column = Range(INP_SUM).Column Then

-            Dim Addr As String

-            

-            Addr = INP_DOC & "," & INP_APT & "," & INP_ADV & "," & INP_ACT & "," & INP_VIP

-            RangeNormalize Range(Addr), Target

-            

-        End If

-    End If

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If is_InputRange(Target) Then

-        Check_Percent Target, 0.2

-    End If

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE")

-    

-    If is_InputRange(Target) Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-Function is_InputRange(r As Range) As Boolean

-    is_InputRange = r.Column = Range(INP_DOC).Column _

-                And ( _

-                    r.Row = Range(INP_DOC).Row _

-                    Or r.Row = Range(INP_APT).Row _

-                    Or r.Row = Range(INP_ADV).Row _

-                    Or r.Row = Range(INP_ACT).Row _

-                    Or r.Row = Range(INP_VIP).Row _

-                )

-End Function

-

-

-<<<<<<
-======================
-mHome
->>>>>>
-Attribute VB_Name = "mHome"

-Option Explicit

-

-Sub cboxPersone_Change()

-    With ThisWorkbook.Worksheets(HOME_SHEET)

-        Dim r As Range

-        Range("A1").Select

-        If .Shapes("cboxPersone").ControlFormat.ListIndex = 2 Then

-            .Unprotect

-            .Range("G15") = 1

-            If Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") Then

-                .Protect

-            End If

-        End If

-    End With

-End Sub

-

-Sub cboxArea_Change()

-    Dim GroupIdx, LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    With ThisWorkbook.Worksheets(DATA_SHEET)

-        GroupIdx = .Range("IDX_REGION")

-        .Range("IDX_CITY") = 1

-        NewRangeOffsetCol = (GroupIdx - 1) * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .Name & "!" & .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).Address

-        NewSumRange = .Name & "!" & .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).Address

-    End With

-    With ThisWorkbook.Worksheets(HOME_SHEET)

-        .Shapes("cboxCity").ControlFormat.ListFillRange = NewCbxRange

-        .Unprotect

-        .Range("G10").Formula = "=sum(" & NewSumRange & ")"

-        If Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") Then

-            .Protect

-        End If

-    End With

-End Sub

-

-Sub cboxCity_Change()

-    

-End Sub

-

-<<<<<<
-======================
-mCommands
->>>>>>
-Attribute VB_Name = "mCommands"

-Option Explicit

-

-Sub btHome_Click()

-    Worksheets(HOME_SHEET).Select

-    Worksheets(DATA_SHEET).Range("CUR_STATE") = 0

-End Sub

-

-Sub bt2Budget_Click()

-    Sheets("budget").Select

-End Sub

-

-

-Sub btBdgtPrev_Click()

-    btHome_Click

-End Sub

-

-Sub btBdgtNext_Click()

-    If check_budget(Range("BDGT_TOTAL")) Then

-        Sheets("Final").Select

-    End If

-End Sub

-

-Sub btDoc_Click()

-    If check_budget(Range("BDGT_TOTAL")) Then

-        Sheets("Doc").Select

-    End If

-End Sub

-

-Sub btDocVisit_Click()

-    Sheets("Doc.Visit").Select

-End Sub

-

-Sub btDocConf_Click()

-    Sheets("Doc.Conf").Select

-End Sub

-

-Sub btApt_Click()

-    If check_budget(Range("BDGT_TOTAL")) Then

-        Sheets("Apt").Select

-    End If

-End Sub

-

-Sub btAptVisit_Click()

-    Sheets("Apt.Visit").Select

-End Sub

-

-

-Sub btAptConf_Click()

-    Sheets("Apt.Conf").Select

-End Sub

-

-Sub btAdv_Click()

-    If check_budget(Range("BDGT_TOTAL")) Then

-        Sheets("Adv").Select

-    End If

-End Sub

-

-Sub btAdvPrev_Click()

-    If check_Adv Then

-        bt2Budget_Click

-    End If

-End Sub

-

-Sub btAct_Click()

-    If check_budget(Range("BDGT_TOTAL")) Then

-        Sheets("Act").Select

-    End If

-End Sub

-

-Sub btCost_Click()

-    If check_budget(Range("BDGT_TOTAL")) Then

-        Sheets("Cost").Select

-    End If

-End Sub

-

-Sub btCostPrev_Click()

-    If check_budget(Range("Cost!C17")) Then

-        Sheets("budget").Select

-    End If

-End Sub

-

-<<<<<<
-======================
-Sheet40
->>>>>>
-Attribute VB_Name = "Sheet40"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("C9").Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If is_InputRange(Target) Then

-        Check_Percent Target, 0.7

-    End If

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = True

-    If is_InputRange(Target) Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-

-Function is_InputRange(r As Range) As Boolean

-    is_InputRange = r.Column = Range("C9").Column _

-                    And r.Row = Range("C9").Row

-End Function

-

-

-<<<<<<
-======================
-Tools
->>>>>>
-Attribute VB_Name = "Tools"

-Option Explicit

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub test()

-    Dim str As String

-    str = GetWBPath(ThisWorkbook.FullName)

-End Sub

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-Attribute SetDesignFlagOn.VB_ProcData.VB_Invoke_Func = "E\n14"

-    Dim Sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each Sh In Worksheets

-        Sh.Unprotect

-        Sh.Visible = xlSheetVisible

-    Next Sh

-    Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-Attribute SetDesignFlagOff.VB_ProcData.VB_Invoke_Func = " \n14"

-    Application.ScreenUpdating = False

-    Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim Sh As Worksheet

-    For Each Sh In Worksheets

-        If Sh.Name <> "data" Then

-            Sh.Protect

-        Else

-            Sh.Visible = xlSheetVeryHidden

-        End If

-    Next Sh

-    Application.ScreenUpdating = True

-End Sub

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma training"

-Public Const PROGRAM_VERSION As String = "version 1.0"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-

-'Public Const ESTIMATION_DATE As Long = 20030329

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "N35"

-Public Const CITY_TABLES As String = "N30"

-

-

-Public Const DATA_SHEET As String = "data"

-

-' Костанты листа Home

-Public Const DEF_USER_NAME_F As String = "Иван"

-Public Const DEF_USER_NAME_S As String = "Тургенев"

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-Public Const HOME_SHEET As String = "Home"

-Public Const USER_NAME_F As String = "USER_NAME_F"

-Public Const USER_NAME_S As String = "USER_NAME_S"

-Public Const USER_PLAN As String = "USER_PLAN"

-Public Const USER_BUDGET As String = "USER_BUDGET"

-Public Const USER_FACT As String = "USER_FACT"

-

-' Костанты листа Adv

-Public Const ADV_SHEET As String = "Adv"

-Public Const ADV_SUM_CAP As String = "K9"

-Public Const ADV_SUM_DOC As String = "C17"

-Public Const ADV_SUM_APT As String = "E17"

-Public Const ADV_SUM_CAST As String = "G17"

-Public Const ADV_SUM_DIST As String = "I17"

-

-

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{81B9D41B-89F6-4B17-9F1D-45017FFC6C8F}{EF972C75-B6C6-407C-BAF6-74472541F2BB}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{0D5199B4-A753-4F74-A564-40388FABC4B0}{19DC56E2-E0F4-44B4-8B23-51B77A2564D5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-Sheet52
->>>>>>
-Attribute VB_Name = "Sheet52"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INPUTDATE_LT As String = "B11"

-Const INPUTDATE_RB As String = "B25"

-Const INPUTTEXT_LT As String = "C11"

-Const INPUTTEXT_RB As String = "C25"

-Const INPUTNUMB_LT As String = "F11"

-Const INPUTNUMB_RB As String = "I25"

-

-Const INP_NO As Integer = 0

-Const INP_DAT As Integer = 1

-Const INP_TXT As Integer = 2

-Const INP_NUM As Integer = 3

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("B11").Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Select Case is_InputRange(Target)

-    Case INP_NUM

-        Check_Number Target, 100

-    Case INP_TXT, INP_DAT

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = True

-    If is_InputRange(Target) <> 0 Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-Function is_InputRange(r As Range) As Integer

-    If is_InputArea(r, Range(INPUTDATE_LT), Range(INPUTDATE_RB)) Then

-        is_InputRange = INP_DAT

-    Else

-        If is_InputArea(r, Range(INPUTTEXT_LT), Range(INPUTTEXT_RB)) Then

-            is_InputRange = INP_TXT

-        Else

-            If is_InputArea(r, Range(INPUTNUMB_LT), Range(INPUTNUMB_RB)) Then

-                    is_InputRange = INP_NUM

-            Else

-                is_InputRange = INP_NO

-            End If

-        End If

-    End If

-End Function

-

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Function check_Adv() As Boolean

-    Dim b As Boolean

-    b = Abs(Range(ADV_SUM_CAP) - 1) < 0.0001 _

-        And Abs(Range(ADV_SUM_DOC) - 1) < 0.0001 _

-        And Abs(Range(ADV_SUM_APT) - 1) < 0.0001 _

-        And Abs(Range(ADV_SUM_CAST) - 1) < 0.0001 _

-        And Abs(Range(ADV_SUM_DIST) - 1) < 0.0001 _

-        Or Range("D13") = 0

-    If Not b Then

-        MsgBox "Не правильно составлен бюджет. Итоговые суммы должны быть = 100%"

-    End If

-    check_Adv = b

-End Function

-

-Function check_budget(r As Range) As Boolean

-    Dim f As Double

-    Dim b As Boolean

-    f = r

-    b = Abs(f - 1#) < 0.0001

-    If Not b Then

-        MsgBox "Не правильно составлен бюджет. Итоговые суммы должны быть = 100%"

-    End If

-    check_budget = b

-End Function

-

-Sub RangeNormalize(Src As Range, Dst As Range)

-    Dim f As Double

-    Dim c As Range

-    f = Dst

-    If f <> 0 Then

-        Src.Worksheet.Unprotect

-        For Each c In Src

-            c = c / f

-        Next c

-        If Not Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") Then

-            Src.Worksheet.Protect

-        End If

-    Else

-        MsgBox "Введите хотя бы одно число!"

-    End If

-End Sub

-

-Sub GoalSeekNow(Goal As Range, Target As Range)

-    Dim diff As Double

-    

-    diff = Goal - 1

-    If Abs(diff) > 0.0001 Then

-        If (diff > 0 And diff < Target) Or (diff < 0 And 1 - Target > Abs(diff)) Then

-            Goal.GoalSeek Goal:=1, ChangingCell:=Range(Target.Address)

-        Else

-            MsgBox "Автоподбор значения не возможен. Выберите другой параметр!"

-        End If

-    End If

-

-End Sub

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100."

-    End If

-End Sub

-

-Sub Check_Number(Target As Range, Def_Val As Double)

-    Dim test As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                test = True

-            End If

-        End If

-    Next r

-    

-    If test Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!"

-    End If

-    

-End Sub

-

-Function is_InputArea(r As Range, LT As Range, RB As Range) As Boolean

-    is_InputArea = r.Column >= LT.Column _

-                And r.Row >= LT.Row _

-                And r.Column <= RB.Column _

-                And r.Row <= RB.Row

-End Function

-

-<<<<<<
-======================
-Sheet70
->>>>>>
-Attribute VB_Name = "Sheet70"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INP_NUM_1_LT As String = "E14"

-Const INP_NUM_1_RB As String = "J14"

-Const INP_NUM_2_LT As String = "E16"

-Const INP_NUM_2_RB As String = "J16"

-Const INP_NUM_3_LT As String = "E18"

-Const INP_NUM_3_RB As String = "J18"

-Const INP_NUM_4_LT As String = "E20"

-Const INP_NUM_4_RB As String = "J20"

-Const INP_NUM_5_LT As String = "E22"

-Const INP_NUM_5_RB As String = "J22"

-

-Const INP_DAT_1_LT As String = "B14"

-Const INP_DAT_1_RB As String = "C14"

-Const INP_DAT_2_LT As String = "B16"

-Const INP_DAT_2_RB As String = "C16"

-Const INP_DAT_3_LT As String = "B18"

-Const INP_DAT_3_RB As String = "C18"

-Const INP_DAT_4_LT As String = "B20"

-Const INP_DAT_4_RB As String = "C20"

-Const INP_DAT_5_LT As String = "B22"

-Const INP_DAT_5_RB As String = "C22"

-

-Const INP_NO As Integer = 0

-Const INP_DAT As Integer = 1

-Const INP_TXT As Integer = 2

-Const INP_NUM As Integer = 3

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("B14").Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Select Case is_InputRange(Target)

-    Case INP_NUM

-        Check_Number Target, 100

-    Case INP_TXT, INP_DAT

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE")

-    

-    If is_InputRange(Target) <> INP_NO Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-

-Function is_InputRange(r As Range) As Integer

-    Dim test As Boolean

-    

-    test = is_InputArea(r, Range(INP_NUM_1_LT), Range(INP_NUM_1_RB)) _

-        Or is_InputArea(r, Range(INP_NUM_2_LT), Range(INP_NUM_2_RB)) _

-        Or is_InputArea(r, Range(INP_NUM_3_LT), Range(INP_NUM_3_RB)) _

-        Or is_InputArea(r, Range(INP_NUM_4_LT), Range(INP_NUM_4_RB)) _

-        Or is_InputArea(r, Range(INP_NUM_5_LT), Range(INP_NUM_5_RB))

-    If test Then

-       is_InputRange = INP_NUM

-    Else

-        test = is_InputArea(r, Range(INP_DAT_1_LT), Range(INP_DAT_1_RB)) _

-            Or is_InputArea(r, Range(INP_DAT_2_LT), Range(INP_DAT_2_RB)) _

-            Or is_InputArea(r, Range(INP_DAT_3_LT), Range(INP_DAT_3_RB)) _

-            Or is_InputArea(r, Range(INP_DAT_4_LT), Range(INP_DAT_4_RB)) _

-            Or is_InputArea(r, Range(INP_DAT_5_LT), Range(INP_DAT_5_RB))

-        If test Then

-            is_InputRange = INP_DAT

-        Else

-            is_InputRange = INP_NO

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-Sheet30
->>>>>>
-Attribute VB_Name = "Sheet30"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet41
->>>>>>
-Attribute VB_Name = "Sheet41"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const MEMBERSHIP As String = "D7"

-Const MILEAGE As String = "D9"

-Const INPUTAREA_LT As String = "C17"

-Const INPUTAREA_RB As String = "E24"

-

-Const ChangeCheckFlag As Boolean = False

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("C17").Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Select Case is_InputRange(Target)

-        Case 1

-            Check_Number Target, 1

-        Case 2

-            Check_Number Target, 15

-        Case 3

-            Check_Number Target, 50

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = True

-    If is_InputRange(Target) <> 0 Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-Function is_InputRange(r As Range) As Integer

-    If r.Column = Range(MEMBERSHIP).Column And r.Row = Range(MEMBERSHIP).Row Then

-        is_InputRange = 1

-    Else

-        If r.Column = Range(MILEAGE).Column And r.Row = Range(MILEAGE).Row Then

-            is_InputRange = 2

-        Else

-            If r.Column >= Range(INPUTAREA_LT).Column _

-                And r.Row >= Range(INPUTAREA_LT).Row _

-                And r.Column <= Range(INPUTAREA_RB).Column _

-                And r.Row <= Range(INPUTAREA_RB).Row Then

-                    is_InputRange = 3

-            Else

-                is_InputRange = 0

-            End If

-        End If

-    End If

-End Function

-

-

-<<<<<<
-======================
-Sheet42
->>>>>>
-Attribute VB_Name = "Sheet42"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INPUTDATE_LT As String = "B11"

-Const INPUTDATE_RB As String = "B25"

-Const INPUTTEXT_LT As String = "C11"

-Const INPUTTEXT_RB As String = "C25"

-Const INPUTNUMB_LT As String = "F11"

-Const INPUTNUMB_RB As String = "I25"

-

-Const INP_NO As Integer = 0

-Const INP_DAT As Integer = 1

-Const INP_TXT As Integer = 2

-Const INP_NUM As Integer = 3

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range(INPUTDATE_LT).Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Select Case is_InputRange(Target)

-    Case INP_NUM

-        Check_Number Target, 100

-    Case INP_TXT, INP_DAT

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = True

-    If is_InputRange(Target) <> 0 Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-Function is_InputRange(r As Range) As Integer

-    If is_InputArea(r, Range(INPUTDATE_LT), Range(INPUTDATE_RB)) Then

-        is_InputRange = INP_DAT

-    Else

-        If is_InputArea(r, Range(INPUTTEXT_LT), Range(INPUTTEXT_RB)) Then

-            is_InputRange = INP_TXT

-        Else

-            If is_InputArea(r, Range(INPUTNUMB_LT), Range(INPUTNUMB_RB)) Then

-                    is_InputRange = INP_NUM

-            Else

-                is_InputRange = INP_NO

-            End If

-        End If

-    End If

-End Function

-

-

-<<<<<<
-======================
-Sheet60
->>>>>>
-Attribute VB_Name = "Sheet60"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INP_DOC_LT As String = "C10"

-Const INP_DOC_RB As String = "C16"

-Const INP_APT_LT As String = "E10"

-Const INP_APT_RB As String = "E16"

-Const INP_CAST_LT As String = "G10"

-Const INP_CAST_RB As String = "G16"

-Const INP_DIST_LT As String = "I10"

-Const INP_DIST_RB As String = "I16"

-Const CAP_DOC As String = "C9"

-Const CAP_APT As String = "E9"

-Const CAP_CAST As String = "G9"

-Const CAP_DIST As String = "I9"

-

-

-Const INP_NO As Integer = 0

-Const INP_CAP As Integer = 1

-Const INP_DOC As Integer = 2

-Const INP_APT As Integer = 3

-Const INP_CAST As Integer = 4

-Const INP_DIST As Integer = 5

-

-Const INP_SUM_CAP As Integer = 11

-Const INP_SUM_DOC As Integer = 12

-Const INP_SUM_APT As Integer = 13

-Const INP_SUM_CAST As Integer = 14

-Const INP_SUM_DIST As Integer = 15

-

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("C9").Select

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim Inp As Integer

-    Dim Addr As String

-    Inp = is_InputRange(Target)

-    Select Case is_InputRange(Target)

-        Case INP_NO

-            Cancel = False

-        

-        Case INP_CAP

-            GoalSeekNow Range(ADV_SUM_CAP), Target

-        

-        Case INP_DOC

-            GoalSeekNow Range(ADV_SUM_DOC), Target

-        

-        Case INP_APT

-            GoalSeekNow Range(ADV_SUM_APT), Target

-        

-        Case INP_CAST

-            GoalSeekNow Range(ADV_SUM_CAST), Target

-        

-        Case INP_DIST

-            GoalSeekNow Range(ADV_SUM_DIST), Target

-        

-        Case INP_SUM_CAP

-            Addr = CAP_DOC & "," & CAP_APT & "," & CAP_CAST & "," & CAP_DIST

-            RangeNormalize Range(Addr), Target

-        

-        Case INP_SUM_DOC

-            Addr = INP_DOC_LT & ":" & INP_DOC_RB

-            RangeNormalize Range(Addr), Target

-        

-        Case INP_SUM_APT

-            Addr = INP_APT_LT & ":" & INP_APT_RB

-            RangeNormalize Range(Addr), Target

-        

-        Case INP_SUM_CAST

-            Addr = INP_CAST_LT & ":" & INP_CAST_RB

-            RangeNormalize Range(Addr), Target

-        

-        Case INP_SUM_DIST

-            Addr = INP_DIST_LT & ":" & INP_DIST_RB

-            RangeNormalize Range(Addr), Target

-    End Select

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Select Case is_InputRange(Target)

-    Case INP_CAP

-        Check_Percent Target, 0.25

-    Case INP_DOC, INP_APT, INP_CAST, INP_DIST

-        Check_Percent Target, 0.15

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE")

-    

-    If is_InputRange(Target) > 0 Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-

-Function is_InputRange(r As Range) As Integer

-    is_InputRange = INP_NO

-    If r.Row = Range(CAP_DOC).Row Then

-        If r.Column = Range(CAP_DOC).Column _

-                Or r.Column = Range(CAP_APT).Column _

-                Or r.Column = Range(CAP_CAST).Column _

-                Or r.Column = Range(CAP_DIST).Column Then

-            is_InputRange = INP_CAP

-        End If

-        If r.Column = Range(ADV_SUM_CAP).Column Then

-            is_InputRange = INP_SUM_CAP

-        End If

-    Else

-        If is_InputArea(r, Range(INP_DOC_LT), Range(INP_DOC_RB)) Then

-            is_InputRange = INP_DOC

-        Else

-            If is_InputArea(r, Range(INP_APT_LT), Range(INP_APT_RB)) Then

-                is_InputRange = INP_APT

-            Else

-                If is_InputArea(r, Range(INP_CAST_LT), Range(INP_CAST_RB)) Then

-                    is_InputRange = INP_CAST

-                Else

-                    If is_InputArea(r, Range(INP_DIST_LT), Range(INP_DIST_RB)) Then

-                        is_InputRange = INP_DIST

-                    Else

-                        If r.Row = Range(ADV_SUM_DOC).Row Then

-                            If r.Column = Range(ADV_SUM_DOC).Column Then

-                                is_InputRange = INP_SUM_DOC

-                            End If

-                            If r.Column = Range(ADV_SUM_APT).Column Then

-                                is_InputRange = INP_SUM_APT

-                            End If

-                            If r.Column = Range(ADV_SUM_APT).Column Then

-                                is_InputRange = INP_SUM_APT

-                            End If

-                            If r.Column = Range(ADV_SUM_CAST).Column Then

-                                is_InputRange = INP_SUM_CAST

-                            End If

-                            If r.Column = Range(ADV_SUM_DIST).Column Then

-                                is_InputRange = INP_SUM_DIST

-                            End If

-                        End If

-                    End If

-                End If

-            End If

-        End If

-    End If

-End Function

-

-

-<<<<<<
-======================
-Sheet50
->>>>>>
-Attribute VB_Name = "Sheet50"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("C9").Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If is_InputRange(Target) Then

-        Check_Percent Target, 0.7

-    End If

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = True

-    If is_InputRange(Target) Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-

-Function is_InputRange(r As Range) As Boolean

-    is_InputRange = r.Column = Range("C9").Column _

-                    And r.Row = Range("C9").Row

-End Function

-

-

-<<<<<<
-======================
-Sheet51
->>>>>>
-Attribute VB_Name = "Sheet51"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INPUTAREA_LT As String = "C17"

-Const INPUTAREA_RB As String = "E20"

-

-Const ChangeCheckFlag As Boolean = False

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("C17").Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If is_InputRange(Target) <> 0 Then

-        Check_Number Target, 50

-    End If

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = True

-    If is_InputRange(Target) <> 0 Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-Function is_InputRange(r As Range) As Integer

-    If is_InputArea(r, Range(INPUTAREA_LT), Range(INPUTAREA_RB)) Then

-        is_InputRange = 3

-    Else

-        is_InputRange = 0

-    End If

-End Function

-

-

-<<<<<<
-======================
-Sheet80
->>>>>>
-Attribute VB_Name = "Sheet80"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INP_DOC As String = "C9"

-Const INP_APT As String = "C11"

-Const INP_CUST As String = "C13"

-Const INP_DIST As String = "C15"

-Const INP_SUM As String = "C17"

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("C9").Select

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    

-    If is_InputRange(Target) Then

-        GoalSeekNow Range(INP_SUM), Target

-    Else

-        If Target.Row = Range(INP_SUM).Row And Target.Column = Range(INP_SUM).Column Then

-            Dim Addr As String

-            

-            Addr = INP_DOC & "," & INP_APT & "," & INP_CUST & "," & INP_DIST

-            RangeNormalize Range(Addr), Target

-            

-        End If

-    End If

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If is_InputRange(Target) Then

-        Check_Percent Target, 0.25

-    End If

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE")

-    

-    If is_InputRange(Target) Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-Function is_InputRange(r As Range) As Boolean

-    is_InputRange = r.Column = Range(INP_DOC).Column _

-                And ( _

-                    r.Row = Range(INP_DOC).Row _

-                    Or r.Row = Range(INP_APT).Row _

-                    Or r.Row = Range(INP_CUST).Row _

-                    Or r.Row = Range(INP_DIST).Row _

-                )

-End Function

-

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Print"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 4

-                        .OnAction = "cmPrint"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-'                With .Controls

-'                    With .Add(msoControlButton)

-'                        .Caption = "&Contents"

-'                        .Style = msoButtonIconAndCaption

-'                        .FaceId = 49

-'                        .OnAction = "cmHelpContents"

-'                    End With

-'                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(Flag As Boolean)

-    If Flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars("Worksheet Menu Bar")

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    dlgAbout.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlgAbout.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlgAbout.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlgAbout.Show

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-        helppath = "hh.exe " & .Path & "\Telfast.chm"

-        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub cmSetStandaloneMode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-    ThisWorkbook.Worksheets("home").Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    rp = common_pwd

-    dlgGetPwd.edPwd = ""

-    dlgGetPwd.Show

-    If dlgGetPwd.edPwd = rp Then

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-    Else

-        cmSetStandaloneMode

-    End If

-    ThisWorkbook.Worksheets("home").Select

-End Sub

-

-

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If Application.Workbooks.Count > 1 Then

-        wbname = Wb.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKCancel, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            Wb.Close Savechanges:=False

-        End If

-        Exit Sub

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub GetState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.Count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.Name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars("Worksheet Menu Bar").Visible = False

-End Sub

-

-

-Public Sub RestoreState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars("Worksheet Menu Bar").Visible = True

-End Sub

-

-

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        cmHelpContents

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Telfast bar"

-Public Const common_pwd As Long = 31415926

-

-

-Sub SetEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    With Application

-        .Caption = PROGRAM_NAME

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .GetState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(HOME_SHEET).Select

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                     cWindow.DisplayHeadings = True

-                Next

-            End If

-        Next

-        .Worksheets(HOME_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu (True)

-        End If

-        With mobjAppState

-            .RestoreState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{6B54EA33-E5D1-44C0-BC3C-E5960329B246}{639FA6FC-FBAC-44B4-ACC5-7DAF95DA47F4}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    

-    dlgPrint.cbMainReport = True

-    dlgPrint.cbMainBudget = False

-    dlgPrint.cbSrcData = False

-    dlgPrint.cbAllSheets = False

-    

-    dlgPrint.Show

-    

-    If dlgPrint.Tag = vbCancel Then

-        Exit Sub

-    End If

-    

-    Dim PrnIdx As Integer

-    

-    With dlgPrint

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("home", "budget", "Final")

-    Case 1111

-        plist = Array("home", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("home")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-dlgFname
->>>>>>
-Attribute VB_Name = "dlgFname"

-Attribute VB_Base = "0{AB4D9ABD-F40E-4C39-8FE4-0625E69E5365}{2CC3E532-33AC-44D8-9195-34917AF21E8C}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btOK_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Sub Macro1()

-Attribute Macro1.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute Macro1.VB_ProcData.VB_Invoke_Func = " \n14"

-'

-' Macro1 Macro

-' Macro recorded 25.09.2003 by nick

-'

-

-'

-    Charts.Add

-    ActiveChart.ChartType = xlBubble

-    ActiveChart.SetSourceData Source:=Sheets("file1").Range("H2:J11"), PlotBy:= _

-        xlColumns

-    ActiveChart.Location Where:=xlLocationAsObject, Name:="file1"

-    With ActiveChart

-        .HasTitle = True

-        .ChartTitle.Characters.Text = "Матрица"

-        .Axes(xlCategory, xlPrimary).HasTitle = True

-        .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Доля клексана"

-        .Axes(xlValue, xlPrimary).HasTitle = True

-        .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Количество больных"

-    End With

-    With ActiveChart.Axes(xlCategory)

-        .HasMajorGridlines = True

-        .HasMinorGridlines = False

-    End With

-    With ActiveChart.Axes(xlValue)

-        .HasMajorGridlines = True

-        .HasMinorGridlines = False

-    End With

-    ActiveChart.HasLegend = False

-    ActiveChart.ApplyDataLabels Type:=xlDataLabelsShowValue, LegendKey:=False

-    ActiveChart.SeriesCollection(1).Select

-    ActiveChart.SeriesCollection(1).DataLabels.Select

-    ActiveChart.SeriesCollection(1).Select

-    ActiveChart.SeriesCollection(1).DataLabels.Select

-    ActiveChart.SeriesCollection(1).Points(9).DataLabel.Select

-    Selection.Characters.Text = "8379 №1"

-    Selection.AutoScaleFont = False

-    With Selection.Characters(Start:=1, Length:=7).Font

-        .Name = "Arial"

-        .FontStyle = "Обычный"

-        .Size = 10

-        .Strikethrough = False

-        .Superscript = False

-        .Subscript = False

-        .OutlineFont = False

-        .Shadow = False

-        .Underline = xlUnderlineStyleNone

-        .ColorIndex = xlAutomatic

-    End With

-    ActiveChart.Axes(xlValue).MajorGridlines.Select

-End Sub

-Sub Macro2()

-Attribute Macro2.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute Macro2.VB_ProcData.VB_Invoke_Func = " \n14"

-'

-' Macro2 Macro

-' Macro recorded 25.09.2003 by nick

-'

-

-'

-    Application.CutCopyMode = False

-    With ActiveChart.ChartGroups(1)

-        .VaryByCategories = True

-        .ShowNegativeBubbles = False

-        .SizeRepresents = xlSizeIsArea

-        .BubbleScale = 100

-    End With

-End Sub

-Sub Macro3()

-Attribute Macro3.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute Macro3.VB_ProcData.VB_Invoke_Func = " \n14"

-'

-' Macro3 Macro

-' Macro recorded 25.09.2003 by nick

-'

-

-'

-    ActiveChart.SeriesCollection(1).DataLabels.Select

-    ActiveChart.SeriesCollection(1).Points(6).DataLabel.Select

-    ActiveChart.Axes(xlValue).MajorGridlines.Select

-    ActiveChart.SeriesCollection(1).DataLabels.Select

-    ActiveChart.SeriesCollection(1).Points(6).DataLabel.Select

-    Selection.Characters.Text = "9847 №2"

-    Selection.AutoScaleFont = False

-    With Selection.Characters(Start:=1, Length:=7).Font

-        .Name = "Arial"

-        .FontStyle = "Обычный"

-        .Size = 12

-        .Strikethrough = False

-        .Superscript = False

-        .Subscript = False

-        .OutlineFont = False

-        .Shadow = False

-        .Underline = xlUnderlineStyleNone

-        .ColorIndex = xlAutomatic

-    End With

-    ActiveChart.PlotArea.Select

-End Sub

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Private Sub Workbook_Open()

-    xlRestoreView

-End Sub

-

-Sub xlRestoreView()

-    Application.CommandBars("Standard").Visible = True

-    Application.CommandBars("Formatting").Visible = True

-    Application.DisplayFormulaBar = True

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'ClexanePM'
-Quirk - duff tag length======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-

-    Application.EnableEvents = True

-    Set MyAppEvents.app = Application

-    

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    

-    MyAppEvents.CheckWorkBooksArround ThisWorkbook

-    

-    cmSetStandaloneMode

-    

-    Application.ScreenUpdating = True

-'    CheckUser

-

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).Select

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).update_history

-    Application.Calculate

-

-End Sub

-

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    

-    Dim RestMode As Boolean

-    RestMode = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE")

-    

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-'        If RestMode Then

-            ThisWorkbook.Saved = True

-'        Else

-'            ThisWorkbook.Save

-'        End If

-    End If

-    If RestMode Then

-        xlRestoreView

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    End If

-    Application.Caption = Empty

-    Application.CommandBars(STDBAR_NAME).Reset

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-    Dim MaxX, MaxY As Integer

-    With ThisWorkbook.Worksheets(TITLE_SHEET)

-        MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-        MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-    End With

-

-    With ThisWorkbook.Application

-        .ScreenUpdating = False

-        .WindowState = xlNormal

-        .Height = MaxY

-        .Width = MaxX

-    End With

-End Sub

-

-

-

-

-

-<<<<<<
-======================
-REP_QTR
->>>>>>
-Attribute VB_Name = "REP_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CQTR_QT As Integer = 0

-Const CQTR_ID As Integer = 1

-Const CQTR_PLN As Integer = 2

-Const CQTR_FCT As Integer = 3

-Const CQTR_BDG As Integer = 4

-Const CQTR_CNT As Integer = 5

-Const CQTR_BEDS As Integer = 6

-Const CQTR_HIR As Integer = 7

-Const CQTR_TER As Integer = 8

-Const CQTR_CRD As Integer = 9

-Const CQTR_CLXN_BDG As Integer = 10

-Const CQTR_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Const LOCAL_ENT_DATE As String = "QTR_SEL"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("REP_QTR")

-        s = .Range("D5") & " " & .Range("D4") & ", " & .Range("H5") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub update_history()

-    Dim objQTR() As tQTR

-    Dim i As Long

-    Dim r As Range

-    Dim cRep As tREPID

-    Dim rm_id As Long

-

-    rm_id = Range("RM_ID")

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    Range("D4") = cRep.LastName

-    Range("D5") = cRep.FirstName

-

-    Range("H4") = GetRegionName(cRep.Region)

-    Range("H5") = GetCityName(cRep.Region, cRep.City)

-

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetAll_QTR_Records_by_REP(objQTR, "%", cRep.rep_id, rm_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CQTR_QT) = objQTR(i).entry_date

-        Next i

-    End If

-    Dim qcd() As tQTR_COMMON

-    i = Get_QTR_CommonList_by_REP(qcd, "%", cRep.rep_id, rm_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(qcd)

-            r.Offset(i - 1, CQTR_QT) = qcd(i).qtr.entry_date

-            r.Offset(i - 1, CQTR_ID) = qcd(i).qtr.id

-            r.Offset(i - 1, CQTR_PLN) = qcd(i).qtr.sale_PLAN

-            r.Offset(i - 1, CQTR_FCT) = qcd(i).c_sale_ALL

-            r.Offset(i - 1, CQTR_BDG) = qcd(i).c_bdgt_LPU

-            r.Offset(i - 1, CQTR_CNT) = qcd(i).i_lcd

-            r.Offset(i - 1, CQTR_BEDS) = qcd(i).c_beds

-            r.Offset(i - 1, CQTR_HIR) = qcd(i).c_pat_HIR

-            r.Offset(i - 1, CQTR_TER) = qcd(i).c_pat_TER

-            r.Offset(i - 1, CQTR_CRD) = qcd(i).c_pat_CRD

-            If qcd(i).c_bdgt_LPU <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_BDG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_LPU

-            End If

-            If qcd(i).c_bdgt_NMG <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_NMG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CQTR_CRD + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-

-Sub Draw_PLN_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_FCT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PLN_QTR").Range("title") = MakeChartTitle

-End Sub

-

-Sub Draw_BDGT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_CLXN_NMG + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_BDGT_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Public Sub cbxRepQtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CQTR_ID + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    i = currRange.Column - Range(CINP_AREA).Column

-

-    QTR_ID = r

-

-    If QTR_ID = 0 Then

-        Worksheets(VAR_SHEET).Range("USER_ACTION") = 1

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        If i > CQTR_FCT Then

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-            Range("LAST_FOCUS") = currRange.address

-        Else

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 3

-            Range("LAST_FOCUS") = currRange.address

-        End If

-    End If

-    Cancel = True

-    btHomeDo_IT

-End Sub

-

-<<<<<<
-======================
-mRep_QTR
->>>>>>
-Attribute VB_Name = "mRep_QTR"

-Option Explicit

-

-Sub NoFunc()

-    MsgBox "Функция не доступна", vbOKOnly, PROGRAM_NAME

-End Sub

-

-Sub DO_Price_qtr(ent_date As String)

-    Dim qtr As tQTR

-    Dim res As Integer

-    Dim cRep As tREPID

-    Dim rm_id As Long

-

-    rm_id = Worksheets(REP_QTR_SHEET).Range("RM_ID")

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    qtr = Get_QTR_Record_by_REP(ent_date, cRep.rep_id, cRep.rm_id)

-

-    If qtr.id = 0 Then

-        qtr.entry_date = ent_date

-

-        With Worksheets(VAR_SHEET)

-            qtr.ClxnH20mg = .Range("ClxnH20mg")

-            qtr.ClxnH40mg = .Range("ClxnH40mg")

-            qtr.ClxnT40mg = .Range("ClxnT40mg")

-            qtr.ClxnC_ACS = .Range("ClxnC_ACS")

-            qtr.ClxnC_IM = .Range("ClxnC_IM")

-        End With

-    End If

-

-    Dim dlg_nq As dlg_nextQTR

-    Set dlg_nq = New dlg_nextQTR

-

-    With dlg_nq

-        .tb_qtr_name = qtr.entry_date

-        .tb_bdgt_avts = qtr.sale_PLAN

-        .tb_qtr_name = qtr.entry_date

-        .tb_ClxnH20mg = qtr.ClxnH20mg

-        .tb_ClxnH40mg = qtr.ClxnH40mg

-        .tb_ClxnT40mg = qtr.ClxnT40mg

-        .tb_ClxnC_ACS = qtr.ClxnC_ACS

-        .tb_ClxnC_IM = qtr.ClxnC_IM

-    End With

-

-    dlg_nq.Show

-End Sub

-

-Sub DO_Edit_qtr(ent_date As String)

-    If ent_date = "" Then

-        NoFunc

-    Else

-        Dim rep_id As Long

-        rep_id = Worksheets(REP_QTR_SHEET).Range("REP_ID")

-        With ThisWorkbook.Worksheets("LPU_LIST")

-            .Range("VIEW_ONLY") = True

-            .setEnt_date (ent_date)

-            .Range("REP_ID") = rep_id

-            .Select

-        End With

-    End If

-End Sub

-

-Sub DO_Delete_qtr(ent_date As String)

-    If ent_date <> "" Then

-        MsgBox "Удалить данные за период [" & ent_date & "] нельзя ", vbOKOnly, PROGRAM_NAME

-    End If

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-

-Sub btHomeDo_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    idx = Worksheets(VAR_SHEET).Range("USER_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).getEnt_date()

-    Select Case idx

-        Case 1

-            NoFunc

-            ' Обновляем экран

-        Case 2

-            DO_Edit_qtr ent_date

-        Case 3

-            DO_Price_qtr ent_date

-        Case 4

-            NoFunc

-    End Select

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-Sub Delete_qtr()

-'    Dim ent_date As String

-'    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-'    DO_Delete_qtr ent_date

-End Sub

-

-Sub btREP_QTR_RET_IT()

-    Dim s As String

-    With Worksheets("REP_QTR")

-        .Range("LAST_FOCUS") = ""

-        s = .Range("ret_addr")

-        .Range("ret_addr") = ""

-    End With

-    If s <> "" Then

-        ThisWorkbook.Worksheets(s).Select

-    Else

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public ppReport As New cPPReport

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane[PM]"

-Public Const PROGRAM_VERSION As String = "Clexane[PM] ver 1.1"

-Public Const PROGRAM_FILENAME As String = "clexane-pm"

-Public Const PROGRAM_BACKUPNAME As String = "pm-backup-"

-Public Const PROGRAM_EXPORTNAME As String = "pm-ex-"

-Public Const PROGRAM_IMPORTNAME As String = "rm-ex*"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-Public Const CHART_DEF_TITLE As String = "* * *"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20031207

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "O41"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-Public Const RM_QTR_SHEET As String = "RM_QTR"

-Public Const PRJ_QTR_SHEET As String = "PRJ_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-Function time_correct(end_date As Long, ByVal theDate As Date) As Boolean

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-    If end_date = NO_ESTIMATION_DATE Then

-        time_correct = True

-        Exit Function

-    End If

-    

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    

-    time_correct = CurDate <= end_date

-    

-End Function

-

-Sub EnableRun(end_date As Long)

-    If Not time_correct(end_date, Now) Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-Sub t()

-    EnableRun ESTIMATION_DATE

-End Sub

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Sub OpenPPT()

-    ppReport.ReportView

-End Sub

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-

-End Sub

-

-Function Double2Str(ByVal d As Double, ByVal precision As Integer, Optional Delim As String = ".") As String

-    Dim s As String

-    If Not precision > 0 Then

-        s = Round(d)

-    Else

-        Dim i As Integer

-        i = Fix(d)

-        s = i & Delim

-        d = Abs(d - i)

-        Do

-            precision = precision - 1

-            d = d * 10

-            If precision > 0 Then

-                i = Fix(d)

-            Else

-                i = Round(d)

-            End If

-            If i < 1 Then

-                s = s & "0"

-            Else

-                s = s & i

-                d = d - i

-            End If

-        Loop While precision > 0

-    End If

-    Double2Str = s

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetWBName(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBName = Right(FullName, s_len - pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.Name = VAR_SHEET Or sh.Name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-<<<<<<
-======================
-Var
->>>>>>
-Attribute VB_Name = "Var"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-title
->>>>>>
-Attribute VB_Name = "title"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LPU_LIST
->>>>>>
-Attribute VB_Name = "LPU_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Const LOCAL_ENT_DATE As String = "C10"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Function getCurrentLPU_ID() As Long

-    Dim r As Range

-

-    With Worksheets("LPU_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CLPU_ID)

-    End With

-

-    getCurrentLPU_ID = r

-End Function

-

-Public Sub LPU_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectLPU_NAME(lpu_id As Long, ent_date As String)

-    SelectLPU_BDGT lpu_id, ent_date

-End Sub

-

-Sub SelectLPU_BDGT(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    If lpu_id = 0 Then

-        SelectLPU_NAME lpu_id, ent_date

-    Else

-        With ThisWorkbook.Worksheets("LPU_BDGT")

-            .Range("VIEW_ONLY") = vo

-            .Range("ret_addr") = "LPU_LIST"

-            .setEnt_date (ent_date)

-            .Range("lpu_id") = lpu_id

-            .Range("REP_ID") = rep_id

-            .Range("RM_ID") = rm_id

-        End With

-    End If

-End Sub

-

-Sub SelectLPU_HIR(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_HIR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .setEnt_date (ent_date)

-        .Range("lpu_id") = lpu_id

-        .Range("REP_ID") = rep_id

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Sub SelectLPU_TER(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_TER")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .setEnt_date (ent_date)

-        .Range("lpu_id") = lpu_id

-        .Range("REP_ID") = rep_id

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Sub SelectLPU_C_ACS(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_C_ACS")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .setEnt_date (ent_date)

-        .Range("RM_ID") = rm_id

-        .Range("REP_ID") = rep_id

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateLPUList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim lpu_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CINP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CINP_AREA).row, CLPU_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    lpu_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CINP_AREA).Column

-

-    If lpu_id = 0 Then

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    End If

-

-    If lpu_id = 0 Then

-        i = CLPU_NAME

-        Range("JUMP") = ""

-    End If

-    Select Case i

-        Case CLPU_NAME, CLPU_NAME1, CLPU_NAME2, CLPU_BEDS

-            SelectLPU_NAME lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-

-        Case CLPU_NMG, CLPU_NFG, CLPU_PLAN, CLPU_FACT

-            SelectLPU_BDGT lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-

-        Case CLPU_HIR

-            SelectLPU_HIR lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_HIR"

-

-        Case CLPU_TER

-            SelectLPU_TER lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_TER"

-

-        Case CLPU_CAR

-            SelectLPU_C_ACS lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        Case Else

-            Range("JUMP") = ""

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateLPUList()

-    Dim lcd() As tLPU_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-    Dim objQTR As tQTR

-    Dim cRep As tREPID

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    ent_date = getEnt_date

-

-'     ent_date = "%" ' % - all records

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id, cRep.rm_id)

-    i = Get_LPU_CommonQTR(lcd, objQTR)

-

-'     стираем ФИО

-    Range("C3:C4").ClearContents

-

-    Range("C3") = cRep.LastName

-    Range("C4") = cRep.FirstName

-    Range("G3") = GetRegionName(cRep.Region)

-    Range("G4") = GetCityName(cRep.Region, cRep.City)

-    Range("G5") = objQTR.sale_PLAN

-

-

-

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(lcd)

-            r.Offset(i - 1, CLPU_NAME) = lcd(i).lpu.Name

-            r.Offset(i - 1, CLPU_ID) = lcd(i).lpu.id

-            r.Offset(i - 1, CLPU_BEDS) = lcd(i).lpu.beds

-

-

-            r.Offset(i - 1, CLPU_NFG) = lcd(i).bdgt.bdgt_NFG

-            r.Offset(i - 1, CLPU_NMG) = lcd(i).bdgt.bdgt_NMG

-            r.Offset(i - 1, CLPU_PLAN) = lcd(i).bdgt.sale_PLAN

-

-            r.Offset(i - 1, CLPU_HIR) = lcd(i).pat_HIR

-            r.Offset(i - 1, CLPU_TER) = lcd(i).pat_TER

-            r.Offset(i - 1, CLPU_CAR) = lcd(i).pat_CRD

-            r.Offset(i - 1, CLPU_FACT) = lcd(i).sale_ALL

-            r.Offset(i - 1, CLPU_PAT_LPU) = lcd(i).pat_LPU

-            r.Offset(i - 1, CLPU_BDGT) = lcd(i).bdgt_LPU

-            If lcd(i).bdgt_LPU > 0 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = lcd(i).sale_ALL / lcd(i).bdgt_LPU

-            End If

-            If r.Offset(i - 1, CLPU_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{32FB0F3D-6884-41DC-99DB-E2C55B2257C4}{DED79A66-DA60-4CCC-9003-082480235D55}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-dbACS
->>>>>>
-Attribute VB_Name = "dbACS"

-Option Explicit

-

-Public Type tACS

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    patients_with_geparins As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objACS.ID <> 0 then updatre else insert

-Sub Insert_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objACS.id <> 0 Then

-        dbUpdate_ACS_Record dbConnection, objACS

-    Else

-        dbInsert_ACS_Record dbConnection, objACS

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_ACS_RecordsByLPU_ID(ByRef all_ACS_() As tACS, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_ACS_RecordsByLPU_ID = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, all_ACS_, lpu_id, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_ACS_Record dbConnection, objACS

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub dbInsert_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_acs", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objACS

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("patients_with_geparins") = .patients_with_geparins

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objACS.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim Update_SQL As String

-    

-    With objACS

-        Update_SQL = "UPDATE lpu_acs SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "patients_with_geparins=" & .patients_with_geparins & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_ACS_RecordsbyLPU_ID(dbConnection As Object, all_ACS() As tACS, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_ACS_SQL As String

-    Dim getAll_ACS_SQL As String

-    Dim ACS_Count As Long

-    ACS_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    Else

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_ACS_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        ACS_Count = dbRecordset("ACS_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_ACS_RecordsbyLPU_ID = ACS_Count

-    

-    If ACS_Count > 0 Then

-        'we have records

-        ReDim all_ACS(1 To ACS_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_ACS_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_ACS As tACS

-                 With tmp_ACS

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .patients_with_geparins = dbRecordset("patients_with_geparins")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 all_ACS(index) = tmp_ACS

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE ID=" & objACS.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_ACS_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_HIR
->>>>>>
-Attribute VB_Name = "LPU_CLSN_HIR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const LOCAL_ENT_DATE As String = "S38"

-

-Sub PrintCopy()

-    Range("A1:M26").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-

-        Dim objHir As tHIRURGIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objHir

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .operations_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L9")

-                .patients_ambulator_clexan_20mg = Range("L10")

-                .patients_ambulator_clexan_40mg = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L19")

-                .patients_stationar_clexan_20mg = Range("L20")

-                .patients_stationar_clexan_40mg = Range("L21")

-            End With

-            Insert_Hir_Record objHir

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objHir.id = Range("rec_id")

-                    If objHir.id <> 0 Then

-                        Delete_Hir_Record objHir

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-End Sub

-

-Sub SetupData(objHir As tHIRURGIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    With objHir

-        Range("rec_id") = .id

-        Range("F6") = .operations_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L9") = .patients_ambulator_clexan

-        Range("L10") = .patients_ambulator_clexan_20mg

-        Range("I21") = .patients_stationar_nmg

-        Range("L19") = .patients_stationar_clexan

-        Range("L20") = .patients_stationar_clexan_20mg

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id, cRep.rm_id)

-

-        formula = "=" & qtr.ClxnH20mg & "*($L$10+$L$20)+" & qtr.ClxnH40mg & "*($L$11+$L$21)"

-        Range("F11").formula = formula

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id, Range("RM_ID"))

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.Name

-        Range("lpu_addr") = lpu.address

-

-        Dim objHir() As tHIRURGIA

-        Dim i As Integer

-        i = GetAll_Hir_RecordsByLPU_ID(objHir, id, Range("ent_date"), Range("RM_ID"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.3

-        Else

-            SetupData objHir(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-mSapes
->>>>>>
-Attribute VB_Name = "mSapes"

-Option Explicit

-

-Const SHAPE_COLOR As Integer = 1

-Const SHAPE_NAME As Integer = 2

-

-

-Sub ShapeView(r_sh_finite_state As Range)

-    Dim chk As Range

-    Dim s As String

-    Dim c, idx As Integer

-    For Each chk In r_sh_finite_state

-        idx = 0

-        If chk = "+" Then

-            c = chk.Offset(0, idx + SHAPE_COLOR)

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While c <> 0

-                ShapeFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s)), c

-                idx = idx + 2

-                c = chk.Offset(0, idx + SHAPE_COLOR)

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        Else

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While s <> ""

-                ShapeUnFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s))

-                idx = idx + 2

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        End If

-    Next chk

-End Sub

-

-Sub ShapeFill(sh As ShapeRange, ByVal color As Integer)

-    sh.Fill.Visible = msoTrue

-    sh.Fill.Solid

-    sh.Fill.ForeColor.SchemeColor = color

-    sh.Fill.Transparency = 0#

-End Sub

-

-Sub ShapeUnFill(sh As ShapeRange)

-    sh.Fill.Visible = msoFalse

-    sh.Fill.Transparency = 0#

-End Sub

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Public Const INPUT_NO = 0

-Public Const INPUT_NUMBER = 1

-Public Const INPUT_PERCENT = 2

-Public Const INPUT_STRING = 3

-Public Const INPUT_CHECK = 4

-

-Public Const INP_IDX_TYPE = 1

-Public Const INP_IDX_NEXT = 2

-Public Const INP_IDX_MIN = 3

-Public Const INP_IDX_MAX = 4

-Public Const INP_IDX_DEP = 5

-Public Const INP_IDX_ALT = 7

-

-

-Public Type tInputSet

-    vType As Integer

-    vMin As Long

-    vMax As Long

-    rChk As String

-End Type

-

-Function is_input_cell(ByVal Target As Range, inputs As Range) As tInputSet

-    Dim t As Range

-    Dim iset As tInputSet

-    Dim test As Range

-    iset.vType = INPUT_NO

-    iset.vMin = 0

-    iset.vMax = 0

-    iset.rChk = ""

-    is_input_cell = iset

-

-' Закоментировать следующую сточку для работы

-'  Exit Function

-

-    Set test = Target.Cells(1, 1)

-    For Each t In inputs

-        If Range(t).Column = test.Column And Range(t).row = test.row Then

-            iset.vType = t.Offset(0, INP_IDX_TYPE).Value

-            Select Case iset.vType

-                Case INPUT_CHECK

-                    iset.rChk = t.Offset(0, INP_IDX_ALT)

-                Case INPUT_NUMBER, INPUT_PERCENT

-                    iset.vMin = t.Offset(0, INP_IDX_MIN).Value

-                    iset.vMax = t.Offset(0, INP_IDX_MAX).Value

-            End Select

-            is_input_cell = iset

-            Exit Function

-        End If

-    Next t

-End Function

-

-Function GetFocusAddress(ByVal r As Range, f_next As Range) As String

-    Dim chk, t As Range

-    

-    For Each chk In f_next

-        For Each t In r

-            If t.address = chk Then

-                GetFocusAddress = chk

-                Exit Function

-            End If

-            If Range(chk).Column = t.Column - 1 And Range(chk).row = t.row _

-            Or Range(chk).Column = t.Column And Range(chk).row = t.row - 1 _

-            Then

-                If Range(chk) <> "" Then

-                    If Range(chk) = 0 Then

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_ALT)).address

-                    Else

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_NEXT)).address

-                    End If

-                Else

-                    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-                End If

-                Exit Function

-            End If

-        Next t

-    Next chk

-    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-End Function

-

-Sub SetDependet(r As Range, inputs As Range)

-    Dim chk As Range

-    Dim s, serr As String

-    Dim idx As Integer

-    Dim iset As tInputSet

-    Dim err_found As Boolean

-    

-    If r.count > 1 Then

-        Exit Sub

-    End If

-    

-    err_found = False

-    For Each chk In inputs

-        idx = INP_IDX_DEP

-        

-        

-        iset.vType = chk.Offset(0, INP_IDX_TYPE).Value

-        Select Case iset.vType

-            Case INPUT_NUMBER, INPUT_PERCENT

-                iset.vMin = chk.Offset(0, INP_IDX_MIN).Value

-                iset.vMax = chk.Offset(0, INP_IDX_MAX).Value

-                

-                If Range(chk) > iset.vMax Then

-                    err_found = True

-                    Range(chk) = iset.vMax

-                    serr = "Выход за дозволенный диапазон [" & iset.vMin & ".." & iset.vMax & "]! Данные скорректированы."

-                End If

-                

-                If Range(chk) = "" Then

-                    s = chk.Offset(0, idx)

-                    Do While s <> ""

-                        Range(s) = ""

-                        idx = idx + 1

-                        s = chk.Offset(0, idx)

-                    Loop

-                End If

-        End Select

-    Next chk

-    If err_found Then

-        MsgBox serr, vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Function CheckInputData(inputs As Range) As Boolean

-    Dim r As Range

-    

-    CheckInputData = True

-    For Each r In inputs

-        If Range(r) = "" Then

-            CheckInputData = False

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100.", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Sub Check_Int_Number(Target As Range, Def_Val As Long)

-    Dim err As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    err = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                err = True

-            End If

-        End If

-    Next r

-    If err Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_TER
->>>>>>
-Attribute VB_Name = "LPU_CLSN_TER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const LOCAL_ENT_DATE As String = "S38"

-

-Sub PrintCopy()

-    Range("A1:M26").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim objTer As tTERAPIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objTer

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .patients_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L20")

-            End With

-            Insert_Ter_Record objTer

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objTer.id = Range("rec_id")

-                    If objTer.id <> 0 Then

-                        Delete_Ter_Record objTer

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-

-End Sub

-

-Sub SetupData(objTer As tTERAPIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    With objTer

-        Range("rec_id") = .id

-        Range("F6") = .patients_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L11") = .patients_ambulator_clexan

-        Range("I21") = .patients_stationar_nmg

-        Range("L20") = .patients_stationar_clexan

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id, cRep.rm_id)

-        formula = "=" & qtr.ClxnT40mg & "*($L$12+$L$20)"

-        Range("F11").formula = formula

-

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id, Range("RM_ID"))

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.Name

-        Range("lpu_addr") = lpu.address

-

-        Dim objTer() As tTERAPIA

-        Dim i As Integer

-        i = GetAll_Ter_RecordsByLPU_ID(objTer, id, Range("ent_date"), Range("RM_ID"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.25

-        Else

-            SetupData objTer(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{0DC9E035-CE0A-49FF-85A2-A4EC5FF8FE96}{D54DDC8A-1EE2-4BB3-8B94-343B521AF098}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-LPU_BDGT
->>>>>>
-Attribute VB_Name = "LPU_BDGT"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const LOCAL_ENT_DATE As String = "S15"

-

-Sub PrintCopy()

-    Range("B1:K21").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Sub SetDefFocus()

-    Range(Range("DEF_FOCUS")).Select

-End Sub

-

-Public Sub ClearData()

-    ClearSheetData

-End Sub

-

-Sub ClearSheetData()

-    If Range("F10") = 0 And Range("F13") = 0 Then

-        Range("F11:F18") = ""

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("F11:F13") = ""

-    End If

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim bdgt As tBUDGET

-        Dim sum As Long

-        Dim test As Boolean

-        With bdgt

-            .lpu_id = Range("lpu_id")

-            .id = Range("rec_id")

-            .entry_date = Range("ent_date")

-            .bdgt_NMG = Round(Range("F11").Value, 0)

-            .bdgt_NFG = Round(Range("F12").Value, 0)

-            .sale_PLAN = Round(Range("F13").Value, 0)

-

-            sum = .bdgt_NFG + .bdgt_NMG - .sale_PLAN

-            test = .bdgt_NFG <> 0 Or .bdgt_NMG <> 0 Or .sale_PLAN <> 0

-        End With

-        If test Then

-            If sum < 0 Then

-                MsgBox _

-                    "Ваш план превышает выделенный на гепарины бюджет. Сохранить данные?", _

-                    vbOKOnly, PROGRAM_NAME

-            End If

-            If test Then

-                Insert_BDGT_Record bdgt

-            End If

-        Else

-            If bdgt.id <> 0 Then

-                If vbYes = MsgBox("Удалить данные из базы!", vbYesNo, PROGRAM_NAME) Then

-                    Delete_BDGT_Record bdgt

-                End If

-                ret_back Range("DEF_FOCUS").Worksheet

-                Exit Sub

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-    End If

-

-   ClearData

-   ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(cLPU As tLPU_COMMON)

-    Dim t_sum As Long

-    t_sum = 0

-' Setup budget data

-    Range("F11") = cLPU.bdgt.bdgt_NMG

-    Range("F12") = cLPU.bdgt.bdgt_NFG

-    Range("F13") = cLPU.bdgt.sale_PLAN

-

-    With cLPU

-        Range("F14") = .pat_ALL

-        Range("F15") = .pat_HIR

-        Range("F16") = .pat_TER

-        Range("F17") = .pat_CRD

-        Range("F18") = .sale_ALL

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    ws_activate

-End Sub

-

-

-Sub ws_activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Dim cLPU As tLPU_COMMON

-    Dim objQTR As tQTR

-    Dim objLPU As tLPU

-    Dim ent_date As String

-    Dim id As Long

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"), Range("RM_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    id = Range("lpu_id").Value

-    ent_date = Range("ent_date")

-    

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id, cRep.rm_id)

-

-    objLPU = Get_LPU_Record(id, Range("RM_ID"))

-    Get_LPU_Common cLPU, objLPU, objQTR

-

-    If cLPU.lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = cLPU.lpu.beds

-        Range("lpu_name") = cLPU.lpu.Name

-        Range("lpu_addr") = cLPU.lpu.address

-        Range("rec_id") = cLPU.bdgt.id

-

-        SetupData cLPU

-

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-'    MsgBox Target.address

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case INPUT_CHECK

-

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{BFB4547C-96A7-4739-AA0A-CEF1E35E2BDC}{C3D618A3-9410-4BC7-9D93-3B049D361132}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mSheets
->>>>>>
-Attribute VB_Name = "mSheets"

-Option Explicit

-

-Function am_load_now() As Boolean

-    am_load_now = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE")

-End Function

-

-Sub Wks_select(RetSheet As String)

-    Dim sheet As Worksheet

-    For Each sheet In ThisWorkbook.Worksheets

-        If sheet.Name = RetSheet Then

-            ThisWorkbook.Worksheets(RetSheet).Select

-            Exit Sub

-        End If

-    Next sheet

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub ret_back(sh As Worksheet)

-    Dim RetSheet As String

-    RetSheet = sh.Range("ret_addr")

-    sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    sh.Range("rec_id") = ""

-    sh.Range("lpu_id") = ""

-    sh.Range("ent_date") = ""

-    sh.Range("lpu_name") = ""

-    sh.Range("lpu_addr") = ""

-    sh.Range("lpu_beds") = ""

-    Wks_select RetSheet

-    sh.Range("ret_addr") = ""

-End Sub

-

-Sub ClearSheetData(r_start As Range)

-    If r_start <> "" Then

-        r_start.Worksheet.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        r_start = ""

-    Else

-        ret_back r_start.Worksheet

-    End If

-End Sub

-

-Sub wks_sel_chng(iset As tInputSet, ByVal Target As Range, sh As Worksheet)

-    Dim DebugMode As Boolean

-    Dim in_range As Range

-    

-    DebugMode = Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-

-    If DebugMode Then

-        sh.Unprotect

-    Else

-        sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    End If

-

-    If iset.vType = INPUT_CHECK Then

-        Set in_range = Target.Worksheet.Range(iset.rChk)

-    Else

-        Set in_range = Target

-    End If

-    

-    Dim str As String

-    str = GetFocusAddress(in_range, sh.Range("h_inputs"))

-

-'    MsgBox Target.Address & "; " & str

-    If str <> Target.address Then

-        sh.Range(str).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-Dlg_lpu_card
->>>>>>
-Attribute VB_Name = "Dlg_lpu_card"

-Attribute VB_Base = "0{9AAD262F-A6C4-4912-9C58-D7A2071181B8}{9470F4EB-DA9F-4584-9159-D09319548D21}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbLPU_List_Change()

-    Dim src As Range

-    Dim idx_src As Integer

-    

-    Set src = Worksheets(VAR_SHEET).Range(Me.cbLPU_List.RowSource)

-    idx_src = Me.cbLPU_List.ListIndex + 1

-    Me.tb_lpu_name.Text = src.Cells(idx_src, 1)

-    Me.tb_lpu_address.Text = src.Cells(idx_src, 2)

-    Me.tbBedsCount.Text = src.Cells(idx_src, 3)

-End Sub

-

-

-Private Sub cbxLPU_List_Enable_Click()

-    

-    If Me.cbxLPU_List_Enable Then

-        

-        Me.tb_lpu_name.Text = ""

-        Me.tb_lpu_name.Enabled = False

-        

-        Me.tb_lpu_address.Text = ""

-        Me.tb_lpu_address.Enabled = False

-        

-        Me.tbBedsCount.Text = ""

-        Me.tbBedsCount.Enabled = False

-        

-        Me.cbLPU_List.Enabled = True

-        cbLPU_List_Change

-    Else

-        Me.tb_lpu_name.Enabled = True

-        Me.tb_lpu_name.Text = ""

-        

-        Me.tb_lpu_address.Enabled = True

-        Me.tb_lpu_address.Text = ""

-        

-        Me.tbBedsCount.Enabled = True

-        Me.tbBedsCount.Text = ""

-        

-        Me.cbLPU_List.Enabled = False

-    End If

-End Sub

-

-<<<<<<
-======================
-UserInfo
->>>>>>
-Attribute VB_Name = "UserInfo"

-Attribute VB_Base = "0{A8FBEE9C-DE59-49DE-971D-07BC9C0E9BD2}{C712732B-D8E4-4C2D-8E78-AC90968E0CD7}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Tag = vbOK

-End Sub

-

-Private Sub cbCity_Change()

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_CITY") = Me.cbCity.ListIndex

-        .Calculate

-    End With

-End Sub

-

-Private Sub cbRegion_Change()

-    Dim LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        NewRangeOffsetCol = cbRegion.Value * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .Name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).address

-        NewSumRange = .Name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).address

-        .Calculate

-        .Range("IDX_CITY") = 0

-        cbCity.RowSource = NewCbxRange

-

-    End With

-    cbCity.ListIndex = 0

-End Sub

-

-<<<<<<
-======================
-mREGMAN
->>>>>>
-Attribute VB_Name = "mREGMAN"

-Option Explicit

-

-Sub hw_reset()

-    Dim rs As Range

-    Dim re As Object

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    HWReset

-    With Application

-        .DisplayAlerts = False

-        .Quit

-    End With

-End Sub

-

-Sub CheckUser()

-    If Range("HW_Number") = "" Then

-        StoreHWInfo

-    End If

-    If CheckHWInfo <> True Then

-        MsgBox "2"

-        cmAbout

-'        With Application

-'            .DisplayAlerts = False

-'            .Quit

-'        End With

-    Else

-        SetupUser

-    End If

-End Sub

-

-

-Sub SetupUser()

-'    Dim cREGMAN As tREGMAN

-'    Dim idx As Integer

-'    Dim dlg_ui As UserInfo

-'

-'    Set dlg_ui = New UserInfo

-'

-'    cREGMAN = Get_REGMAN_Record()

-'

-'    With ThisWorkbook.Worksheets(REGS_SHEET)

-'        .Range("IDX_REGION") = cREGMAN.Region

-'        .Range("IDX_CITY") = cREGMAN.City

-'    End With

-'

-'    With dlg_ui

-'        .cbRegion = cREGMAN.Region

-'        .cbCity = cREGMAN.City

-'        .tbFName = cREGMAN.FirstName

-'        .tbLName = cREGMAN.LastName

-'    End With

-'

-'    dlg_ui.Show

-'    Worksheets(REGS_SHEET).Calculate

-'

-'    If dlg_ui.Tag = vbOK Then

-'        With cREGMAN

-'            .Region = dlg_ui.cbRegion.Value

-'            .City = dlg_ui.cbCity.Value

-'            .FirstName = dlg_ui.tbFName.Value

-'            .LastName = dlg_ui.tbLName.Value

-'        End With

-'        Set_REGMAN_Record cREGMAN

-'    Else

-'        cmAbout

-'        With Application

-'            .DisplayAlerts = False

-'            .Quit

-'        End With

-'    End If

-End Sub

-

-Sub StoreHWInfo()

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim objHW() As Long

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    Set r = Range("HW_Number")

-    i = 1

-    For Each d In dc

-        If d.drivetype = 2 Then

-            r = d.SerialNumber

-            Set r = r.Offset(1, 0)

-            ReDim Preserve objHW(i)

-            objHW(i) = d.SerialNumber

-            i = i + 1

-        End If

-    Next

-    

-    UpdateHWRecords objHW

-End Sub

-

-Function CheckHWInfo()

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim objHW() As Long

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    

-    CheckHWInfo = False

-    

-    i = GetHWRecords(objHW)

-    If i = 0 And Range("HW_Number") <> 0 Then

-        Exit Function

-    End If

-    For Each d In dc

-        If d.drivetype = 2 Then

-            Set r = Range("HW_Number")

-            Do While r <> ""

-                If r = d.SerialNumber Then

-                    For i = 1 To UBound(objHW)

-                        If d.SerialNumber = objHW(i) Then

-                            CheckHWInfo = True

-                            Exit Function

-                        End If

-                    Next i

-                End If

-                Set r = r.Offset(1, 0)

-            Loop

-        End If

-    Next

-End Function

-<<<<<<
-======================
-dbBudget
->>>>>>
-Attribute VB_Name = "dbBudget"

-Option Explicit

-

-Public Type tBUDGET

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    rm_id As Long

-    bdgt_NMG As Long

-    bdgt_NFG As Long

-    sale_PLAN As Long

-End Type

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function GetAll_BDGT_RecordsByLPU_ID(ByRef allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_BDGT_RecordsByLPU_ID = dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection, allBDGT, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function Get_BDGT_Record(ByVal lpu_id As Long, ByVal ent_date As String, rm_id As Long) As tBUDGET

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    Get_BDGT_Record = dbGet_BDGT_Record(dbConnection, lpu_id, ent_date, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-' if objBDGT.ID <> 0 then updatre else insert

-Public Sub Insert_BDGT_Record(objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    If objBDGT.id <> 0 Then

-        dbUpdate_BDGT_Record dbConnection, objBDGT

-    Else

-        dbInsert_BDGT_Record dbConnection, objBDGT

-    End If

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Public Sub Delete_BDGT_Record(ByRef objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    dbDelete_BDGT_Record dbConnection, objBDGT

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_BDGT_Record(dbConnection As Object, ByVal lpu_id As Long, ent_date As String, rm_id As Long) As tBUDGET

-    

-    Dim sql As String

-    Dim objBDGT As tBUDGET

-    

-    With objBDGT

-        .id = 0

-        .lpu_id = lpu_id

-        .rm_id = rm_id

-        .entry_date = ent_date

-        .bdgt_NMG = 0

-        .bdgt_NFG = 0

-        .sale_PLAN = 0

-    End With

-        

-    

-    sql = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        With objBDGT

-            .entry_date = dbRecordset("entry_date")

-            .id = dbRecordset("id")

-            .lpu_id = dbRecordset("lpu_id")

-            .bdgt_NFG = dbRecordset("bdgt_NFG")

-            .bdgt_NMG = dbRecordset("bdgt_NMG")

-            .sale_PLAN = dbRecordset("sale_PLAN")

-        End With

-    End If

-    

-    dbGet_BDGT_Record = objBDGT

-End Function

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection As Object, allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_BDGT_SQL As String

-    Dim getAll_BDGT_SQL As String

-    Dim BDGT_Count As Long

-    BDGT_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_BDGT_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        BDGT_Count = dbRecordset("BDGT_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_BDGT_RecordsbyLPU_ID = BDGT_Count

-    

-    If BDGT_Count > 0 Then

-        'we have records

-        ReDim allBDGT(1 To BDGT_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_BDGT_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpBDGT As tBUDGET

-                 With tmpBDGT

-                    .entry_date = dbRecordset("entry_date")

-                    .id = dbRecordset("id")

-                    .lpu_id = dbRecordset("lpu_id")

-                    .bdgt_NFG = dbRecordset("bdgt_NFG")

-                    .bdgt_NMG = dbRecordset("bdgt_NMG")

-                    .sale_PLAN = dbRecordset("sale_PLAN")

-                 End With

-                 

-                 allBDGT(index) = tmpBDGT

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbInsert_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "lpu_budget", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    dbRecordset("entry_date") = objBDGT.entry_date

-    dbRecordset("lpu_id") = objBDGT.lpu_id

-    dbRecordset("bdgt_NMG") = objBDGT.bdgt_NMG

-    dbRecordset("bdgt_NFG") = objBDGT.bdgt_NFG

-    dbRecordset("sale_PLAN") = objBDGT.sale_PLAN

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objBDGT.id = dbRecordset("id")

-  

-End Sub

-

-Public Sub dbUpdate_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu_budget SET " & _

-    "entry_date='" & objBDGT.entry_date & "'," & _

-    "lpu_id=" & objBDGT.lpu_id & "," & _

-    "bdgt_NMG=" & objBDGT.bdgt_NMG & "," & _

-    "bdgt_NFG=" & objBDGT.bdgt_NFG & "," & _

-    "sale_PLAN=" & objBDGT.sale_PLAN & _

-    " WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-Public Sub dbDelete_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_BDGT_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbDatabase
->>>>>>
-Attribute VB_Name = "dbDatabase"

-Option Explicit

-

-

-Sub dbOpenConnection(dbConnection As Object)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-<<<<<<
-======================
-dbLPU
->>>>>>
-Attribute VB_Name = "dbLPU"

-Option Explicit

-

-Public Type tLPU

-    id As Long

-    rep_id As Long

-    rm_id As Long

-    Name As String

-    address As String

-    beds As Integer

-End Type

-

-Function Get_LPU_Record(ByVal lpu_id As Long, rm_id As Long) As tLPU

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_LPU_Record = dbGet_LPU_Record(dbConnection, lpu_id, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_LPU_byQTR(allLPU() As tLPU, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_LPU_byQTR = dbGetAll_LPU_byQTR(dbConnection, allLPU, ent_date, rep_id, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_Record(dbConnection As Object, ByVal lpu_id As Long, rm_id As Long) As tLPU

-    

-    Dim sql As String

-    Dim objLPU As tLPU

-    

-    objLPU.id = lpu_id

-    objLPU.Name = ""

-    objLPU.address = ""

-    

-    sql = "SELECT * FROM lpu WHERE id=" & lpu_id & " AND rm_id=" & rm_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objLPU.Name = dbRecordset("name")

-        objLPU.address = dbRecordset("address")

-        objLPU.rep_id = dbRecordset("rep_id")

-        objLPU.rm_id = dbRecordset("rm_id")

-        objLPU.beds = dbRecordset("beds")

-    End If

-    

-    dbGet_LPU_Record = objLPU

-

-End Function

-

-Function dbGetAll_LPU_byQTR(dbConnection As Object, allLPU() As tLPU, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    Dim Where As String

-    Where = "WHERE lpu_budget.entry_date like '" & ent_date & "'" & " AND lpu.id=lpu_budget.lpu_id " & _

-    "AND lpu.rep_id=" & rep_id & " AND lpu.rm_id=lpu_budget.rm_id AND lpu.rm_id=" & rm_id

-

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu_budget, lpu " & Where

-    

-    getAll_LPU_SQL = "SELECT lpu.id as id, lpu.rep_id as rep_id, lpu.name as name, lpu.address as address, lpu.beds AS beds, lpu.rm_id AS rm_id " & _

-    "FROM lpu, lpu_budget " & Where

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_LPU_byQTR = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .Name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-dbREP
->>>>>>
-Attribute VB_Name = "dbREP"

-'Option Explicit

-'

-'Public Type tREP

-'    FirstName As String

-'    LastName As String

-'    Region As Integer

-'    City As Integer

-'End Type

-'

-'Function GetREPRecord() As tREP

-'    Dim dbConnection As Object

-'

-'    dbOpenConnection dbConnection

-'    GetREPRecord = dbGetREPRecord(dbConnection)

-'    dbCloseConnection dbConnection

-'End Function

-'

-'Sub SetREPRecord(cUser As tREP)

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbSetREPRecord dbConnection, cUser

-'    dbCloseConnection dbConnection

-'End Sub

-'

-'Public Function dbGetREPRecord(dbConnection As Object) As tREP

-'

-'    Dim SQL As String

-'    Dim objREP As tREP

-'

-'    objREP.FirstName = ""

-'    objREP.LastName = ""

-'    objREP.Region = 0

-'    objREP.City = 0

-'    SQL = "SELECT firstname, lastname, region, city FROM " & _

-'          "rep"

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open SQL, dbConnection

-'    ', 3, 3

-'    If Not dbRecordset.BOF Then

-'

-'        objREP.FirstName = dbRecordset("firstname")

-'        objREP.LastName = dbRecordset("lastname")

-'        objREP.Region = dbRecordset("region")

-'        objREP.City = dbRecordset("city")

-'

-'    End If

-'

-'    dbGetREPRecord = objREP

-'

-'End Function

-'

-'Public Sub dbSetREPRecord(dbConnection As Object, ByRef objREP As tREP)

-'

-'    Dim DeleteSQL As String

-'    Dim InsertSQL As String

-'

-'    DeleteSQL = "DELETE FROM rep"

-'    InsertSQL = "INSERT INTO rep (firstname, lastname, region, city) VALUES (" & _

-'    "'" & objREP.FirstName & "', " & _

-'    "'" & objREP.LastName & "', " & _

-'    objREP.Region & ", " & _

-'    objREP.City & ")"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-'

-'End Sub

-'

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    CheckWorkBooksArround Wb

-End Sub

-

-

-Sub CheckWorkBooksArround(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If app.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEL сейчас будут закрыты!", vbOKOnly, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub GetState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-        ActiveWorkbook.DisplayDrawingObjects = xlDisplayShapes

-        

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.Name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars(STDBAR_NAME).Visible = False

-End Sub

-

-

-Public Sub RestoreState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars(STDBAR_NAME).Visible = True

-End Sub

-

-

-

-<<<<<<
-======================
-cdbRM
->>>>>>
-Attribute VB_Name = "cdbRM"

-Option Explicit

-

-Public Type tRMID_COMMON

-    rm As tREGMAN

-    rgcd_count As Integer

-    rgcd() As tREGION

-End Type

-

-Function Get_RM_CommonList_by_QTR(ByRef rmcd() As tRMID_COMMON, ent_date As String) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_RM_CommonList_by_QTR = dbGet_RM_CommonList_by_QTR(dbConnection, rmcd(), ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_RM_CommonList_by_QTR(dbConnection As Object, ByRef rmcd() As tRMID_COMMON, ent_date As String) As Integer

-    ' Получить список RM-ов

-    Dim count As Integer

-    count = db_get_All_RM_by_QTR(dbConnection, rmcd(), ent_date)

-    

-    Dim i As Integer

-    For i = 1 To count

-        rmcd(i).rgcd_count = 1

-        ReDim rmcd(i).rgcd(1 To 1)

-        getREGION_by_QTR ent_date, rmcd(i).rgcd(1), rmcd(i).rm.rm_id

-    Next i

-    dbGet_RM_CommonList_by_QTR = count

-End Function

-

-Function db_get_All_RM_by_QTR(dbConnection As Object, rmcd() As tRMID_COMMON, ent_date As String) As Integer

-    

-    Dim count_sql As String

-    Dim get_sql As String

-    Dim rs As Object

-    Dim RM_Count As Integer

-        

-    count_sql = "SELECT COUNT(*) AS RM_TOTAL FROM reg_man"

-    get_sql = "SELECT * FROM reg_man"

-    Set rs = CreateObject("ADODB.Recordset")

-    rs.Open count_sql, dbConnection

-    

-    If Not rs.BOF Then

-        RM_Count = rs("RM_TOTAL")

-    End If

-    

-    rs.Close

-    

-     db_get_All_RM_by_QTR = RM_Count

-    

-    If RM_Count > 0 Then

-        'we have records

-        ReDim rmcd(1 To RM_Count)

-        Dim index As Long

-        index = 1

-        rs.Open get_sql, dbConnection

-        

-        If Not rs.BOF Then

-             Do While Not rs.EOF

-                 Dim tmp_rmcd As tRMID_COMMON

-                 With tmp_rmcd

-                    .rgcd_count = 0

-                    .rm.City = rs("city")

-                    .rm.FirstName = rs("firstname")

-                    .rm.LastName = rs("lastname")

-                    .rm.rm_id = rs("mgr_id")

-                    .rm.Region = rs("region")

-                 End With

-                 

-                 rmcd(index) = tmp_rmcd

-                 index = index + 1

-                 rs.MoveNext

-             Loop

-        End If

-    End If

-    

-End Function

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Public Const STDBAR_NAME = "Worksheet Menu Bar"

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Import data"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmDataImport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-             With .Add(msoControlPopup)

-                .Caption = "&Report"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&New Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 18

-                        .OnAction = "cmNewReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Open Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmOpenReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Close && Save"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseReport"

-                    End With

-                End With

-            End With

-           With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Exit && Restore Excel"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 548

-                        .OnAction = "cmExitRestore"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-        End With

-    End With

-End Sub

-

-Sub CreateExtCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom extendet commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Import data"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmDataImport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-             With .Add(msoControlPopup)

-                .Caption = "&Report"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&New Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 18

-                        .OnAction = "cmNewReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Open Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmOpenReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Close && Save"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseReport"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Add New Slide"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 280

-                .OnAction = "cmAddSlide"

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(flag As Boolean)

-    If flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars(STDBAR_NAME)

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmExport()

-    dbExport

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    Dim dlg As dlgAbout

-    Set dlg = New dlgAbout

-    

-    dlg.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlg.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlg.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlg.Show

-End Sub

-

-Sub cmMail2Support()

-    Dim err_description As String

-    Dim dlg_msg As dlg_Mail

-    Set dlg_msg = New dlg_Mail

-    With dlg_msg

-        .Show

-        If .Tag = vbOK Then

-            ThisWorkbook.Worksheets(VAR_SHEET).Range("ERR_MESSAGE") _

-                = .tbMessage.Text

-            ThisWorkbook.Save

-            ThisWorkbook.SendMail Recipients:="infra@i-rs.ru", Subject:=PROGRAM_NAME & " ver.:" & PROGRAM_VERSION

-            MsgBox "Сообщение об ошибке отправлено. Перезагрузите программу.", vbOKOnly, PROGRAM_NAME

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-    End With

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-'        helppath = "hh.exe " & .Path & "\Telfast.chm"

-'        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub set_work_mode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-End Sub

-

-Sub cmSetStandaloneMode()

-    set_work_mode

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    Dim dlg As dlgGetPwd

-    rp = common_pwd

-    

-    Set dlg = New dlgGetPwd

-    dlg.edPwd = ""

-    dlg.Show

-    

-    If dlg.edPwd = rp Then

-        Application.ScreenUpdating = False

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-        xlRestoreView

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-        Application.ScreenUpdating = True

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmNewReport()

-    ppReport.CreateReport

-    MsgBox "Новый отчет создан", vbInformation + vbOKOnly, PROGRAM_NAME

-    CreateExtCommandBar theApp:=ThisWorkbook.Application

-End Sub

-

-Sub cmOpenReport()

-    Dim fileToOpen

-    Dim s As String

-    fileToOpen = Application _

-        .GetOpenFileName("Report Files (*.ppt), *.ppt", title:="Report OPen", MultiSelect:=False)

-    If fileToOpen <> False Then

-        s = fileToOpen

-        ppReport.OpenReport s

-        CreateExtCommandBar theApp:=ThisWorkbook.Application

-    End If

-End Sub

-

-Sub cmCloseReport()

-    On Error Resume Next

-    ppReport.SaveReport

-    CreateCommandBar theApp:=ThisWorkbook.Application

-End Sub

-

-Sub cmAddSlide()

-    ThisWorkbook.ActiveSheet.PrintCopy

-    ppReport.InsertSlide

-End Sub

-

-Sub cmHomePage()

-    ThisWorkbook.Worksheets("PRJ_QTR").Select

-End Sub

-

-Sub cmExitRestore()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = True

-    Application.Quit

-End Sub

-

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    Dim dlg_prn As dlgPrint

-    

-    Set dlg_prn = New dlgPrint

-    

-    With dlg_prn

-        .cbMainReport = True

-        .cbMainBudget = False

-        .cbSrcData = False

-        .cbAllSheets = False

-    

-        .Show

-    

-        If .Tag = vbCancel Then

-            Exit Sub

-        End If

-    End With

-    

-    Dim PrnIdx As Integer

-    

-    With dlg_prn

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("REP_QTR", "budget", "Final")

-    Case 1111

-        plist = Array("REP_QTR", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("REP_QTR")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Clexane bar"

-Public Const common_pwd As String = "crdjhxtyjr"

-

-

-Sub SetEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    With Application

-        .Caption = PROGRAM_NAME

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .GetState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = False

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Unprotect

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    If cWindow.Type = xlWorkbook Then

-                        cWindow.DisplayHeadings = True

-                    End If

-                Next

-            End If

-        Next

-        If DesignMode Then

-            SetupDesignMenu True

-        End If

-        With mobjAppState

-            .RestoreState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Option Explicit

-

-Sub UpdateHWRecords(objHW() As Long)

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    dbUpdateHWRecords dbConnection, objHW

-    dbCloseConnection dbConnection

-End Sub

-

-Function GetHWRecords(objHW() As Long) As Integer

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    GetHWRecords = dbGetHWRecords(dbConnection, objHW)

-    dbCloseConnection dbConnection

-End Function

-

-Sub HWReset()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbInsertHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    

-    Dim dbRecordset As Object

-    Dim i As Long

-    

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "hw", dbConnection, 2, 2

-    

-    For i = 1 To UBound(objHW)

-        dbRecordset.addnew

-        dbRecordset("num") = objHW(i)

-        dbRecordset.Update

-    Next i

-    

-End Sub

-

-Sub dbUpdateHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    dbDeleteHWRecord dbConnection

-    dbInsertHWRecords dbConnection, objHW

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-dbHir
->>>>>>
-Attribute VB_Name = "dbHir"

-Option Explicit

-

-Public Type tHIRURGIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    operations_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_ambulator_clexan_40mg As Integer

-    patients_ambulator_clexan_20mg As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-    patients_stationar_clexan_40mg As Integer

-    patients_stationar_clexan_20mg As Integer

-End Type

-

-' if objHir.ID <> 0 then updatre else insert

-Sub Insert_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objHir.id <> 0 Then

-        dbUpdate_Hir_Record dbConnection, objHir

-    Else

-        dbInsert_Hir_Record dbConnection, objHir

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Hir_RecordsByLPU_ID(ByRef allHir() As tHIRURGIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Hir_RecordsByLPU_ID = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, allHir, lpu_id, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Hir_Record dbConnection, objHir

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objHir.ID <> 0 then updatre else insert

-

-Sub dbInsert_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_hir", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objHir

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("operations_per_quarter") = .operations_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_ambulator_clexan_20mg") = .patients_ambulator_clexan_20mg

-        dbRecordset("patients_ambulator_clexan_40mg") = .patients_ambulator_clexan_40mg

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-        dbRecordset("patients_stationar_clexan_20mg") = .patients_stationar_clexan_20mg

-        dbRecordset("patients_stationar_clexan_40mg") = .patients_stationar_clexan_40mg

-        

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objHir.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim UpdateSQL As String

-    

-    With objHir

-        UpdateSQL = "UPDATE lpu_hir SET " & _

-            "entry_date='" & objHir.entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "operations_per_quarter=" & .operations_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_ambulator_clexan_20mg=" & .patients_ambulator_clexan_20mg & "," & _

-            "patients_ambulator_clexan_40mg=" & .patients_ambulator_clexan_40mg & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & "," & _

-            "patients_stationar_clexan_20mg=" & .patients_stationar_clexan_20mg & "," & _

-            "patients_stationar_clexan_40mg=" & .patients_stationar_clexan_40mg & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_Hir_RecordsbyLPU_ID(dbConnection As Object, allHir() As tHIRURGIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_Hir_SQL As String

-    Dim getAll_Hir_SQL As String

-    Dim Hir_Count As Long

-    Hir_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    Else

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Hir_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Hir_Count = dbRecordset("HIR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Hir_RecordsbyLPU_ID = Hir_Count

-    

-    If Hir_Count > 0 Then

-        'we have records

-        ReDim allHir(1 To Hir_Count)

-        Dim index As Integer

-        index = 1

-        dbRecordset.Open getAll_Hir_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpHir As tHIRURGIA

-                 With tmpHir

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .operations_per_quarter = dbRecordset("operations_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_ambulator_clexan_20mg = dbRecordset("patients_ambulator_clexan_20mg")

-                    .patients_ambulator_clexan_40mg = dbRecordset("patients_ambulator_clexan_40mg")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                    .patients_stationar_clexan_20mg = dbRecordset("patients_stationar_clexan_20mg")

-                    .patients_stationar_clexan_40mg = dbRecordset("patients_stationar_clexan_40mg")

-                 End With

-                 

-                 allHir(index) = tmpHir

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE ID=" & objHir.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Hir_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbTer
->>>>>>
-Attribute VB_Name = "dbTer"

-Option Explicit

-

-Public Type tTERAPIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objTer.ID <> 0 then updatre else insert

-Sub Insert_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objTer.id <> 0 Then

-        dbUpdate_Ter_Record dbConnection, objTer

-    Else

-        dbInsert_Ter_Record dbConnection, objTer

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Ter_RecordsByLPU_ID(ByRef allTer() As tTERAPIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Ter_RecordsByLPU_ID = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, allTer, lpu_id, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Ter_Record dbConnection, objTer

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objTer.ID <> 0 then updatre else insert

-

-Sub dbInsert_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_ter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objTer

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objTer.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim Update_SQL As String

-    

-    With objTer

-        Update_SQL = "UPDATE lpu_ter SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_Ter_RecordsbyLPU_ID(dbConnection As Object, allTer() As tTERAPIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_Ter_SQL As String

-    Dim getAll_Ter_SQL As String

-    Dim Ter_Count As Long

-    Ter_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    Else

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Ter_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Ter_Count = dbRecordset("TER_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Ter_RecordsbyLPU_ID = Ter_Count

-    

-    If Ter_Count > 0 Then

-        'we have records

-        ReDim allTer(1 To Ter_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_Ter_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpTer As tTERAPIA

-                 With tmpTer

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 allTer(index) = tmpTer

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE ID=" & objTer.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Ter_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-mLPU_LIST
->>>>>>
-Attribute VB_Name = "mLPU_LIST"

-Option Explicit

-

-Public Const CINP_AREA As String = "B12"

-Public Const CLPU_NAME As Integer = 0

-Public Const CLPU_NAME1 As Integer = 1

-Public Const CLPU_NAME2 As Integer = 2

-Public Const CLPU_ID As Integer = 3

-Public Const CLPU_BEDS As Integer = 4

-Public Const CLPU_NFG As Integer = 5

-Public Const CLPU_NMG As Integer = 6

-Public Const CLPU_HIR As Integer = 7

-Public Const CLPU_TER As Integer = 8

-Public Const CLPU_CAR As Integer = 9

-Public Const CLPU_FACT As Integer = 10

-Public Const CLPU_PLAN As Integer = 11

-Public Const CLPU_PAT_LPU As Integer = 16

-Public Const CLPU_BDGT As Integer = 17

-Public Const CLPU_PAT_ALL As Integer = 16

-

-Sub EditLPU(cLPU As tLPU, ent_date As String)

-    NoFunc

-End Sub

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("LPU_LIST")

-        s = .Range("C4") & " " & .Range("C3") & ", " & .Range("G4") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_LPU_BBL").Range("title") = MakeChartTitle

-End Sub

-

-Sub Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PIE").Range("title") = MakeChartTitle

-End Sub

-

-Sub Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU_A").Range("title") = MakeChartTitle

-End Sub

-

-Sub btLPU_DEL_IT()

-'    Dim cLPU As tLPU

-'    Dim ent_date As String

-'    Dim delete_all As Integer

-'    Dim dlg_del As dlg_LPU_delete

-'

-'    With Worksheets("LPU_LIST")

-'        ent_date = .Range("ent_date")

-'        cLPU.id = .getCurrentLPU_ID()

-'    End With

-'

-'    If cLPU.id = 0 Then

-'        MsgBox "Укажите удаляемый объект", vbOKOnly, PROGRAM_NAME

-'        Exit Sub

-'    End If

-'    cLPU = Get_LPU_Record(cLPU.id)

-'

-'    Set dlg_del = New dlg_LPU_delete

-'    With dlg_del

-'        .chbDeleteQTR.Value = True

-'        .chbDeleteAll.Value = False

-'        .lComment = ent_date & ": Удаление ЛПУ '" _

-'        & cLPU.Name & "', расположенного по адресу:" _

-'        & cLPU.address & " не разрешено."

-'        .Show

-'    End With

-End Sub

-

-Sub btLPU_RET_IT()

-    With Worksheets("LPU_LIST")

-        .setEnt_date ("")

-        .Range("LAST_FOCUS") = ""

-        

-        Wks_select .Range("ret_addr")

-    End With

-

-End Sub

-

-

-Sub btLPU_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim lpu_id As Long

-

-    i = Worksheets(VAR_SHEET).Range("QTR_ACTION").Value

-    With Worksheets("LPU_LIST")

-        ent_date = .getEnt_date()

-

-

-        lpu_id = .getCurrentLPU_ID

-        If lpu_id = 0 And i <> 6 Then

-            i = 1

-        End If

-        Select Case i

-            Case 1

-                .SelectLPU_NAME lpu_id, ent_date

-                .Range("JUMP") = "LPU_BDGT"

-            Case 2

-                .SelectLPU_BDGT lpu_id, ent_date

-                .Range("JUMP") = "LPU_BDGT"

-            Case 3

-                .SelectLPU_HIR lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_HIR"

-

-            Case 4

-                .SelectLPU_TER lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_TER"

-

-            Case 5

-                .SelectLPU_C_ACS lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        End Select

-    End With

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-dbQTR
->>>>>>
-Attribute VB_Name = "dbQTR"

-Option Explicit

-

-Public Type tQTR

-    id As Long

-    entry_date As String

-    rep_id As Long

-    rm_id As Long

-    sale_PLAN As Long

-    ClxnH20mg As Long

-    ClxnH40mg As Long

-    ClxnT40mg As Long

-    ClxnC_IM As Long

-    ClxnC_ACS As Long

-End Type

-

-Function Get_QTR_Record(ByVal QTR_ID As Long, rm_id As Long) As tQTR

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_QTR_Record = dbGet_QTR_Record(dbConnection, QTR_ID, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_Record(dbConnection As Object, ByVal QTR_ID As Long, rm_id As Long) As tQTR

-    

-    Dim sql As String

-    Dim objQTR As tQTR

-    

-    With objQTR

-        .ClxnC_ACS = 0

-        .ClxnC_IM = 0

-        .ClxnH20mg = 0

-        .ClxnH40mg = 0

-        .ClxnT40mg = 0

-        .entry_date = ""

-        .id = QTR_ID

-        .rm_id = rm_id

-    End With

-    

-    sql = "SELECT * FROM quarter WHERE id=" & QTR_ID & " AND rm_id=" & rm_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objQTR.entry_date = dbRecordset("entry_date")

-        objQTR.rep_id = dbRecordset("rep_id")

-        objQTR.rm_id = dbRecordset("rm_id")

-        objQTR.sale_PLAN = dbRecordset("sale_plan")

-        objQTR.ClxnH20mg = dbRecordset("ClxnH20mg")

-        objQTR.ClxnH40mg = dbRecordset("ClxnH40mg")

-        objQTR.ClxnT40mg = dbRecordset("ClxnT40mg")

-        objQTR.ClxnC_IM = dbRecordset("ClxnC_IM")

-        objQTR.ClxnC_ACS = dbRecordset("ClxnC_ACS")

-        objQTR.id = dbRecordset("id")

-    End If

-    

-    dbGet_QTR_Record = objQTR

-

-End Function

-

-

-Function Get_QTR_Record_by_REP(ent_date As String, rep_id As Long, rm_id As Long) As tQTR

-    Dim dbConnection As Object

-    Dim allQTR() As tQTR

-    Dim i As Long

-

-    dbOpenConnection dbConnection

-

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id, rm_id)

-    If i <> 0 Then

-        Get_QTR_Record_by_REP = allQTR(1)

-    End If

-

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTR_Records_by_REP(ByRef all_QTR() As tQTR, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-

-    GetAll_QTR_Records_by_REP = dbGetAll_QTR_Records_By_REP(dbConnection, all_QTR, ent_date, rep_id, rm_id)

-

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGetAll_QTR_Records_By_REP(dbConnection As Object, all_QTR() As tQTR, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-

-    Dim getCount_QTR_SQL As String

-    Dim getAll_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    Dim rep_sql As String

-    Dim rm_sql As String

-    

-    rep_sql = ""

-    rm_sql = ""

-    

-    If rep_id <> 0 Then

-        rep_sql = " AND rep_id=" & rep_id

-    End If

-    

-    If rm_id <> 0 Then

-        rm_sql = " AND rm_id=" & rm_id

-    End If

-    

-    

-        getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter " & _

-        "WHERE entry_date like '" & ent_date & "' " & rep_sql & rm_sql

-        getAll_QTR_SQL = "SELECT * FROM quarter " & _

-        "WHERE entry_date like '" & ent_date & "' " & rep_sql & rm_sql & " ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-

-    dbRecordset.Close

-

-    dbGetAll_QTR_Records_By_REP = QTR_Count

-

-    If QTR_Count > 0 Then

-        'we have records

-        ReDim all_QTR(1 To QTR_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTR_SQL, dbConnection

-

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTR As tQTR

-                 With tmp_QTR

-                    .entry_date = dbRecordset("entry_date")

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .ClxnH20mg = dbRecordset("ClxnH20mg")

-                    .ClxnH40mg = dbRecordset("ClxnH40mg")

-                    .ClxnT40mg = dbRecordset("ClxnT40mg")

-                    .ClxnC_IM = dbRecordset("ClxnC_IM")

-                    .ClxnC_ACS = dbRecordset("ClxnC_ACS")

-                    .id = dbRecordset("id")

-                 End With

-

-                 all_QTR(index) = tmp_QTR

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-cdbQTR
->>>>>>
-Attribute VB_Name = "cdbQTR"

-Option Explicit

-

-Public Type tQTR_COMMON

-    qtr As tQTR

-    i_lcd As Long           ' число ЛПУ в СПИСКЕ

-    lcd() As tLPU_COMMON    ' список ЛПУ

-    c_beds As Long          ' сумма коек

-    c_bdgt_NFG As Long      ' общий бюджет на НФГ

-    c_bdgt_NMG As Long      ' общий бюджет на НМГ

-    c_bdgt_LPU As Long      ' общий бюджет на гепарины

-    c_sale_PLAN As Long     ' план продаж репа

-    c_sale_ALL As Long      ' продажи

-    c_sale_HIR As Long      ' в хирургии

-    c_sale_TER  As Long     ' в терапии

-    c_sale_CRD  As Long     ' в кардиологии

-    c_pat_HIR   As Long     ' пациенты

-    c_pat_TER   As Long     '

-    c_pat_CRD   As Long     '

-    c_pat_ALL   As Long     '

-    c_pat_LPU   As Long     ' Всего операций

-End Type

-

-Function Get_QTR_CommonList_by_REP(ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long, rm_id As Long) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_QTR_CommonList_by_REP = dbGet_QTR_CommonList_by_REP(dbConnection, qcd, ent_date, rep_id, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_CommonList_by_REP(dbConnection As Object, ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long, rm_id As Long) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim allQTR() As tQTR

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id, rm_id)

-    dbGet_QTR_CommonList_by_REP = i

-    If i > 0 Then

-        ReDim qcd(i)

-        For i = 1 To UBound(allQTR)

-            With qcd(i)

-                .qtr = allQTR(i)

-                .c_beds = 0

-                .c_bdgt_NFG = 0

-                .c_bdgt_NMG = 0

-                .c_bdgt_LPU = 0

-                .c_sale_PLAN = 0

-                .c_pat_HIR = 0

-                .c_pat_TER = 0

-                .c_pat_CRD = 0

-                .c_pat_ALL = 0

-                .c_sale_HIR = 0

-                .c_sale_TER = 0

-                .c_sale_CRD = 0

-                .c_sale_ALL = 0

-                .c_pat_LPU = 0

-                

-                j = dbGet_LPU_CommonQTR(dbConnection, .lcd, .qtr)

-                .i_lcd = j

-                If j > 0 Then

-                    For j = 1 To UBound(.lcd)

-                        .c_beds = .c_beds + .lcd(j).lpu.beds

-                        .c_bdgt_NFG = .c_bdgt_NFG + .lcd(j).bdgt.bdgt_NFG

-                        .c_bdgt_NMG = .c_bdgt_NMG + .lcd(j).bdgt.bdgt_NMG

-                        .c_bdgt_LPU = .c_bdgt_LPU + .lcd(j).bdgt_LPU

-                        .c_sale_PLAN = .c_sale_PLAN + .lcd(j).bdgt.sale_PLAN

-                        .c_pat_HIR = .c_pat_HIR + .lcd(j).pat_HIR

-                        .c_pat_TER = .c_pat_TER + .lcd(j).pat_TER

-                        .c_pat_CRD = .c_pat_CRD + .lcd(j).pat_CRD

-                        .c_pat_ALL = .c_pat_ALL + .lcd(j).pat_ALL

-                        .c_sale_HIR = .c_sale_HIR + .lcd(j).sale_HIR

-                        .c_sale_TER = .c_sale_TER + .lcd(j).sale_TER

-                        .c_sale_CRD = .c_sale_CRD + .lcd(j).sale_CRD

-                        .c_sale_ALL = .c_sale_ALL + .lcd(j).sale_ALL

-                        .c_pat_LPU = .c_pat_LPU + .lcd(j).pat_LPU

-                    Next j

-                    

-                End If

-            End With

-        Next i

-    End If

-End Function

-

-Function GetLastQtr() As String

-    Dim s As String

-    Dim r As Range

-    Set r = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Do While r.Cells(1, 1) <> ""

-        s = r.Cells(1, 1)

-        Set r = r.Cells.Offset(1, 0)

-    Loop

-    GetLastQtr = s

-End Function

-

-Function GetNextQTR(ent_date As String) As String

-    Dim rd As Range

-    Dim idx As Integer

-    Dim b As Variant

-    Dim dlg As dlg_newQTR

-    Set dlg = New dlg_newQTR

-    

-    If ent_date = "" Then

-        Dim ir As Variant

-        idx = 0

-        dlg.Show

-        b = dlg.Tag

-            

-        If IsNumeric(b) Then

-            GetNextQTR = dlg.cbQTR

-        Else

-            GetNextQTR = ""

-        End If

-    Else

-        Set rd = Worksheets(VAR_SHEET).Range("Date_Lst")

-        idx = WorksheetFunction.Match(ent_date, rd, 0)

-        GetNextQTR = WorksheetFunction.index(rd, idx + 1, 1)

-    End If

-End Function

-<<<<<<
-======================
-mRestView
->>>>>>
-Attribute VB_Name = "mRestView"

-Option Explicit

-

-Sub xlRestoreView()

-Attribute xlRestoreView.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute xlRestoreView.VB_ProcData.VB_Invoke_Func = " \n14"

-    With Application

-        .CommandBars("Standard").Visible = True

-        .CommandBars("Formatting").Visible = True

-        .DisplayFormulaBar = True

-        .DisplayStatusBar = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = True

-    End With

-End Sub

-<<<<<<
-======================
-dlg_newQTR
->>>>>>
-Attribute VB_Name = "dlg_newQTR"

-Attribute VB_Base = "0{92648543-CB84-4B6B-BEB3-539AE7EF9D84}{7E20E3E3-027A-483B-A14D-AA9EA5398ACC}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mDec2TS
->>>>>>
-Attribute VB_Name = "mDec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-CHRT_LPU_BBL
->>>>>>
-Attribute VB_Name = "CHRT_LPU_BBL"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    Unprotect

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Потенциал рынка: " & Range("title")

-    Range("view_key") = False

-    ChangeLabels

-    Range("A1").Select

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Unprotect

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub BCLabelChng_Click()

-    Unprotect

-    If Range("view_key") Then

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать названия"

-    Else

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать объемы"

-    End If

-    Range("view_key") = Not Range("view_key")

-    ChangeLabels

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub ChangeLabels()

-    Dim i As Integer

-    Dim offset_text As Integer

-    Dim src As Range

-    Set src = Range("CHRT_BBL_DATA")

-    

-    offset_text = 3

-    If Range("view_key") Then

-        offset_text = 4

-    End If

-    

-    With ChartObjects(1).Chart

-        With .SeriesCollection(1)

-            For i = 1 To .Points.count

-                On Error GoTo ExitLabel

-                .Points(i).DataLabel.Characters.Text = Format(src.Cells(i, offset_text))

-            Next i

-        End With

-    End With

-ExitLabel:

-End Sub

-<<<<<<
-======================
-CHRT_PAT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PAT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Пациенты на Клексане(чел.): " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-<<<<<<
-======================
-CHRT_PAT_LPU
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Пациенты на Клексане(%): " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_nextQTR
->>>>>>
-Attribute VB_Name = "dlg_nextQTR"

-Attribute VB_Base = "0{067FED69-B41E-427D-AF59-5798B8E2E73A}{4C13CAB1-FDCC-4708-89EB-E92EDC125712}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-cdbLPU
->>>>>>
-Attribute VB_Name = "cdbLPU"

-Option Explicit

-

-Public Type tLPU_COMMON

-    lpu As tLPU

-    bdgt As tBUDGET

-    i_hir As Long

-    hir() As tHIRURGIA

-    i_ter As Long

-    ter() As tTERAPIA

-    i_ACS As Long

-    ACS() As tACS

-    bdgt_LPU As Long

-    sale_HIR As Long

-    sale_TER As Long

-    sale_CRD As Long

-    sale_ALL As Long

-    pat_HIR As Long

-    pat_TER As Long

-    pat_CRD As Long

-    pat_ALL As Long     ' Сумма всех пациентов на клексане

-    pat_LPU As Long     ' Число потенциальных пациентов для продаж клексана

-End Type

-

-Function Get_LPU_CommonQTR(ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    Get_LPU_CommonQTR = dbGet_LPU_CommonQTR(dbConnection, lcd, objQTR)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_CommonQTR(dbConnection As Object, ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    i = dbGetAll_LPU_byQTR(dbConnection, allLPU, objQTR.entry_date, objQTR.rep_id, objQTR.rm_id)

-    dbGet_LPU_CommonQTR = i

-    If i > 0 Then

-        ReDim lcd(i)

-        For i = 1 To UBound(allLPU)

-            dbGet_LPU_Common dbConnection, lcd(i), allLPU(i), objQTR

-        Next i

-    End If

-End Function

-

-Sub Get_LPU_Common(ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    dbGet_LPU_Common dbConnection, lcd, cLPU, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbGet_LPU_Common(dbConnection As Object, ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-

-    lcd.lpu = cLPU

-    lcd.bdgt = dbGet_BDGT_Record(dbConnection, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    lcd.i_hir = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, lcd.hir, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    lcd.i_ter = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, lcd.ter, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    lcd.i_ACS = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, lcd.ACS, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    With lcd

-        .bdgt_LPU = .bdgt.bdgt_NFG + .bdgt.bdgt_NMG

-        .pat_LPU = 0

-        If .i_hir > 0 Then

-            .pat_HIR = .hir(1).patients_ambulator_clexan + .hir(1).patients_stationar_clexan

-            .sale_HIR = objQTR.ClxnH20mg * (.hir(1).patients_ambulator_clexan_20mg + .hir(1).patients_stationar_clexan_20mg)

-            .sale_HIR = .sale_HIR + objQTR.ClxnH40mg * (.hir(1).patients_ambulator_clexan_40mg + .hir(1).patients_stationar_clexan_40mg)

-            .pat_LPU = .pat_LPU + .hir(1).operations_per_quarter

-        End If

-        If .i_ter > 0 Then

-            .pat_TER = .ter(1).patients_ambulator_clexan + .ter(1).patients_stationar_clexan

-            .sale_TER = .pat_TER * objQTR.ClxnT40mg

-            .pat_LPU = .pat_LPU + .ter(1).patients_per_quarter

-        End If

-        If .i_ACS > 0 Then

-            .pat_CRD = .ACS(1).patients_stationar_clexan

-            .sale_CRD = .pat_CRD * objQTR.ClxnC_ACS

-            .pat_LPU = .pat_LPU + .ACS(1).patients_per_quarter

-        End If

-        .pat_ALL = .pat_HIR + .pat_TER + .pat_CRD

-        .sale_ALL = .sale_HIR + .sale_TER + .sale_CRD

-    End With

-End Sub

-

-<<<<<<
-======================
-CHRT_PIE
->>>>>>
-Attribute VB_Name = "CHRT_PIE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Unprotect

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Доля продаж: " & Range("title")

-    

-    On Error Resume Next

-    Range("P5:Q24").Sort _

-        Key1:=Range("Q5"), _

-        Order1:=xlDescending, _

-        Header:=xlGuess, _

-        OrderCustom:=1, _

-        MatchCase:=False, _

-        Orientation:=xlTopToBottom

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PLN_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PLN_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Динамика продаж: " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_BDGT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_BDGT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Бюджеты ЛПУ: " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-dlg_LPU_delete
->>>>>>
-Attribute VB_Name = "dlg_LPU_delete"

-Attribute VB_Base = "0{9C81F4D2-4ECF-46F5-999B-9801D572A12F}{B382508B-7F3D-4747-8407-0F75F6F265F5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlg_Mail
->>>>>>
-Attribute VB_Name = "dlg_Mail"

-Attribute VB_Base = "0{EA8CE4CE-AC2E-45BC-BAF8-1429E6242097}{575F0762-04F4-4F86-B98A-8E87E3424B0D}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dbREP_id
->>>>>>
-Attribute VB_Name = "dbREP_id"

-Public Type tREPID

-    rep_id As Long

-    rm_id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function GetAll_REPID_Records_by_QTR(ByRef all_REPID() As tREPID, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_REPID_Records_by_QTR = dbGetAll_REPID_Records_by_QTR(dbConnection, all_REPID, ent_date, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function Get_REPID_Record(rep_id As Long, rm_id As Long) As tREPID

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REPID_Record = dbGet_REPID_Record(dbConnection, rep_id, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_REPID_Records(ByRef all_REPID() As tREPID) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_REPID_Records = dbGetAll_REPID_Records(dbConnection, all_REPID)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function dbGet_REPID_Record(dbConnection As Object, rep_id As Long, rm_id As Long) As tREPID

-    

-    Dim sql As String

-    Dim objREPID As tREPID

-    

-    objREPID.FirstName = ""

-    objREPID.LastName = ""

-    objREPID.Region = 0

-    objREPID.City = 0

-    sql = "SELECT * FROM " & _

-          "rep WHERE rep_id=" & rep_id & " AND rm_id=" & rm_id

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREPID.rep_id = dbRecordset("rep_id")

-        objREPID.rm_id = dbRecordset("rm_id")

-        objREPID.FirstName = dbRecordset("firstname")

-        objREPID.LastName = dbRecordset("lastname")

-        objREPID.Region = dbRecordset("region")

-        objREPID.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REPID_Record = objREPID

-        

-End Function

-

-Function dbGetAll_REPID_Records_by_QTR(dbConnection As Object, ByRef all_REPID() As tREPID, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    Dim Where As String

-    

-    REPID_Count = 0

-    

-    Where = " WHERE lpu_budget.entry_date like '" & ent_date & "' " & _

-        "AND rep.rep_id=lpu.rep_id AND lpu.id=lpu_budget.lpu_id"

-    If rm_id <> 0 Then

-        Where = Where & " AND rep.rm_id=" & rm_id

-    End If

-    

-    getAll_REPID_SQL = "SELECT distinct rep.* FROM rep, lpu, lpu_budget" & Where

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM (" & getAll_REPID_SQL & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records_by_QTR = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Function dbGetAll_REPID_Records(dbConnection As Object, ByRef all_REPID() As tREPID) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    REPID_Count = 0

-    

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM rep"

-    getAll_REPID_SQL = "SELECT * FROM rep"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-cdbExport
->>>>>>
-Attribute VB_Name = "cdbExport"

-Option Explicit

-

-Function GetDBSN() As String

-    Dim n As Long

-    Randomize Timer

-    n = Int((100000000 - 1000000 + 1) * Rnd + 1000000)

-    GetDBSN = Dec2ThirtySix(n)

-End Function

-

-Sub dbExport()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim old_file As String

-    

-    On Error GoTo ErrHandler

-    

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    old_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & "*.*"

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & GetDBSN() & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.DeleteFile old_file, True

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Данные экспортированы в файл:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для передачи", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-Exit Sub

-

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-<<<<<<
-======================
-mRegs
->>>>>>
-Attribute VB_Name = "mRegs"

-Option Explicit

-

-Function GetRegionName(idx As Integer) As String

-    GetRegionName = Worksheets(REGS_SHEET).Range("LST_REGIONS").Cells(idx + 1, 1).Text

-End Function

-

-Function GetCityName(idx_reg As Integer, idx_city As Integer) As String

-    GetCityName = Worksheets(REGS_SHEET).Range("CITY_TABLES").Offset(idx_city + 1, idx_reg * 2).Text

-End Function

-

-Sub testReg()

-    Dim r As Integer

-    Dim c As Integer

-    Dim s As String

-    

-    r = 3

-    c = 3

-    s = GetRegionName(r)

-    s = s & ", " & GetCityName(r, c)

-    MsgBox s

-End Sub

-

-<<<<<<
-======================
-RM_QTR
->>>>>>
-Attribute VB_Name = "RM_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CRGN_QT As Integer = 0

-Const CRGN_PLN As Integer = 2

-Const CRGN_FCT As Integer = 3

-Const CRGN_BDG As Integer = 4

-Const CRGN_LPU As Integer = 5

-Const CRGN_REP As Integer = 6

-Const CRGN_HIR As Integer = 7

-Const CRGN_TER As Integer = 8

-Const CRGN_CRD As Integer = 9

-Const CRGN_CLXN_BDG As Integer = 10

-Const CRGN_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Const LOCAL_ENT_DATE As String = "B11"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("RM_QTR")

-        s = .Range("D5") & " " & .Range("D4") & ", " & .Range("H4") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub update_history()

-    Dim objRGN() As tREGION

-    Dim i As Long

-    Dim r As Range

-    Dim cRMan As tREGMAN

-

-    cRMan = Get_REGMAN_Record(Range("RM_ID"))

-    

-    Range("D4") = cRMan.LastName

-    Range("D5") = cRMan.FirstName

-

-    Range("H4") = GetRegionName(cRMan.Region)

-    

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetRGN_COMM_DATA(objRGN, Range("RM_ID"))

-    

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objRGN)

-            r.Offset(i - 1, CRGN_QT) = objRGN(i).ent_date

-            r.Offset(i - 1, CRGN_FCT) = objRGN(i).total_SALE

-            r.Offset(i - 1, CRGN_PLN) = objRGN(i).sale_PLAN

-            r.Offset(i - 1, CRGN_BDG) = objRGN(i).total_BDGT

-            r.Offset(i - 1, CRGN_LPU) = objRGN(i).total_LPU

-            r.Offset(i - 1, CRGN_REP) = objRGN(i).total_REP

-            r.Offset(i - 1, CRGN_HIR) = objRGN(i).total_HIR

-            r.Offset(i - 1, CRGN_TER) = objRGN(i).total_TER

-            r.Offset(i - 1, CRGN_CRD) = objRGN(i).total_ACS

-            If objRGN(i).total_BDGT <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_BDG) = objRGN(i).total_SALE / objRGN(i).total_BDGT

-            End If

-            If objRGN(i).total_BDGT_NMG <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_NMG) = objRGN(i).total_SALE / objRGN(i).total_BDGT_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRGN_CRD + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-

-Sub Draw_PLN_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_FCT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PLN_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Draw_BDGT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_CLXN_NMG + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_BDGT_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Public Sub cbxRM_QtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR_RM

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR_RM

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR_RM

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = RM_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CRGN_QT + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    If r = "" Then

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = currRange.address

-    End If

-    Cancel = True

-    btRM_QTR_Do_IT

-End Sub

-

-<<<<<<
-======================
-dbREG_MAN
->>>>>>
-Attribute VB_Name = "dbREG_MAN"

-Option Explicit

-

-Public Type tREGMAN

-    rm_id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function Get_REGMAN_Record(rm_id As Long) As tREGMAN

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REGMAN_Record = dbGet_REGMAN_Record(dbConnection, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Sub Set_REGMAN_Record(cREGMAN As tREGMAN)

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbSet_REGMAN_Record dbConnection, cREGMAN

-'    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_REGMAN_Record(dbConnection As Object, rm_id As Long) As tREGMAN

-    

-    Dim sql As String

-    Dim objREGMAN As tREGMAN

-    

-    objREGMAN.FirstName = ""

-    objREGMAN.LastName = ""

-    objREGMAN.Region = 0

-    objREGMAN.City = 0

-    objREGMAN.rm_id = rm_id

-    sql = "SELECT * FROM " & _

-          "reg_man WHERE mgr_id=" & rm_id

-          

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREGMAN.FirstName = dbRecordset("firstname")

-        objREGMAN.LastName = dbRecordset("lastname")

-        objREGMAN.Region = dbRecordset("region")

-        objREGMAN.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REGMAN_Record = objREGMAN

-        

-End Function

-

-Public Sub dbSet_REGMAN_Record(dbConnection As Object, ByRef objREGMAN As tREGMAN)

-  

-'    Dim DeleteSQL As String

-'    Dim InsertSQL As String

-'

-'    DeleteSQL = "DELETE FROM reg_man"

-'    InsertSQL = "INSERT INTO reg_man (firstname, lastname, region, city) VALUES (" & _

-'    "'" & objREGMAN.FirstName & "', " & _

-'    "'" & objREGMAN.LastName & "', " & _

-'    objREGMAN.Region & ", " & _

-'    objREGMAN.City & ")"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-       

-End Sub

-

-

-

-<<<<<<
-======================
-dbDatabaseMerge
->>>>>>
-Attribute VB_Name = "dbDatabaseMerge"

-Option Explicit

-

-Public Type tDBFIELD

-    Name As String

-End Type

-

-Public Type tDBTABLE

-    Name As String

-    field() As tDBFIELD

-End Type

-

-

-Function dbGetConnection(dbAccessFileFullPath As String) As Object

-    Dim dbConnection As Object

-    Dim dbAccessFilePasswd As String

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFileFullPath & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    Set dbGetConnection = dbConnection

-End Function

-

-Sub dbCloseOpenedConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteOpenedSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-Function dbMergeREP(from_dbConnection As Object, to_dbConnection As Object) As Long

-

-    Dim getRecordset As Object

-    Dim getREPData_SQL As String

-    Dim REP_fn As String

-    Dim REP_ln As String

-    Dim REP_region As String

-    Dim REP_city As String

-

-

-    getREPData_SQL = "SELECT * FROM rep"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getREPData_SQL, from_dbConnection

-        

-        If Not getRecordset.BOF Then

-            REP_fn = getRecordset("firstname")

-            REP_ln = getRecordset("lastname")

-            REP_city = getRecordset("city")

-            REP_region = getRecordset("region")

-        Else

-            MsgBox "There is no information about rep! This database cannot be merged!!!"

-            dbMergeREP = -1

-            Exit Function

-        End If

-    

-    Dim insertRecordset As Object

-    Set insertRecordset = CreateObject("ADODB.Recordset")

-        

-    insertRecordset.Open "rep", to_dbConnection, 2, 2

-    insertRecordset.addnew

-        

-    insertRecordset("firstname") = REP_fn

-    insertRecordset("lastname") = REP_ln

-    insertRecordset("region") = REP_region

-    insertRecordset("city") = REP_city

-    insertRecordset.Update

-    insertRecordset.MoveLast

-    'new ID

-    

-    dbMergeREP = insertRecordset("rep_id")

-    

-End Function

-

-Sub dbMergeLPU(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getLPU_SQL As String

-    Dim getRecordset As Object

-    Dim idx As Long

-    idx = 1

-    

-    getLPU_SQL = "SELECT * FROM lpu"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getLPU_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            ReDim Preserve objLPU(1 To idx)

-            objLPU(idx).old_lpu_id = getRecordset("id")

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "lpu", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("name") = getRecordset("name")

-            insRS("address") = getRecordset("address")

-            insRS("beds") = getRecordset("beds")

-            insRS.Update

-            insRS.MoveLast

-            'new ID

-            

-            objLPU(idx).new_lpu_id = insRS("id")

-                        

-            idx = idx + 1

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about LPU! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-

-Sub dbMergeLPURelated(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object)

-

-    ' 6 tables to change

-    Dim tables(1 To 5) As tDBTABLE

-    

-    'lpu budget

-    tables(1).Name = "lpu_budget"

-    ReDim tables(1).field(1 To 4)

-    

-    tables(1).field(1).Name = "entry_date"

-    tables(1).field(2).Name = "bdgt_NMG"

-    tables(1).field(3).Name = "bdgt_NFG"

-    tables(1).field(4).Name = "sale_PLAN"

-    

-    'lpu hir

-    tables(2).Name = "lpu_hir"

-    ReDim tables(2).field(1 To 13)

-    

-    tables(2).field(1).Name = "entry_date"

-    tables(2).field(2).Name = "operations_per_quarter"

-    tables(2).field(3).Name = "risk_percent"

-    tables(2).field(4).Name = "patients_with_risk_ON"

-    tables(2).field(5).Name = "patients_ambulator"

-    tables(2).field(6).Name = "patients_ambulator_nmg"

-    tables(2).field(7).Name = "patients_ambulator_clexan"

-    tables(2).field(8).Name = "patients_ambulator_clexan_40mg"

-    tables(2).field(9).Name = "patients_ambulator_clexan_20mg"

-    tables(2).field(10).Name = "patients_stationar_nmg"

-    tables(2).field(11).Name = "patients_stationar_clexan"

-    tables(2).field(12).Name = "patients_stationar_clexan_40mg"

-    tables(2).field(13).Name = "patients_stationar_clexan_20mg"

-    

-    

-    'lpu acs

-    tables(3).Name = "lpu_acs"

-    ReDim tables(3).field(1 To 5)

-    

-    tables(3).field(1).Name = "entry_date"

-    tables(3).field(2).Name = "patients_with_geparins"

-    tables(3).field(3).Name = "patients_per_quarter"

-    tables(3).field(4).Name = "patients_stationar_nmg"

-    tables(3).field(5).Name = "patients_stationar_clexan"

-    

-    'lpu acs

-    tables(4).Name = "lpu_im"

-    ReDim tables(4).field(1 To 5)

-    

-    tables(4).field(1).Name = "entry_date"

-    tables(4).field(2).Name = "patients_with_geparins"

-    tables(4).field(3).Name = "patients_per_quarter"

-    tables(4).field(4).Name = "patients_stationar_nmg"

-    tables(4).field(5).Name = "patients_stationar_clexan"

-    

-    

-    'lpu acs

-    tables(5).Name = "lpu_ter"

-    ReDim tables(5).field(1 To 9)

-    

-    tables(5).field(1).Name = "entry_date"

-    tables(5).field(2).Name = "patients_per_quarter"

-    tables(5).field(3).Name = "risk_percent"

-    tables(5).field(4).Name = "patients_with_risk_ON"

-    tables(5).field(5).Name = "patients_ambulator"

-    tables(5).field(6).Name = "patients_ambulator_nmg"

-    tables(5).field(7).Name = "patients_ambulator_clexan"

-    tables(5).field(8).Name = "patients_stationar_nmg"

-    tables(5).field(9).Name = "patients_stationar_clexan"

-    

-    

-    

-    Dim tbl_idx As Integer

-    

-    For tbl_idx = 1 To UBound(tables)

-        

-        Dim getSQL As String

-        Dim getRS As Object

-        

-        

-        

-        Set getRS = CreateObject("ADODB.Recordset")

-        

-        getSQL = "SELECT * FROM " & tables(tbl_idx).Name

-        getRS.Open getSQL, from_db

-        

-        If Not getRS.BOF Then

-            Do While Not getRS.EOF

-                Dim insRS As Object

-                Set insRS = CreateObject("ADODB.Recordset")

-                

-                insRS.Open tables(tbl_idx).Name, to_db, 2, 2

-                insRS.addnew

-                Dim fld_idx As Integer

-    

-                    For fld_idx = 1 To UBound(tables(tbl_idx).field)

-                        insRS(tables(tbl_idx).field(fld_idx).Name) = getRS(tables(tbl_idx).field(fld_idx).Name)

-                        insRS("lpu_id") = findNewLPU_IDByOld(objLPU, getRS("lpu_id"))

-                    Next fld_idx

-                    

-                insRS.Update

-                insRS.MoveLast

-                getRS.MoveNext

-            Loop

-        End If

-        

-        

-    Next tbl_idx

-

-End Sub

-

-Function findNewLPU_IDByOld(objLPU() As tLPUCONVERTION, old_id As Long)

-

-Dim i As Integer

-For i = 1 To UBound(objLPU)

-    If objLPU(i).old_lpu_id = old_id Then

-        findNewLPU_IDByOld = objLPU(i).new_lpu_id

-        Exit Function

-    End If

-Next i

-

-findNewLPU_IDByOld = -1

-End Function

-

-

-

-

-

-Sub dbMergeQTR(from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getQTR_SQL As String

-    Dim getRecordset As Object

-    

-    getQTR_SQL = "SELECT * FROM quarter"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getQTR_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "quarter", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("entry_date") = getRecordset("entry_date")

-            insRS("sale_plan") = getRecordset("sale_plan")

-            insRS("ClxnH20mg") = getRecordset("ClxnH20mg")

-            insRS("ClxnH40mg") = getRecordset("ClxnH40mg")

-            insRS("ClxnT40mg") = getRecordset("ClxnT40mg")

-            insRS("ClxnC_IM") = getRecordset("ClxnC_IM")

-            insRS("ClxnC_ACS") = getRecordset("ClxnC_ACS")

-            

-            

-            insRS.Update

-            

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about quarter budget! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-dbMerge
->>>>>>
-Attribute VB_Name = "dbMerge"

-Option Explicit

-

-Public Type tLPUCONVERTION

-    old_lpu_id As Long

-    new_lpu_id As Long

-End Type

-

-Sub Merge_BackUp_All_Data()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim time_stump As String

-    

-    On Error GoTo ErrHandler

-    

-    time_stump = Format(Date, "yy-mm-dd_") & Format(Time, "hh-mm")

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_BACKUPNAME & time_stump & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Старые данные сохранены в файле:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для восстанеовления данных в случае утери", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-    Exit Sub

-    

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-

-Sub Merge_Clear_All_Data(access_file_full_path As String)

-    

-    Dim db As Object

-    Dim tables_to_clear() As String

-    On Error GoTo ErrHandler

-    

-    ReDim tables_to_clear(1 To 10)

-    tables_to_clear(1) = "rep"

-    tables_to_clear(2) = "lpu"

-    tables_to_clear(3) = "lpu_budget"

-    tables_to_clear(4) = "lpu_hir"

-    tables_to_clear(5) = "lpu_ter"

-    tables_to_clear(6) = "lpu_acs"

-    tables_to_clear(7) = "lpu_im"

-    tables_to_clear(8) = "quarter"

-    tables_to_clear(9) = "quarter_rm"

-    tables_to_clear(10) = "reg_man"

-    

-    Set db = dbGetConnection(access_file_full_path)

-

-    Dim i As Integer

-    

-    For i = 1 To UBound(tables_to_clear)

-        

-        If tables_to_clear(i) <> "" Then

-            Dim Clear_SQL As String

-            Clear_SQL = "DELETE FROM " & tables_to_clear(i)

-            dbExecuteOpenedSQL db, Clear_SQL

-        Else

-            'do nothing or show message

-        End If

-    Next i

-    

-    dbCloseOpenedConnection db

-    Set db = Nothing

-    

-Exit Sub

-

-ErrHandler:

-    MsgBox "something wrong: " & err.Description

-    Resume Next

-    

-End Sub

-

-Function MergeREP(from_file As String, to_file As String) As Long

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    Dim new_rep_id As Long

-

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    MergeREP = dbMergeREP(db1, db2)

-    'MsgBox "new rep ID is " & new_rep_id

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Function

-

-Sub MergeQTR(from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeQTR db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-

-Sub MergeLPU(objLPU() As tLPUCONVERTION, from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeLPU objLPU, db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-Sub MergeLPURelated(objLPU() As tLPUCONVERTION, from_file As String, to_file As String)

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    dbMergeLPURelated objLPU, db1, db2

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-

-End Sub

-

-Sub MergeGlobal(rep_files() As String, rm_file As String)

-

-    Dim i As Integer

-    'clear output file content

-    Merge_Clear_All_Data rm_file

-    

-    For i = 1 To UBound(rep_files)

-        

-        Dim rep_file As String

-        'setup input and output files

-        rep_file = rep_files(i)

-        

-        Dim new_rep_id As Long

-        ' insert REP data and get new rep_id

-        new_rep_id = MergeREP(rep_file, rm_file)

-        

-        Dim objLPU() As tLPUCONVERTION

-        'insert all LPU using new generated rep_id

-        'and populate objLPU old->new relation object

-        

-        MergeLPU objLPU, rep_file, rm_file, new_rep_id

-        'insert quarter data using new rep_id

-        MergeQTR rep_file, rm_file, new_rep_id

-        

-        

-        ' and.... insert all another data (5 tables excl version and hw)

-        'using objLPU old->new relation object

-        MergeLPURelated objLPU, rep_file, rm_file

-    

-    

-    Next i

-    

-End Sub

-

-Function GetDBList(MyPath() As String, ByRef dblist() As String) As Integer

-    Dim i As Integer

-    Dim MyName, MyMask

-    MyMask = MyPath(0) & MyPath(1) & PROGRAM_DATAEXT

-    i = 0

-    MyName = Dir(MyMask)      ' Retrieve the first entry.

-    Do While MyName <> ""    ' Start the loop.

-        ' Ignore the current directory and the encompassing directory.

-        If MyName <> "." And MyName <> ".." Then

-            ' Use bitwise comparison to make sure MyName is a directory.

-            i = i + 1

-            ReDim Preserve dblist(i)

-            dblist(i) = MyPath(0) & MyName

-        End If

-        MyName = Dir    ' Get next entry.

-    Loop

-    GetDBList = i

-End Function

-

-<<<<<<
-======================
-cdbPRJ
->>>>>>
-Attribute VB_Name = "cdbPRJ"

-Option Explicit

-

-Type tPROJECT

-    total_SALE  As Long ' общий объем продаж

-    total_BDGT  As Long ' бюджет всех ЛПУ

-    total_BDGT_NMG As Long ' бюджет всех ЛПУ на НМГ

-    total_LPU   As Long ' число ЛПУ

-    total_REP   As Long ' число репов

-    total_RM    As Long ' число репов

-    total_BEDS  As Long ' общее число коек

-    total_HIR   As Long '  общее число пациентов на клексане в хирургии

-    total_TER   As Long '  общее число пациентов на клексане в терапии

-    total_ACS   As Long '  общее число пациентов на клексане в кардиологии

-    sale_PLAN   As Long '  план продаж Авентиса

-    objRGN() As tREGION

-End Type

-

-Function GetPRJ_COMM_DATA(ByRef prj_data As tPROJECT) As Integer

-    Dim i As Integer

-    i = GetRGN_COMM_DATA(prj_data.objRGN, 0)

-    GetPRJ_COMM_DATA = i

-    If i > 0 Then

-        With prj_data

-            .sale_PLAN = 0

-            .total_ACS = 0

-            .total_BDGT = 0

-            .total_BDGT_NMG = 0

-            .total_BEDS = 0

-            .total_HIR = 0

-            .total_LPU = 0

-            .total_REP = 0

-            .total_RM = 0

-            .total_SALE = 0

-            .total_TER = 0

-            For i = 1 To UBound(prj_data.objRGN)

-                

-            Next i

-        End With

-    End If

-

-End Function

-

-<<<<<<
-======================
-dbQTR_RM
->>>>>>
-Attribute VB_Name = "dbQTR_RM"

-Option Explicit

-

-Public Type tQTRRM

-    id As Long

-    entry_date As String

-    rm_id As Long

-    sale_PLAN As Long

-End Type

-

-

-Sub Insert_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objQTRRM.id <> 0 Then

-        dbUpdate_QTRRM_Record dbConnection, objQTRRM

-    Else

-        dbInsert_QTRRM_Record dbConnection, objQTRRM

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-Function Get_QTRRM_Record(ent_date As String) As tQTRRM

-    Dim dbConnection As Object

-    Dim allQTRRM() As tQTRRM

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    i = dbGetAll_QTRRM_Records(dbConnection, allQTRRM, ent_date)

-    If i <> 0 Then

-        Get_QTRRM_Record = allQTRRM(1)

-    End If

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTRRM_Records(ByRef all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_QTRRM_Records = dbGetAll_QTRRM_Records(dbConnection, all_QTRRM, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_QTRRM_Record dbConnection, objQTRRM

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objQTRRM.ID <> 0 then updatre else insert

-Sub dbInsert_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "quarter_rm", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objQTRRM

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("sale_plan") = .sale_PLAN

-        dbRecordset("rm_id") = .rm_id

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objQTRRM.id = dbRecordset("id")

-

-End Sub

-

-Sub dbUpdate_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim Update_SQL As String

-    

-    With objQTRRM

-        Update_SQL = "UPDATE quarter_rm SET " & _

-            "entry_date='" & .entry_date & "'" & "," & _

-            "rm_id=" & .rm_id & "," & _

-            "sale_plan=" & .sale_PLAN & "," & _

-            " WHERE id=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if ent_date = % then all_records

-Function dbGetAll_QTRRM_Records(dbConnection As Object, all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    

-    Dim getCount_QTRRM_SQL As String

-    Dim getAll_QTRRM_SQL As String

-    Dim QTRRM_Count As Long

-    QTRRM_Count = 0

-    

-    getCount_QTRRM_SQL = "SELECT COUNT(*) AS QTRRM_TOTAL FROM quarter_rm WHERE entry_date like '" & ent_date & "'"

-    getAll_QTRRM_SQL = "SELECT * FROM quarter_rm WHERE entry_date like '" & ent_date & "' ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTRRM_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTRRM_Count = dbRecordset("QTRRM_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_QTRRM_Records = QTRRM_Count

-    

-    If QTRRM_Count > 0 Then

-        'we have records

-        ReDim all_QTRRM(1 To QTRRM_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTRRM_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTRRM As tQTRRM

-                 With tmp_QTRRM

-                    .entry_date = dbRecordset("entry_date")

-                    .rm_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .id = dbRecordset("id")

-                 End With

-                 

-                 all_QTRRM(index) = tmp_QTRRM

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM quarter_rm " & _

-    "WHERE id=" & objQTRRM.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-    

-    'delete related budget entries

-    MsgBox "remember delete related"

-'    dbDelete_BDGT_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Hir_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Ter_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_ACS_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-       

-End Sub

-

-

-<<<<<<
-======================
-REP_LIST
->>>>>>
-Attribute VB_Name = "REP_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Const LOCAL_ENT_DATE As String = "C10"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-

-Public Function getCurrentREP_ID() As Long

-    Dim r As Range

-

-    With Worksheets("REP_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CREP_ID)

-    End With

-

-    getCurrentREP_ID = r

-End Function

-

-Public Sub REP_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Rep_Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Rep_Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Rep_Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Rep_Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectREP_LPU(rep_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    Range("JUMP") = "LPU_LIST"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-        .Range("RM_ID") = rm_id

-        .setEnt_date (getEnt_date())

-    End With

-End Sub

-

-Public Sub SelectREP_QTR(rep_id As Long)

-    Dim vo As Boolean

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    Range("JUMP") = "REP_QTR"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("REP_QTR")

-        .Range("VIEW_ONLY") = vo

-        .Range("RM_ID") = rm_id

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateREPList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim rep_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CREP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CREP_AREA).row, CREP_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    rep_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CREP_AREA).Column

-    

-    If i < 4 Then

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 1

-    Else

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 2

-    End If

-    

-    If rep_id = 0 Then

-        Range("LAST_FOCUS") = Range(CREP_AREA).address

-    End If

-

-    If rep_id = 0 Then

-        i = CREP_NAME

-        Range("JUMP") = ""

-    Else

-        btREP_LIST_DO_IT

-    End If

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateREPList()

-    Dim rcd() As tREPID_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-

-    ent_date = getEnt_date

-

-    Dim rm_struc As tREGMAN

-    

-    i = Range("RM_ID")

-    rm_struc = Get_REGMAN_Record(i)

-    

-    Range("C4") = rm_struc.LastName

-    Range("C5") = rm_struc.FirstName

-

-    Range("G5") = GetRegionName(rm_struc.Region)

-    

-    i = Get_REP_CommonList_by_QTR(rcd, ent_date, Range("RM_ID"))

-

-    

-    With ThisWorkbook.Worksheets("REP_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(rcd)

-            r.Offset(i - 1, CREP_NAME) = rcd(i).rep.FirstName & " " & rcd(i).rep.LastName

-            r.Offset(i - 1, CREP_ID) = rcd(i).rep.rep_id

-            r.Offset(i - 1, CREP_BEDS) = rcd(i).qtrs(1).c_beds

-

-            r.Offset(i - 1, CREP_NFG) = rcd(i).qtrs(1).c_bdgt_NFG

-            r.Offset(i - 1, CREP_NMG) = rcd(i).qtrs(1).c_bdgt_NMG

-

-            r.Offset(i - 1, CREP_PLAN) = rcd(i).qtrs(1).qtr.sale_PLAN

-

-            r.Offset(i - 1, CREP_HIR) = rcd(i).qtrs(1).c_pat_HIR

-            r.Offset(i - 1, CREP_TER) = rcd(i).qtrs(1).c_pat_TER

-            r.Offset(i - 1, CREP_CAR) = rcd(i).qtrs(1).c_pat_CRD

-            r.Offset(i - 1, CREP_FACT) = rcd(i).qtrs(1).c_sale_ALL

-            r.Offset(i - 1, CREP_PAT_LPU) = rcd(i).qtrs(1).c_pat_LPU

-            r.Offset(i - 1, CREP_BDGT) = rcd(i).qtrs(1).c_bdgt_LPU

-            If rcd(i).qtrs(1).c_bdgt_LPU > 0 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = rcd(i).qtrs(1).c_sale_ALL / rcd(i).qtrs(1).c_bdgt_LPU

-            End If

-            If r.Offset(i - 1, CREP_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-

-

-<<<<<<
-======================
-mREP_LIST
->>>>>>
-Attribute VB_Name = "mREP_LIST"

-Option Explicit

-

-Public Const CREP_AREA As String = "B12"

-Public Const CREP_NAME As Integer = 0

-Public Const CREP_NAME1 As Integer = 1

-Public Const CREP_NAME2 As Integer = 2

-Public Const CREP_ID As Integer = 3

-Public Const CREP_BEDS As Integer = 4

-Public Const CREP_NFG As Integer = 5

-Public Const CREP_NMG As Integer = 6

-Public Const CREP_HIR As Integer = 7

-Public Const CREP_TER As Integer = 8

-Public Const CREP_CAR As Integer = 9

-Public Const CREP_FACT As Integer = 10

-Public Const CREP_PLAN As Integer = 11

-Public Const CREP_PAT_LPU As Integer = 16

-Public Const CREP_BDGT As Integer = 17

-

-

-Const LOCAL_ENT_DATE As String = "C10"

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Sub EditREP(cRep As tREPID, ent_date As String)

-    NoFunc

-End Sub

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("REP_LIST")

-        s = .Range("C5") & " " & .Range("C4") & ", " & .Range("G5") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub Rep_Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_LPU_BBL").Range("title") = MakeChartTitle

-End Sub

-

-Sub Rep_Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CREP_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CREP_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CREP_FACT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PIE").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rep_Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CREP_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CREP_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CREP_HIR + 1)

-            psum = psum + src.Cells(i, CREP_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CREP_TER + 1)

-            psum = psum + src.Cells(i, CREP_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CREP_CAR + 1)

-            psum = psum + src.Cells(i, CREP_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CREP_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rep_Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CREP_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CREP_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CREP_HIR + 1)

-            psum = psum + src.Cells(i, CREP_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CREP_TER + 1)

-            psum = psum + src.Cells(i, CREP_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CREP_CAR + 1)

-            psum = psum + src.Cells(i, CREP_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CREP_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU_A").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub btREP_RET_IT()

-    With Worksheets("REP_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = "RM_QTR"

-    End With

-    Dim str As String

-    str = Range("ret_addr")

-    ThisWorkbook.Worksheets(str).Activate

-End Sub

-

-

-Sub btREP_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim rep_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("REP_LST_DETALS")

-    With Worksheets("REP_LIST")

-        rep_id = .getCurrentREP_ID

-        

-        Select Case i

-            Case 1:

-                .SelectREP_QTR rep_id

-            Case 2:

-                ent_date = .getEnt_date()

-                .SelectREP_LPU rep_id, ent_date

-        End Select

-    End With

-    

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-

-

-

-<<<<<<
-======================
-cdbREP
->>>>>>
-Attribute VB_Name = "cdbREP"

-Option Explicit

-

-Public Type tREPID_COMMON

-    rep As tREPID

-    i_qtrs As Integer

-    qtrs() As tQTR_COMMON

-End Type

-

-Function Get_REP_CommonList_by_QTR(ByRef rcd() As tREPID_COMMON, ent_date As String, rm_id As Long) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_REP_CommonList_by_QTR = dbGet_REP_CommonList_by_QTR(dbConnection, rcd, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_REP_CommonList_by_QTR(dbConnection As Object, ByRef rcd() As tREPID_COMMON, ent_date As String, rm_id As Long) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim k As Long

-    Dim allREPID() As tREPID

-    

-    i = dbGetAll_REPID_Records_by_QTR(dbConnection, allREPID, ent_date, rm_id)

-    dbGet_REP_CommonList_by_QTR = i

-    If i > 0 Then

-        ReDim rcd(i)

-        For i = 1 To UBound(allREPID)

-            rcd(i).rep = allREPID(i)

-            rcd(i).i_qtrs = Get_QTR_CommonList_by_REP(rcd(i).qtrs, ent_date, allREPID(i).rep_id, allREPID(i).rm_id)

-        Next i

-    End If

-End Function

-

-

-

-<<<<<<
-======================
-CHRT_PAT_LPU_A
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU_A"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Пациенты на Клексане(чел.): " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-cdbRegion
->>>>>>
-Attribute VB_Name = "cdbRegion"

-Option Explicit

-

-Type tREGION

-    ent_date As String

-    rm_id As Long

-    total_SALE As Long ' общий объем продаж

-    total_BDGT As Long ' бюджет всех ЛПУ

-    total_BDGT_NMG As Long ' бюджет всех ЛПУ на НМГ

-    total_LPU As Long ' число ЛПУ

-    total_REP   As Long ' число репов

-    total_BEDS As Long ' общее число коек

-    total_HIR As Long '  общее число пациентов на клексане в хирургии

-    total_TER As Long '  общее число пациентов на клексане в терапии

-    total_ACS As Long '  общее число пациентов на клексане в кардиологии

-    sale_PLAN As Long '  план продаж Авентиса

-End Type

-

-Function GetRGN_COMM_DATA(ByRef reg_data() As tREGION, rm_id As Long) As Integer

-    Dim q_date() As String

-    Dim q_count As Integer, i As Integer

-    

-    q_count = getAllQTRNames(q_date, rm_id)

-    If q_count > 0 Then

-        ReDim reg_data(q_count)

-        For i = 1 To q_count

-            Dim current_REP_count As Integer

-            reg_data(i).rm_id = rm_id

-            reg_data(i).ent_date = q_date(i)

-            current_REP_count = getREGION_by_QTR(q_date(i), reg_data(i), rm_id)

-        Next i

-    End If

-    

-    GetRGN_COMM_DATA = q_count

-End Function

-

-' if rm_id = 0 then gets all records

-Function getAllQTRNames(ByRef qtr_lst() As String, rm_id As Long) As Integer

-    

-    Dim sql As String

-    Dim i As Integer

-    Dim db As Object, rs As Object

-    

-    sql = "SELECT DISTINCT entry_date FROM lpu_budget"

-    

-    If rm_id <> 0 Then

-        sql = sql & " WHERE rm_id=" & rm_id

-    End If

-    

-    i = 0

-    

-    dbOpenConnection db

-    Set rs = CreateObject("ADODB.Recordset")

-    

-    rs.Open sql, db

-        

-        If Not rs.BOF Then

-            Do While Not rs.EOF

-                i = i + 1

-                ReDim Preserve qtr_lst(i)

-                qtr_lst(i) = rs("entry_date")

-                rs.MoveNext

-            Loop

-        Else

-            getAllQTRNames = 0

-            Exit Function

-        End If

-    getAllQTRNames = i

-    dbCloseConnection db

-End Function

-

-Function getREGION_by_QTR(ent_date As String, treg As tREGION, rm_id As Long) As Integer

-    Dim rep_count As Integer

-    rep_count = 0

-    

-    Dim reps() As tQTR_COMMON

-    rep_count = Get_QTR_CommonList_by_REP(reps, ent_date, 0, rm_id)

-    

-    treg.ent_date = ent_date

-    treg.total_BDGT = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.total_BDGT_NMG = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.sale_PLAN = 0 ' quarter.sale_plan

-    treg.total_SALE = 0 'summ of

-    ' hir = (amb40+st40)*pr40 + (amb20+st20)*pr20

-    'ter (amb_clx+stat_clx)*price

-    ' acs xxx

-    'price per rep

-    treg.total_HIR = 0 'patiens clxn

-    treg.total_TER = 0 'patiens clxn

-    treg.total_ACS = 0 'patiens clxn

-    treg.total_LPU = 0 'lpu

-    treg.total_BEDS = 0 'lpu.beds

-    treg.total_REP = 0 '

-    

-    If rep_count > 0 Then

-        Dim i As Integer

-        

-        For i = 1 To UBound(reps)

-            ' current rep is reps(i)

-            With reps(i)

-                treg.total_BDGT = treg.total_BDGT + .c_bdgt_NFG + .c_bdgt_NMG

-                treg.total_BDGT_NMG = treg.total_BDGT_NMG + .c_bdgt_NMG

-                treg.sale_PLAN = treg.sale_PLAN + .qtr.sale_PLAN

-                treg.total_SALE = treg.total_SALE + .c_sale_ALL

-                treg.total_HIR = treg.total_HIR + .c_pat_HIR

-                treg.total_TER = treg.total_TER + .c_pat_TER

-                treg.total_ACS = treg.total_ACS + .c_pat_CRD

-                treg.total_LPU = treg.total_LPU + .i_lcd

-                treg.total_BEDS = treg.total_BEDS + .c_beds

-                treg.total_REP = treg.total_REP + 1

-            End With

-            

-        Next i

-        

-    End If

-    

-    getREGION_by_QTR = treg.total_REP

-End Function

-

-<<<<<<
-======================
-mRM_QTR
->>>>>>
-Attribute VB_Name = "mRM_QTR"

-Option Explicit

-

-Sub btRM_QTR_Do_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    Dim i As Integer

-    Dim def_dir As String

-    Dim flist() As String

-    

-    idx = Worksheets(VAR_SHEET).Range("RM_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-'            def_dir = GetWBPath(ThisWorkbook.FullName)

-'            If GetImportDirectory(def_dir, flist) Then

-'                Dim db_list() As String

-'                i = GetDBList(flist, db_list)

-'                If i > 0 Then

-'                    ImportFromRegionalManagers db_list, GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-'                End If

-'            End If

-'            Worksheets(RM_QTR_SHEET).update_history

-        Case 2

-            Worksheets("REP_LIST").Range("ret_addr") = "RM_QTR"

-            Worksheets("REP_LIST").setEnt_date (Worksheets(RM_QTR_SHEET).getEnt_date())

-            Worksheets("REP_LIST").Range("RM_ID") = Worksheets(RM_QTR_SHEET).Range("RM_ID")

-            Worksheets("REP_LIST").Range("VIEW_ONLY") = True

-

-            Worksheets("REP_LIST").Select

-        Case 3

-            MsgBox "Функция не доступна", vbOKOnly, PROGRAM_NAME

-    End Select

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-End Sub

-

-Sub btRM_QTR_RET_IT()

-    Dim str As String

-    str = Range("ret_addr")

-    ThisWorkbook.Worksheets(str).Activate

-End Sub

-

-<<<<<<
-======================
-mImport
->>>>>>
-Attribute VB_Name = "mImport"

-    Option Explicit

-

-Const OFN_ALLOWMULTISELECT As Long = 512

-Const OFN_EXPLORER As Long = 524288

-Const OFN_HIDEREADONLY As Long = 4

-Const OFN_NONETWORKBUTTON As Long = 131072

-Const OFN_READONLY As Long = 1

-       

-Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _

-    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

-

-Private Type OPENFILENAME

-    lStructSize As Long

-    hWndOwner As Long

-    hInstance As Long

-    lpstrFilter As String

-    lpstrCustomFilter As String

-    nMaxCustFilter As Long

-    nFilterIndex As Long

-    lpstrFile As String

-    nMaxFile As Long

-    lpstrFileTitle As String

-    nMaxFileTitle As Long

-    lpstrInitialDir As String

-    lpstrTitle As String

-    flags As Long

-    nFileOffset As Integer

-    nFileExtension As Integer

-    lpstrDefExt As String

-    lCustData As Long

-    lpfnHook As Long

-    lpTemplateName As String

-End Type

-

-Function GetImportDirectory(DB_dir As String, flist() As String) As Boolean

-    Dim OpenFile As OPENFILENAME

-    Dim lReturn As Long

-    Dim sFilter As String

-    

-    OpenFile.lStructSize = Len(OpenFile)

-    '         OpenFile.hwndOwner = Form1.hWnd

-    '         OpenFile.hInstance = App.hInstance

-    sFilter = "Clexane Data Files" & Chr(0) & PROGRAM_IMPORTNAME & PROGRAM_DATAEXT & Chr(0)

-    OpenFile.lpstrFilter = sFilter

-    OpenFile.nFilterIndex = 1

-    OpenFile.lpstrFile = String(257, 0)

-    OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1

-    OpenFile.lpstrFileTitle = OpenFile.lpstrFile

-    OpenFile.nMaxFileTitle = OpenFile.nMaxFile

-    OpenFile.lpstrInitialDir = DB_dir

-    OpenFile.lpstrTitle = "Импорт данных"

-    OpenFile.flags = OFN_HIDEREADONLY + OFN_EXPLORER

-    lReturn = GetOpenFileName(OpenFile)

-    If lReturn = 0 Then

-        GetImportDirectory = False

-    Else

-        GetImportDirectory = True

- 

-        flist = Split(OpenFile.lpstrFile, Chr(0), Compare:=vbBinaryCompare)

-        Dim i As Integer

-        i = 0

-        Do While flist(i) <> ""

-            i = i + 1

-        Loop

-        If i = 1 Then

-            flist(1) = flist(0)

-            flist(0) = GetWBPath(flist(1))

-            flist(1) = GetWBName(flist(1))

-        Else

-            flist(0) = flist(0) & "\"

-        End If

-    End If

-End Function

-<<<<<<
-======================
-cPPReport
->>>>>>
-Attribute VB_Name = "cPPReport"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Const PPR_NON As Integer = 0

-Const PPR_NEW As Integer = 1

-Const PPR_OLD As Integer = 2

-

-Dim ReportApp As PowerPoint.Application

-Dim ReportDoc As PowerPoint.Presentation

-Dim ReportState As Integer

-Dim PowerPointPath As String

-

-Private Sub Class_Initialize()

-    Set ReportApp = CreateObject("PowerPoint.Application")

-    PowerPointPath = ReportApp.Path & "\PowerPNT.EXE"

-    ReportState = PPR_NON

-End Sub

-

-Sub OpenReport(FileName As String)

-    If ReportState <> PPR_NON Then

-        SaveReport

-    End If

-    Set ReportDoc = GetObject(FileName)

-    ReportState = PPR_OLD

-End Sub

-

-Sub CreateReport()

-    If ReportState <> PPR_NON Then

-        SaveReport

-    End If

-    Set ReportDoc = ReportApp.Presentations.Add

-    ReportState = PPR_NEW

-End Sub

-

-Sub SaveReport()

-    Select Case ReportState

-        Case PPR_NEW

-            ReportDoc.SaveAs GetWBPath(ThisWorkbook.FullName) + PROGRAM_FILENAME

-        Case PPR_OLD

-            ReportDoc.Save

-    End Select

-    ReportState = PPR_NON

-End Sub

-

-Sub ReportView()

-    Dim CmdName As String

-    CmdName = GetWBPath(ThisWorkbook.FullName) + PROGRAM_FILENAME + ".PPT"

-    CmdName = PowerPointPath & " " & CmdName

-    Shell CmdName, 1

-End Sub

-

-Sub InsertSlide()

-    Dim ReportPage As PowerPoint.Slide

-    Set ReportPage = ReportDoc.Slides.Add(ReportDoc.Slides.count + 1, ppLayoutBlank)

-    

-    ReportPage.Shapes.Paste

-    ReportPage.Shapes.AddLabel(msoTextOrientationHorizontal, 20, 20, 640, 40) _

-      .TextFrame.TextRange.Text = "Slide #" & Format(ReportDoc.Slides.count)

-End Sub

-

-

-Private Sub Class_Terminate()

-    SaveReport

-    ReportApp.Quit

-End Sub

-<<<<<<
-======================
-dlgImprtDB
->>>>>>
-Attribute VB_Name = "dlgImprtDB"

-Attribute VB_Base = "0{36355920-F7A4-44A8-96EF-5D79CF26137D}{F852BDF2-AB3E-468E-89DF-EC5DC0C7C88B}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Private Sub btSelAll_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = True

-    Next i

-End Sub

-

-Private Sub btUnselect_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = False

-    Next i

-End Sub

-<<<<<<
-======================
-rmImport
->>>>>>
-Attribute VB_Name = "rmImport"

-Option Explicit

-

-Public Type dbDESCRIPTION

-    Name As String

-    Fields() As String

-End Type

-

-Sub ImportFromRegionalManagers(rm_files() As String, fm_file As String)

-    Dim db(9) As dbDESCRIPTION

-    

-    '''''data

-    db(1).Name = "rep"

-    

-    db(2).Name = "lpu"

-    db(3).Name = "lpu_acs"

-    db(4).Name = "lpu_budget"

-    db(5).Name = "lpu_hir"

-    db(6).Name = "lpu_im"

-    db(7).Name = "lpu_ter"

-    db(8).Name = "quarter"

-    db(9).Name = "quarter_rm"

-    

-    ReDim db(1).Fields(5)

-    With db(1)

-        .Fields(1) = "rep_id"

-        .Fields(2) = "firstname"

-        .Fields(3) = "lastname"

-        .Fields(4) = "region"

-        .Fields(5) = "city"

-    End With

-    

-    ReDim db(2).Fields(5)

-    With db(2)

-        .Fields(1) = "id"

-        .Fields(2) = "rep_id"

-        .Fields(3) = "name"

-        .Fields(4) = "address"

-        .Fields(5) = "beds"

-    End With

-    

-    ReDim db(3).Fields(7)

-    With db(3)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "patients_with_geparins"

-        .Fields(5) = "patients_per_quarter"

-        .Fields(6) = "patients_stationar_nmg"

-        .Fields(7) = "patients_stationar_clexan"

-    End With

-    

-    ReDim db(4).Fields(6)

-    With db(4)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "bdgt_NMG"

-        .Fields(5) = "bdgt_NFG"

-        .Fields(6) = "sale_PLAN"

-    End With

-    

-    ReDim db(5).Fields(15)

-    With db(5)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "operations_per_quarter"

-        .Fields(5) = "risk_percent"

-        .Fields(6) = "patients_with_risk_ON"

-        .Fields(7) = "patients_ambulator"

-        .Fields(8) = "patients_ambulator_nmg"

-        .Fields(9) = "patients_ambulator_clexan"

-        .Fields(10) = "patients_ambulator_clexan_40mg"

-        .Fields(11) = "patients_ambulator_clexan_20mg"

-        .Fields(12) = "patients_stationar_nmg"

-        .Fields(13) = "patients_stationar_clexan"

-        .Fields(14) = "patients_stationar_clexan_40mg"

-        .Fields(15) = "patients_stationar_clexan_20mg"

-    End With

-    

-    

-    ReDim db(6).Fields(7)

-    With db(6)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "patients_with_geparins"

-        .Fields(5) = "patients_per_quarter"

-        .Fields(6) = "patients_stationar_nmg"

-        .Fields(7) = "patients_stationar_clexan"

-    End With

-    

-    ReDim db(7).Fields(11)

-    With db(7)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "patients_per_quarter"

-        .Fields(5) = "risk_percent"

-        .Fields(6) = "patients_with_risk_ON"

-        .Fields(7) = "patients_ambulator"

-        .Fields(8) = "patients_ambulator_nmg"

-        .Fields(9) = "patients_ambulator_clexan"

-        .Fields(10) = "patients_stationar_nmg"

-        .Fields(11) = "patients_stationar_clexan"

-    End With

-    

-    ReDim db(8).Fields(9)

-    With db(8)

-        .Fields(1) = "ID"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "rep_id"

-        .Fields(4) = "sale_plan"

-        .Fields(5) = "ClxnH20mg"

-        .Fields(6) = "ClxnH40mg"

-        .Fields(7) = "ClxnT40mg"

-        .Fields(8) = "ClxnC_IM"

-        .Fields(9) = "ClxnC_ACS"

-    End With

-    

-    ReDim db(9).Fields(3)

-    With db(9)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "sale_plan"

-    End With

-    

-    Dim rm_idx As Integer

-    Dim to_db As Object

-    'back uo

-    Merge_BackUp_All_Data

-    

-    'clean up

-    Merge_Clear_All_Data fm_file

-    

-    Set to_db = dbGetConnection(fm_file)

-    

-    For rm_idx = 1 To UBound(rm_files)

-        Dim from_db As Object

-        

-        Set from_db = dbGetConnection(rm_files(rm_idx))

-        

-        Dim new_rm_id As Long

-        new_rm_id = dbMergeRM(from_db, to_db)

-

-        Dim i As Integer

-

-        For i = 1 To UBound(db)

-            Dim get_sql As String

-            Dim getRS As Object

-            Dim insRS As Object

-            Dim field_idx As Integer

-                        

-            get_sql = "SELECT * FROM " & db(i).Name

-            Set getRS = CreateObject("ADODB.Recordset")

-            Set insRS = CreateObject("ADODB.Recordset")

-            insRS.Open db(i).Name, to_db, 2, 2

-

-            getRS.Open get_sql, from_db

-            

-            If Not getRS.BOF Then

-                Do While Not getRS.EOF

-                    insRS.addnew

-                    Dim fld_name As String

-                    

-                    For field_idx = 1 To UBound(db(i).Fields)

-                        fld_name = db(i).Fields(field_idx)

-                        insRS(fld_name) = getRS(fld_name)

-                    Next field_idx

-                    

-                    insRS("rm_id") = new_rm_id

-                    insRS.Update

-                    getRS.MoveNext

-                Loop

-            

-            Else

-                'empty table

-                ' do nothing

-            End If

-            

-            

-        Next i

-        

-        dbCloseOpenedConnection from_db

-    Next rm_idx

-    

-    dbCloseOpenedConnection to_db

-End Sub

-

-Function dbMergeRM(from_dbConnection As Object, to_dbConnection As Object) As Long

-

-    Dim getRecordset As Object

-    Dim getREPData_SQL As String

-    Dim REP_fn As String

-    Dim REP_ln As String

-    Dim REP_region As String

-    Dim REP_city As String

-

-

-    getREPData_SQL = "SELECT * FROM reg_man"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getREPData_SQL, from_dbConnection

-        

-        If Not getRecordset.BOF Then

-            REP_fn = getRecordset("firstname")

-            REP_ln = getRecordset("lastname")

-            REP_city = getRecordset("city")

-            REP_region = getRecordset("region")

-        Else

-            MsgBox "There is no information about Regional Manager! This database cannot be merged!!!"

-            dbMergeRM = -1

-            Exit Function

-        End If

-    

-    Dim insertRecordset As Object

-    Set insertRecordset = CreateObject("ADODB.Recordset")

-        

-    insertRecordset.Open "reg_man", to_dbConnection, 2, 2

-    insertRecordset.addnew

-        

-    insertRecordset("firstname") = REP_fn

-    insertRecordset("lastname") = REP_ln

-    insertRecordset("region") = REP_region

-    insertRecordset("city") = REP_city

-    insertRecordset.Update

-    insertRecordset.MoveLast

-    'new ID

-    dbMergeRM = insertRecordset("mgr_id")

-    

-End Function

-

-Sub cmDataImport()

-    Dim def_dir As String

-    Dim flist() As String

-    Dim i As Integer

-

-    def_dir = GetWBPath(ThisWorkbook.FullName)

-    If GetImportDirectory(def_dir, flist) Then

-        Dim ImpMask() As String

-        ImpMask = Split(flist(1), Chr(95), Compare:=vbBinaryCompare)

-        flist(1) = ImpMask(0) & "*"

-        Dim db_list() As String

-        i = GetDBList(flist(), db_list)

-        

-        If i > 0 Then

-            ImportFromRegionalManagers db_list, GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-        End If

-    End If

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).Select

-End Sub

-

-

-<<<<<<
-======================
-PRJ_QTR
->>>>>>
-Attribute VB_Name = "PRJ_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CPRJ_QT As Integer = 0

-Const CPRJ_ID As Integer = 1

-Const CPRJ_PLN As Integer = 2

-Const CPRJ_FCT As Integer = 3

-Const CPRJ_BDG As Integer = 4

-Const CPRJ_CNT As Integer = 5

-Const CPRJ_BEDS As Integer = 6

-Const CPRJ_HIR As Integer = 7

-Const CPRJ_TER As Integer = 8

-Const CPRJ_CRD As Integer = 9

-Const CPRJ_CLXN_BDG As Integer = 10

-Const CPRJ_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Const LOCAL_ENT_DATE As String = "B11"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("PRJ_QTR")

-        s = "Все регионы, " & .getEnt_date()

-    End With

-    

-    MakeChartTitle = s

-End Function

-

-Sub update_history()

-    Dim objQTR() As tREGION

-    Dim i As Long

-    Dim r As Range

-

-

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetRGN_COMM_DATA(objQTR(), 0)

-    

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CPRJ_QT) = objQTR(i).ent_date

-            r.Offset(i - 1, CPRJ_ID) = ""

-            r.Offset(i - 1, CPRJ_PLN) = objQTR(i).sale_PLAN

-            r.Offset(i - 1, CPRJ_FCT) = objQTR(i).total_SALE

-            r.Offset(i - 1, CPRJ_BDG) = objQTR(i).total_BDGT

-            r.Offset(i - 1, CPRJ_CNT) = objQTR(i).total_LPU

-            r.Offset(i - 1, CPRJ_BEDS) = objQTR(i).total_REP

-            r.Offset(i - 1, CPRJ_HIR) = objQTR(i).total_HIR

-            r.Offset(i - 1, CPRJ_TER) = objQTR(i).total_TER

-            r.Offset(i - 1, CPRJ_CRD) = objQTR(i).total_ACS

-            If objQTR(i).total_BDGT <> 0 Then

-                r.Offset(i - 1, CPRJ_CLXN_BDG) = objQTR(i).total_SALE / objQTR(i).total_BDGT

-            End If

-            If objQTR(i).total_BDGT_NMG <> 0 Then

-                r.Offset(i - 1, CPRJ_CLXN_NMG) = objQTR(i).total_SALE / objQTR(i).total_BDGT_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR_PRJ()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(PRJ_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CPRJ_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CPRJ_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CPRJ_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CPRJ_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CPRJ_CRD + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-

-Sub Draw_PLN_QTR_PRJ()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(PRJ_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CPRJ_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CPRJ_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CPRJ_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CPRJ_FCT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PLN_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Draw_BDGT_QTR_PRJ()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(PRJ_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CPRJ_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CPRJ_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CPRJ_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CPRJ_CLXN_NMG + 1)

-        End If

-    Next i

-    Worksheets("CHRT_BDGT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-Public Sub cbxPRJ_QtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR_PRJ

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR_PRJ

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR_PRJ

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = PRJ_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    Protect UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CPRJ_QT + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    If r = "" Then

-        Worksheets(VAR_SHEET).Range("PRJ_ACTION") = 2

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        Worksheets(VAR_SHEET).Range("PRJ_ACTION") = 2

-        Range("LAST_FOCUS") = currRange.address

-        With Worksheets("REP_LIST")

-            .Range("ret_addr") = "PRJ_QTR"

-            .Range("ent_date") = r

-            .Range("VIEW_ONLY") = True

-        End With

-    End If

-    Cancel = True

-    btPRJ_QTR_Do_IT ' old btRM_OTR_DO_IT

-End Sub

-

-<<<<<<
-======================
-RM_LIST
->>>>>>
-Attribute VB_Name = "RM_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Const LOCAL_ENT_DATE As String = "C10"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-

-Public Function getCurrentRM_ID() As Long

-    Dim r As Range

-

-    With Worksheets("RM_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CRM_ID)

-    End With

-

-    getCurrentRM_ID = r

-End Function

-

-Public Sub RM_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("PM_CHR_IDX")

-        Case 1

-            Rm_Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Rm_Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Rm_Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-

-        Case 4

-            Rm_Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectRM_QTR(rm_id As Long)

-    Dim vo As Boolean

-

-    Range("JUMP") = "RM_QTR"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("RM_QTR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "RM_LIST"

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Public Sub SelectREP_LIST(rm_id As Long)

-    Dim vo As Boolean

-

-    Range("JUMP") = "REP_LIST"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("REP_LIST")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "RM_LIST"

-        .setEnt_date (getEnt_date())

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateRMList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Sub UpdateRMList()

-    Dim rmcd() As tRMID_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-

-    ent_date = getEnt_date

-

-    i = Get_RM_CommonList_by_QTR(rmcd(), ent_date)

-

-    With ThisWorkbook.Worksheets("RM_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(rmcd)

-            r.Offset(i - 1, CRM_NAME) = GetRegionName(rmcd(i).rm.Region)

-            r.Offset(i - 1, CRM_ID) = rmcd(i).rm.rm_id

-            r.Offset(i - 1, CRM_BEDS) = rmcd(i).rgcd(1).total_BEDS

-            r.Offset(i - 1, CRM_BDGT) = rmcd(i).rgcd(1).total_BDGT

-            r.Offset(i - 1, CRM_NMG) = rmcd(i).rgcd(1).total_BDGT_NMG

-            r.Offset(i - 1, CRM_HIR) = rmcd(i).rgcd(1).total_HIR

-            r.Offset(i - 1, CRM_TER) = rmcd(i).rgcd(1).total_TER

-            r.Offset(i - 1, CRM_CAR) = rmcd(i).rgcd(1).total_ACS

-            r.Offset(i - 1, CRM_FACT) = rmcd(i).rgcd(1).total_SALE

-            r.Offset(i - 1, CRM_PLAN) = rmcd(i).rgcd(1).sale_PLAN

-            

-            With rmcd(i).rgcd(1)

-                r.Offset(i - 1, CRM_PAT_LPU) = .total_HIR + .total_TER + .total_ACS

-            End With

-            

-            r.Offset(i - 1, CRM_BDGT_1) = rmcd(i).rgcd(1).total_BDGT

-            If rmcd(i).rgcd(1).total_BDGT > 0 Then

-                r.Offset(i - 1, CRM_BDGT_1 + 1) = rmcd(i).rgcd(1).total_SALE / rmcd(i).rgcd(1).total_BDGT

-            End If

-            If r.Offset(i - 1, CRM_BDGT_1 + 1) > 1 Then

-                r.Offset(i - 1, CRM_BDGT_1 + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim rep_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CRM_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CRM_AREA).row, CRM_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    rep_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CRM_AREA).Column

-

-    If i < 4 Then

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 1

-    Else

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 2

-    End If

-

-    If rep_id = 0 Then

-        Range("LAST_FOCUS") = Range(CRM_AREA).address

-    End If

-

-    If rep_id = 0 Then

-        i = CRM_NAME

-        Range("JUMP") = ""

-    Else

-        btRM_LIST_DO_IT

-    End If

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-<<<<<<
-======================
-mPRJ_QTR
->>>>>>
-Attribute VB_Name = "mPRJ_QTR"

-Sub btPRJ_QTR_Do_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    

-    idx = Worksheets(VAR_SHEET).Range("PRJ_ACTION")

-    ent_date = Worksheets(PRJ_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            cmDataImport

-        Case 2

-            Worksheets("RM_LIST").setEnt_date (Worksheets("PRJ_QTR").getEnt_date())

-            Worksheets("RM_LIST").Range("ret_addr") = "PRJ_QTR"

-            Worksheets("RM_LIST").Select

-        Case 3

-            cmNewReport

-    End Select

-    Worksheets(VAR_SHEET).Range("PRJ_ACTION") = 2

-End Sub

-

-

-<<<<<<
-======================
-mRM_LIST
->>>>>>
-Attribute VB_Name = "mRM_LIST"

-Option Explicit

-

-Public Const CRM_AREA As String = "B12"

-Public Const CRM_NAME As Integer = 0

-Public Const CRM_NAME1 As Integer = 1

-Public Const CRM_NAME2 As Integer = 2

-Public Const CRM_ID As Integer = 3

-Public Const CRM_BEDS As Integer = 4

-Public Const CRM_BDGT As Integer = 5

-Public Const CRM_NMG As Integer = 6

-Public Const CRM_HIR As Integer = 7

-Public Const CRM_TER As Integer = 8

-Public Const CRM_CAR As Integer = 9

-Public Const CRM_FACT As Integer = 10

-Public Const CRM_PLAN As Integer = 11

-Public Const CRM_PAT_LPU As Integer = 16

-Public Const CRM_BDGT_1 As Integer = 17

-

-

-Const LOCAL_ENT_DATE As String = "C10"

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Sub EditREP(CRM As tREPID, ent_date As String)

-    NoFunc

-End Sub

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("RM_LIST")

-        s = "Регионы, " & .getEnt_date()

-    End With

-    

-    MakeChartTitle = s

-End Function

-

-Sub Rm_Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_LPU_BBL").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rm_Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRM_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRM_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRM_FACT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PIE").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rm_Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CRM_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRM_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRM_HIR + 1)

-            psum = psum + src.Cells(i, CRM_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRM_TER + 1)

-            psum = psum + src.Cells(i, CRM_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRM_CAR + 1)

-            psum = psum + src.Cells(i, CRM_CAR + 1)

-            dst.Cells(i, 5) = psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU").Range("title") = MakeChartTitle

-    

-End Sub

-

-Sub Rm_Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CRM_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRM_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRM_HIR + 1)

-            psum = psum + src.Cells(i, CRM_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRM_TER + 1)

-            psum = psum + src.Cells(i, CRM_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRM_CAR + 1)

-            psum = psum + src.Cells(i, CRM_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CRM_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU_A").Range("title") = MakeChartTitle

-    

-End Sub

-

-Sub btRM_LIST_RET_IT()

-    With Worksheets("RM_LIST")

-        .setEnt_date ("")

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = "PRJ_QTR"

-    End With

-    ThisWorkbook.Worksheets("PRJ_QTR").Activate

-End Sub

-

-

-Sub btRM_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim rm_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("RM_LIST_ACTION")

-    With Worksheets("RM_LIST")

-        rm_id = .getCurrentRM_ID()

-        

-        Select Case i

-            Case 1:

-                .SelectRM_QTR rm_id

-            Case 2:

-                .SelectREP_LIST rm_id

-            End Select

-    End With

-    

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-

-

-

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mImport2
->>>>>>
-Attribute VB_Name = "mImport2"

-Option Explicit

-

-Sub FOpen()

-    Dim flist As String

-    Dim fileToOpen, s

-    flist = ""

-    fileToOpen = Application _

-        .GetOpenFileName("Data Files (*.mdb), mr*.mdb", Title:="Импорт данных", MultiSelect:=True)

-    If fileToOpen <> False Then

-        For Each s In fileToOpen

-            flist = flist & s & "; "

-        Next s

-        MsgBox "Open " & flist

-    End If

-End Sub

-

-Sub t2()

-Dim d As ImprtDB

-Set d = New ImprtDB

-d.Show

-

-End Sub

-

-<<<<<<
-======================
-ImprtDB
->>>>>>
-Attribute VB_Name = "ImprtDB"

-Attribute VB_Base = "0{67FA6A28-8370-4981-8F01-1A9079245761}{ECFCB43F-B241-4CD9-9CB3-2A981933173D}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btSelAll_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = True

-    Next i

-End Sub

-

-Private Sub btUnselect_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = False

-    Next i

-End Sub

-<<<<<<
-======================
-mImport
->>>>>>
-Attribute VB_Name = "mImport"

-    Option Explicit

-

-Const OFN_ALLOWMULTISELECT As Long = 512

-Const OFN_EXPLORER As Long = 524288

-Const OFN_HIDEREADONLY As Long = 4

-Const OFN_NONETWORKBUTTON As Long = 131072

-Const OFN_READONLY As Long = 1

-       

-Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _

-  "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

-

-Private Type OPENFILENAME

-  lStructSize As Long

-  hWndOwner As Long

-  hInstance As Long

-  lpstrFilter As String

-  lpstrCustomFilter As String

-  nMaxCustFilter As Long

-  nFilterIndex As Long

-  lpstrFile As String

-  nMaxFile As Long

-  lpstrFileTitle As String

-  nMaxFileTitle As Long

-  lpstrInitialDir As String

-  lpstrTitle As String

-  flags As Long

-  nFileOffset As Integer

-  nFileExtension As Integer

-  lpstrDefExt As String

-  lCustData As Long

-  lpfnHook As Long

-  lpTemplateName As String

-End Type

-

-Private Sub Command1_Click()

-  Dim OpenFile As OPENFILENAME

-  Dim lReturn As Long

-  Dim sFilter As String

-  OpenFile.lStructSize = Len(OpenFile)

-'         OpenFile.hwndOwner = Form1.hWnd

-'         OpenFile.hInstance = App.hInstance

-  sFilter = "Clexane Data Files" & Chr(0) & "mr*.mdb" & Chr(0)

-  OpenFile.lpstrFilter = sFilter

-  OpenFile.nFilterIndex = 1

-  OpenFile.lpstrFile = String(257, 0)

-  OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1

-  OpenFile.lpstrFileTitle = OpenFile.lpstrFile

-  OpenFile.nMaxFileTitle = OpenFile.nMaxFile

-' OpenFile.lpstrInitialDir = "C:\"

-  OpenFile.lpstrTitle = "Импорт данных"

-  OpenFile.flags = OFN_HIDEREADONLY + OFN_ALLOWMULTISELECT + OFN_EXPLORER

-  lReturn = GetOpenFileName(OpenFile)

-  If lReturn = 0 Then

-     MsgBox "The User pressed the Cancel Button"

-  Else

-     MsgBox "The user Chose " & Trim(OpenFile.lpstrFile)

-  End If

-End Sub

-

-<<<<<<
-Project Name : 'ClexaneRM'
-Quirk - duff tag length======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    ThisWorkbook.Worksheets(RM_QTR_SHEET).ClearRMName

-    

-    Application.EnableEvents = True

-    Set MyAppEvents.app = Application

-    

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    

-    MyAppEvents.CheckWorkBooksArround ThisWorkbook

-    

-    cmSetStandaloneMode

-    

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-    

-    Application.ScreenUpdating = True

-    

-    If CheckUser Then

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).update_history

-        Application.Calculate

-    End If

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    

-    Dim RestMode As Boolean

-    RestMode = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE")

-    

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-'        If RestMode Then

-            ThisWorkbook.Saved = True

-'        Else

-'            ThisWorkbook.Save

-'        End If

-    End If

-    Application.Caption = Empty

-    Application.CommandBars(STDBAR_NAME).Reset

-    If RestMode Then

-        xlRestoreView

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    End If

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-    Dim MaxX, MaxY As Integer

-    With ThisWorkbook.Worksheets(TITLE_SHEET)

-        MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-        MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-    End With

-

-    With ThisWorkbook.Application

-        .ScreenUpdating = False

-        .WindowState = xlNormal

-        .Height = MaxY

-        .Width = MaxX

-    End With

-End Sub

-

-

-

-

-

-<<<<<<
-======================
-REP_QTR
->>>>>>
-Attribute VB_Name = "REP_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CQTR_QT As Integer = 0

-Const CQTR_ID As Integer = 1

-Const CQTR_PLN As Integer = 2

-Const CQTR_FCT As Integer = 3

-Const CQTR_BDG As Integer = 4

-Const CQTR_CNT As Integer = 5

-Const CQTR_BEDS As Integer = 6

-Const CQTR_HIR As Integer = 7

-Const CQTR_TER As Integer = 8

-Const CQTR_CRD As Integer = 9

-Const CQTR_CLXN_BDG As Integer = 10

-Const CQTR_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub update_history()

-    Dim objQTR() As tQTR

-    Dim i As Long

-    Dim r As Range

-    Dim cRep As tREPID

-

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    Range("D4") = cRep.LastName

-    Range("D5") = cRep.FirstName

-

-    Range("H4") = GetRegionName(cRep.Region)

-    Range("H5") = GetCityName(cRep.Region, cRep.City)

-

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetAll_QTR_Records_by_REP(objQTR, "%", cRep.rep_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CQTR_QT) = objQTR(i).entry_date

-        Next i

-    End If

-    Dim qcd() As tQTR_COMMON

-    i = Get_QTR_CommonList_by_REP(qcd, "%", cRep.rep_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(qcd)

-            r.Offset(i - 1, CQTR_QT) = qcd(i).qtr.entry_date

-            r.Offset(i - 1, CQTR_ID) = qcd(i).qtr.id

-            r.Offset(i - 1, CQTR_PLN) = qcd(i).qtr.sale_PLAN

-            r.Offset(i - 1, CQTR_FCT) = qcd(i).c_sale_ALL

-            r.Offset(i - 1, CQTR_BDG) = qcd(i).c_bdgt_LPU

-            r.Offset(i - 1, CQTR_CNT) = qcd(i).i_lcd

-            r.Offset(i - 1, CQTR_BEDS) = qcd(i).c_beds

-            r.Offset(i - 1, CQTR_HIR) = qcd(i).c_pat_HIR

-            r.Offset(i - 1, CQTR_TER) = qcd(i).c_pat_TER

-            r.Offset(i - 1, CQTR_CRD) = qcd(i).c_pat_CRD

-            If qcd(i).c_bdgt_LPU <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_BDG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_LPU

-            End If

-            If qcd(i).c_bdgt_NMG <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_NMG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CQTR_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRepQtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect UserInterfaceOnly:=True

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CQTR_ID + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    i = currRange.Column - Range(CINP_AREA).Column

-

-    QTR_ID = r

-

-    If QTR_ID = 0 Then

-        Worksheets(VAR_SHEET).Range("USER_ACTION") = 1

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        If i > CQTR_FCT Then

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-            Range("LAST_FOCUS") = currRange.address

-        Else

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 3

-            Range("LAST_FOCUS") = currRange.address

-        End If

-    End If

-    Cancel = True

-    btHomeDo_IT

-End Sub

-

-<<<<<<
-======================
-mRep_QTR
->>>>>>
-Attribute VB_Name = "mRep_QTR"

-Option Explicit

-

-Sub NoFunc()

-    MsgBox "Функция не доступна", vbOKOnly, PROGRAM_NAME

-End Sub

-

-Sub DO_Price_qtr(ent_date As String)

-    Dim qtr As tQTR

-    Dim res As Integer

-    Dim cRep As tREPID

-

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    qtr = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-

-    If qtr.id = 0 Then

-        qtr.entry_date = ent_date

-

-        With Worksheets(VAR_SHEET)

-            qtr.ClxnH20mg = .Range("ClxnH20mg")

-            qtr.ClxnH40mg = .Range("ClxnH40mg")

-            qtr.ClxnT40mg = .Range("ClxnT40mg")

-            qtr.ClxnC_ACS = .Range("ClxnC_ACS")

-            qtr.ClxnC_IM = .Range("ClxnC_IM")

-        End With

-    End If

-

-    Dim dlg_nq As dlg_nextQTR

-    Set dlg_nq = New dlg_nextQTR

-

-    With dlg_nq

-        .tb_qtr_name = qtr.entry_date

-        .tb_bdgt_avts = qtr.sale_PLAN

-        .tb_qtr_name = qtr.entry_date

-        .tb_ClxnH20mg = qtr.ClxnH20mg

-        .tb_ClxnH40mg = qtr.ClxnH40mg

-        .tb_ClxnT40mg = qtr.ClxnT40mg

-        .tb_ClxnC_ACS = qtr.ClxnC_ACS

-        .tb_ClxnC_IM = qtr.ClxnC_IM

-    End With

-

-    dlg_nq.Show

-End Sub

-

-Sub DO_Edit_qtr(ent_date As String)

-    If ent_date = "" Then

-        NoFunc

-    Else

-        Dim rep_id As Long

-        rep_id = Worksheets(REP_QTR_SHEET).Range("REP_ID")

-        With ThisWorkbook.Worksheets("LPU_LIST")

-            .Range("VIEW_ONLY") = True

-            .Range("ent_date") = ent_date

-            .Range("REP_ID") = rep_id

-            .Select

-        End With

-    End If

-End Sub

-

-Sub DO_Delete_qtr(ent_date As String)

-    If ent_date <> "" Then

-        MsgBox "Удалить данные за период [" & ent_date & "] нельзя ", vbOKOnly, PROGRAM_NAME

-    End If

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-

-Sub btHomeDo_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    idx = Worksheets(VAR_SHEET).Range("USER_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            NoFunc

-            ' Обновляем экран

-        Case 2

-            DO_Edit_qtr ent_date

-        Case 3

-            DO_Price_qtr ent_date

-        Case 4

-            NoFunc

-    End Select

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-Sub Delete_qtr()

-'    Dim ent_date As String

-'    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-'    DO_Delete_qtr ent_date

-End Sub

-

-Sub btREP_QTR_RET_IT()

-    Dim s As String

-    With Worksheets("REP_QTR")

-        .Range("LAST_FOCUS") = ""

-        s = .Range("ret_addr")

-        .Range("ret_addr") = ""

-    End With

-    If s <> "" Then

-        ThisWorkbook.Worksheets(s).Select

-    Else

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane[RM]"

-Public Const PROGRAM_VERSION As String = "version 1.3"

-Public Const PROGRAM_FILENAME As String = "clexane-rm"

-Public Const PROGRAM_BACKUPNAME As String = "rm-backup-"

-Public Const PROGRAM_EXPORTNAME As String = "rm-ex-"

-Public Const PROGRAM_IMPORTNAME As String = "mr-ex-*"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20030329

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "O40"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-Public Const RM_QTR_SHEET As String = "RM_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-

-End Sub

-

-Function Double2Str(ByVal d As Double, ByVal precision As Integer, Optional Delim As String = ".") As String

-    Dim s As String

-    If Not precision > 0 Then

-        s = Round(d)

-    Else

-        Dim i As Integer

-        i = Fix(d)

-        s = i & Delim

-        d = Abs(d - i)

-        Do

-            precision = precision - 1

-            d = d * 10

-            If precision > 0 Then

-                i = Fix(d)

-            Else

-                i = Round(d)

-            End If

-            If i < 1 Then

-                s = s & "0"

-            Else

-                s = s & i

-                d = d - i

-            End If

-        Loop While precision > 0

-    End If

-    Double2Str = s

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetWBName(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBName = Right(FullName, s_len - pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.name = VAR_SHEET Or sh.name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-<<<<<<
-======================
-Var
->>>>>>
-Attribute VB_Name = "Var"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-title
->>>>>>
-Attribute VB_Name = "title"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LPU_LIST
->>>>>>
-Attribute VB_Name = "LPU_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentLPU_ID() As Long

-    Dim r As Range

-

-    With Worksheets("LPU_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CLPU_ID)

-    End With

-

-    getCurrentLPU_ID = r

-End Function

-

-Public Sub LPU_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectLPU_NAME(lpu_id As Long, ent_date As String)

-    If Range("VIEW_ONLY") = True Then

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    Dim cLPU As tLPU

-    If lpu_id = 0 Then

-        cLPU.id = 0

-        cLPU.rep_id = 0

-        cLPU.address = ""

-        cLPU.name = ""

-    Else

-        cLPU = Get_LPU_Record(lpu_id)

-    End If

-    EditLPU cLPU, getEnt_date

-    Worksheet_Activate

-End Sub

-

-Sub SelectLPU_BDGT(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    vo = Range("VIEW_ONLY")

-    If lpu_id = 0 Then

-        SelectLPU_NAME lpu_id, ent_date

-    Else

-        With ThisWorkbook.Worksheets("LPU_BDGT")

-            .Range("VIEW_ONLY") = vo

-            .Range("ret_addr") = "LPU_LIST"

-            .Range("REP_ID") = r_id

-            .Range("ent_date") = ent_date

-            .Range("lpu_id") = lpu_id

-        End With

-    End If

-End Sub

-

-Sub SelectLPU_HIR(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_HIR")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Sub SelectLPU_TER(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_TER")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Sub SelectLPU_C_ACS(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_C_ACS")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect UserInterfaceOnly:=True

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateLPUList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim lpu_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CINP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CINP_AREA).row, CLPU_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    lpu_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CINP_AREA).Column

-

-    If lpu_id = 0 Then

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    End If

-

-    If lpu_id = 0 Then

-        i = CLPU_NAME

-        Range("JUMP") = ""

-    End If

-    Select Case i

-        Case CLPU_NAME, CLPU_NAME1, CLPU_NAME2, CLPU_BEDS

-            SelectLPU_NAME lpu_id, ent_date

-            Range("JUMP") = ""

-

-        Case CLPU_NMG, CLPU_NFG, CLPU_PLAN, CLPU_FACT

-            SelectLPU_BDGT lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-

-        Case CLPU_HIR

-            SelectLPU_HIR lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_HIR"

-

-        Case CLPU_TER

-            SelectLPU_TER lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_TER"

-

-        Case CLPU_CAR

-            SelectLPU_C_ACS lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        Case Else

-            Range("JUMP") = ""

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateLPUList()

-    Dim lcd() As tLPU_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-    Dim objQTR As tQTR

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    ent_date = getEnt_date

-

-'     ent_date = "%" ' % - all records

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-    i = Get_LPU_CommonQTR(lcd, objQTR)

-

-'     стираем ФИО

-    Range("C3:C4").ClearContents

-

-    Range("C3") = cRep.LastName

-    Range("C4") = cRep.FirstName

-    Range("G3") = GetRegionName(cRep.Region)

-    Range("G4") = GetCityName(cRep.Region, cRep.City)

-    Range("G5") = objQTR.sale_PLAN

-

-

-

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(lcd)

-            r.Offset(i - 1, CLPU_NAME) = lcd(i).lpu.name

-            r.Offset(i - 1, CLPU_ID) = lcd(i).lpu.id

-            r.Offset(i - 1, CLPU_BEDS) = lcd(i).lpu.beds

-

-

-            r.Offset(i - 1, CLPU_NFG) = lcd(i).bdgt.bdgt_NFG

-            r.Offset(i - 1, CLPU_NMG) = lcd(i).bdgt.bdgt_NMG

-            r.Offset(i - 1, CLPU_PLAN) = lcd(i).bdgt.sale_PLAN

-

-            r.Offset(i - 1, CLPU_HIR) = lcd(i).pat_HIR

-            r.Offset(i - 1, CLPU_TER) = lcd(i).pat_TER

-            r.Offset(i - 1, CLPU_CAR) = lcd(i).pat_CRD

-            r.Offset(i - 1, CLPU_FACT) = lcd(i).sale_ALL

-            r.Offset(i - 1, CLPU_PAT_LPU) = lcd(i).pat_LPU

-            r.Offset(i - 1, CLPU_BDGT) = lcd(i).bdgt_LPU

-            If lcd(i).bdgt_LPU > 0 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = lcd(i).sale_ALL / lcd(i).bdgt_LPU

-            End If

-            If r.Offset(i - 1, CLPU_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{F2A5159C-AEB6-4066-B85F-339184DAFECD}{712D78F6-CCB6-499E-9674-B992A7482317}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-dbACS
->>>>>>
-Attribute VB_Name = "dbACS"

-Option Explicit

-

-Public Type tACS

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    patients_with_geparins As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objACS.ID <> 0 then updatre else insert

-Sub Insert_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objACS.id <> 0 Then

-        dbUpdate_ACS_Record dbConnection, objACS

-    Else

-        dbInsert_ACS_Record dbConnection, objACS

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_ACS_RecordsByLPU_ID(ByRef all_ACS_() As tACS, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_ACS_RecordsByLPU_ID = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, all_ACS_, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_ACS_Record dbConnection, objACS

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub dbInsert_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_acs", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objACS

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("patients_with_geparins") = .patients_with_geparins

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objACS.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim Update_SQL As String

-    

-    With objACS

-        Update_SQL = "UPDATE lpu_acs SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "patients_with_geparins=" & .patients_with_geparins & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_ACS_RecordsbyLPU_ID(dbConnection As Object, all_ACS() As tACS, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_ACS_SQL As String

-    Dim getAll_ACS_SQL As String

-    Dim ACS_Count As Long

-    ACS_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_ACS_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        ACS_Count = dbRecordset("ACS_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_ACS_RecordsbyLPU_ID = ACS_Count

-    

-    If ACS_Count > 0 Then

-        'we have records

-        ReDim all_ACS(1 To ACS_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_ACS_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_ACS As tACS

-                 With tmp_ACS

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .patients_with_geparins = dbRecordset("patients_with_geparins")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 all_ACS(index) = tmp_ACS

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE ID=" & objACS.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_ACS_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_HIR
->>>>>>
-Attribute VB_Name = "LPU_CLSN_HIR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-

-        Dim objHir As tHIRURGIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objHir

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .operations_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L9")

-                .patients_ambulator_clexan_20mg = Range("L10")

-                .patients_ambulator_clexan_40mg = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L19")

-                .patients_stationar_clexan_20mg = Range("L20")

-                .patients_stationar_clexan_40mg = Range("L21")

-            End With

-            Insert_Hir_Record objHir

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objHir.id = Range("rec_id")

-                    If objHir.id <> 0 Then

-                        Delete_Hir_Record objHir

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objHir As tHIRURGIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    With objHir

-        Range("rec_id") = .id

-        Range("F6") = .operations_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L9") = .patients_ambulator_clexan

-        Range("L10") = .patients_ambulator_clexan_20mg

-        Range("I21") = .patients_stationar_nmg

-        Range("L19") = .patients_stationar_clexan

-        Range("L20") = .patients_stationar_clexan_20mg

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id)

-

-        formula = "=" & qtr.ClxnH20mg & "*($L$10+$L$20)+" & qtr.ClxnH40mg & "*($L$11+$L$21)"

-        Range("F11").formula = formula

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objHir() As tHIRURGIA

-        Dim i As Integer

-        i = GetAll_Hir_RecordsByLPU_ID(objHir, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.3

-        Else

-            SetupData objHir(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-mSapes
->>>>>>
-Attribute VB_Name = "mSapes"

-Option Explicit

-

-Const SHAPE_COLOR As Integer = 1

-Const SHAPE_NAME As Integer = 2

-

-

-Sub ShapeView(r_sh_finite_state As Range)

-    Dim chk As Range

-    Dim s As String

-    Dim c, idx As Integer

-    For Each chk In r_sh_finite_state

-        idx = 0

-        If chk = "+" Then

-            c = chk.Offset(0, idx + SHAPE_COLOR)

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While c <> 0

-                ShapeFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s)), c

-                idx = idx + 2

-                c = chk.Offset(0, idx + SHAPE_COLOR)

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        Else

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While s <> ""

-                ShapeUnFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s))

-                idx = idx + 2

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        End If

-    Next chk

-End Sub

-

-Sub ShapeFill(sh As ShapeRange, ByVal color As Integer)

-    sh.Fill.Visible = msoTrue

-    sh.Fill.Solid

-    sh.Fill.ForeColor.SchemeColor = color

-    sh.Fill.Transparency = 0#

-End Sub

-

-Sub ShapeUnFill(sh As ShapeRange)

-    sh.Fill.Visible = msoFalse

-    sh.Fill.Transparency = 0#

-End Sub

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Public Const INPUT_NO = 0

-Public Const INPUT_NUMBER = 1

-Public Const INPUT_PERCENT = 2

-Public Const INPUT_STRING = 3

-Public Const INPUT_CHECK = 4

-

-Public Const INP_IDX_TYPE = 1

-Public Const INP_IDX_NEXT = 2

-Public Const INP_IDX_MIN = 3

-Public Const INP_IDX_MAX = 4

-Public Const INP_IDX_DEP = 5

-Public Const INP_IDX_ALT = 7

-

-

-Public Type tInputSet

-    vType As Integer

-    vMin As Long

-    vMax As Long

-    rChk As String

-End Type

-

-Function is_input_cell(ByVal Target As Range, inputs As Range) As tInputSet

-    Dim t As Range

-    Dim iset As tInputSet

-    Dim test As Range

-    iset.vType = INPUT_NO

-    iset.vMin = 0

-    iset.vMax = 0

-    iset.rChk = ""

-    is_input_cell = iset

-

-' Закоментировать следующую сточку для работы

-'  Exit Function

-

-    Set test = Target.Cells(1, 1)

-    For Each t In inputs

-        If Range(t).Column = test.Column And Range(t).row = test.row Then

-            iset.vType = t.Offset(0, INP_IDX_TYPE).Value

-            Select Case iset.vType

-                Case INPUT_CHECK

-                    iset.rChk = t.Offset(0, INP_IDX_ALT)

-                Case INPUT_NUMBER, INPUT_PERCENT

-                    iset.vMin = t.Offset(0, INP_IDX_MIN).Value

-                    iset.vMax = t.Offset(0, INP_IDX_MAX).Value

-            End Select

-            is_input_cell = iset

-            Exit Function

-        End If

-    Next t

-End Function

-

-Function GetFocusAddress(ByVal r As Range, f_next As Range) As String

-    Dim chk, t As Range

-    

-    For Each chk In f_next

-        For Each t In r

-            If t.address = chk Then

-                GetFocusAddress = chk

-                Exit Function

-            End If

-            If Range(chk).Column = t.Column - 1 And Range(chk).row = t.row _

-            Or Range(chk).Column = t.Column And Range(chk).row = t.row - 1 _

-            Then

-                If Range(chk) <> "" Then

-                    If Range(chk) = 0 Then

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_ALT)).address

-                    Else

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_NEXT)).address

-                    End If

-                Else

-                    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-                End If

-                Exit Function

-            End If

-        Next t

-    Next chk

-    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-End Function

-

-Sub SetDependet(r As Range, inputs As Range)

-    Dim chk As Range

-    Dim s, serr As String

-    Dim idx As Integer

-    Dim iset As tInputSet

-    Dim err_found As Boolean

-    

-    If r.count > 1 Then

-        Exit Sub

-    End If

-    

-    err_found = False

-    For Each chk In inputs

-        idx = INP_IDX_DEP

-        

-        

-        iset.vType = chk.Offset(0, INP_IDX_TYPE).Value

-        Select Case iset.vType

-            Case INPUT_NUMBER, INPUT_PERCENT

-                iset.vMin = chk.Offset(0, INP_IDX_MIN).Value

-                iset.vMax = chk.Offset(0, INP_IDX_MAX).Value

-                

-                If Range(chk) > iset.vMax Then

-                    err_found = True

-                    Range(chk) = iset.vMax

-                    serr = "Выход за дозволенный диапазон [" & iset.vMin & ".." & iset.vMax & "]! Данные скорректированы."

-                End If

-                

-                If Range(chk) = "" Then

-                    s = chk.Offset(0, idx)

-                    Do While s <> ""

-                        Range(s) = ""

-                        idx = idx + 1

-                        s = chk.Offset(0, idx)

-                    Loop

-                End If

-        End Select

-    Next chk

-    If err_found Then

-        MsgBox serr, vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Function CheckInputData(inputs As Range) As Boolean

-    Dim r As Range

-    

-    CheckInputData = True

-    For Each r In inputs

-        If Range(r) = "" Then

-            CheckInputData = False

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100.", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Sub Check_Int_Number(Target As Range, Def_Val As Long)

-    Dim err As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    err = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                err = True

-            End If

-        End If

-    Next r

-    If err Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_TER
->>>>>>
-Attribute VB_Name = "LPU_CLSN_TER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim objTer As tTERAPIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objTer

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .patients_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L20")

-            End With

-            Insert_Ter_Record objTer

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objTer.id = Range("rec_id")

-                    If objTer.id <> 0 Then

-                        Delete_Ter_Record objTer

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objTer As tTERAPIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    With objTer

-        Range("rec_id") = .id

-        Range("F6") = .patients_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L11") = .patients_ambulator_clexan

-        Range("I21") = .patients_stationar_nmg

-        Range("L20") = .patients_stationar_clexan

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id)

-        formula = "=" & qtr.ClxnT40mg & "*($L$12+$L$20)"

-        Range("F11").formula = formula

-

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objTer() As tTERAPIA

-        Dim i As Integer

-        i = GetAll_Ter_RecordsByLPU_ID(objTer, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.25

-        Else

-            SetupData objTer(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{5D2CB2D2-3E5E-4B6E-9E0C-2EEBA5E10E17}{C891C133-B6B4-43D3-B411-B4A821905C23}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-LPU_BDGT
->>>>>>
-Attribute VB_Name = "LPU_BDGT"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub SetDefFocus()

-    Range(Range("DEF_FOCUS")).Select

-End Sub

-

-Public Sub ClearData()

-    ClearSheetData

-End Sub

-

-Sub ClearSheetData()

-    If Range("F10") = 0 And Range("F13") = 0 Then

-        Range("F11:F18") = ""

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("F11:F13") = ""

-    End If

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim bdgt As tBUDGET

-        Dim test As Boolean

-        Dim sum As Long

-        With bdgt

-            .lpu_id = Range("lpu_id")

-            .id = Range("rec_id")

-            .entry_date = Range("ent_date")

-            .bdgt_NMG = Round(Range("F11").Value, 0)

-            .bdgt_NFG = Round(Range("F12").Value, 0)

-            .sale_PLAN = Round(Range("F13").Value, 0)

-

-            sum = .bdgt_NFG + .bdgt_NMG - .sale_PLAN

-            test = .bdgt_NFG <> 0 Or .bdgt_NMG <> 0 Or .sale_PLAN <> 0

-        End With

-        If test Then

-            If sum < 0 Then

-                MsgBox _

-                    "Ваш план превышает выделенный на гепарины бюджет. Сохранить данные?", _

-                    vbOKOnly, PROGRAM_NAME

-            End If

-            If test Then

-                Insert_BDGT_Record bdgt

-            End If

-        Else

-            If bdgt.id <> 0 Then

-                If vbYes = MsgBox("Удалить данные из базы!", vbYesNo, PROGRAM_NAME) Then

-                    Delete_BDGT_Record bdgt

-                End If

-                ret_back Range("DEF_FOCUS").Worksheet

-                Exit Sub

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-    End If

-

-   ClearData

-   ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(cLPU As tLPU_COMMON)

-    Dim t_sum As Long

-    t_sum = 0

-' Setup budget data

-    Range("F11") = cLPU.bdgt.bdgt_NMG

-    Range("F12") = cLPU.bdgt.bdgt_NFG

-    Range("F13") = cLPU.bdgt.sale_PLAN

-

-    With cLPU

-        Range("F14") = .pat_ALL

-        Range("F15") = .pat_HIR

-        Range("F16") = .pat_TER

-        Range("F17") = .pat_CRD

-        Range("F18") = .sale_ALL

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-    ws_activate

-End Sub

-

-

-Sub ws_activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Dim cLPU As tLPU_COMMON

-    Dim objQTR As tQTR

-    Dim objLPU As tLPU

-    Dim ent_date As String

-    Dim id As Long

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    id = Range("lpu_id").Value

-    ent_date = Range("ent_date")

-    

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-

-    objLPU = Get_LPU_Record(id)

-    Get_LPU_Common cLPU, objLPU, objQTR

-

-    If cLPU.lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = cLPU.lpu.beds

-        Range("lpu_name") = cLPU.lpu.name

-        Range("lpu_addr") = cLPU.lpu.address

-        Range("rec_id") = cLPU.bdgt.id

-

-        SetupData cLPU

-

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-'    MsgBox Target.address

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case INPUT_CHECK

-

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{BB60E38F-A4AB-4AB4-91D0-40AA798D9F5C}{BE9A54D9-F093-4755-9E17-0B47BB5E2546}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mSheets
->>>>>>
-Attribute VB_Name = "mSheets"

-Option Explicit

-

-Function am_load_now() As Boolean

-    am_load_now = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE")

-End Function

-

-Sub Wks_select(RetSheet As String)

-    Dim sheet As Worksheet

-    For Each sheet In ThisWorkbook.Worksheets

-        If sheet.name = RetSheet Then

-            ThisWorkbook.Worksheets(RetSheet).Select

-            Exit Sub

-        End If

-    Next sheet

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub ret_back(sh As Worksheet)

-    Dim RetSheet As String

-    RetSheet = sh.Range("ret_addr")

-    sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    sh.Range("ret_addr") = ""

-    sh.Range("rec_id") = ""

-    sh.Range("lpu_id") = ""

-    sh.Range("ent_date") = ""

-    sh.Range("lpu_name") = ""

-    sh.Range("lpu_addr") = ""

-    sh.Range("lpu_beds") = ""

-    Wks_select RetSheet

-End Sub

-

-Sub ClearSheetData(r_start As Range)

-    If r_start <> "" Then

-        r_start.Worksheet.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        r_start = ""

-    Else

-        ret_back r_start.Worksheet

-    End If

-End Sub

-

-Sub wks_sel_chng(iset As tInputSet, ByVal Target As Range, sh As Worksheet)

-    Dim DebugMode As Boolean

-    Dim in_range As Range

-    

-    DebugMode = Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-

-    If DebugMode Then

-        sh.Unprotect

-    Else

-        sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    End If

-

-    If iset.vType = INPUT_CHECK Then

-        Set in_range = Target.Worksheet.Range(iset.rChk)

-    Else

-        Set in_range = Target

-    End If

-    

-    Dim str As String

-    str = GetFocusAddress(in_range, sh.Range("h_inputs"))

-

-'    MsgBox Target.Address & "; " & str

-    If str <> Target.address Then

-        sh.Range(str).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-Dlg_lpu_card
->>>>>>
-Attribute VB_Name = "Dlg_lpu_card"

-Attribute VB_Base = "0{2C69E842-8DA9-4240-A0A8-F6B0141DC246}{75AAB28C-ADCF-4D1B-9D5A-AF89E80A810C}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbLPU_List_Change()

-    Dim src As Range

-    Dim idx_src As Integer

-    

-    Set src = Worksheets(VAR_SHEET).Range(Me.cbLPU_List.RowSource)

-    idx_src = Me.cbLPU_List.ListIndex + 1

-    Me.tb_lpu_name.Text = src.Cells(idx_src, 1)

-    Me.tb_lpu_address.Text = src.Cells(idx_src, 2)

-    Me.tbBedsCount.Text = src.Cells(idx_src, 3)

-End Sub

-

-

-Private Sub cbxLPU_List_Enable_Click()

-    

-    If Me.cbxLPU_List_Enable Then

-        

-        Me.tb_lpu_name.Text = ""

-        Me.tb_lpu_name.Enabled = False

-        

-        Me.tb_lpu_address.Text = ""

-        Me.tb_lpu_address.Enabled = False

-        

-        Me.tbBedsCount.Text = ""

-        Me.tbBedsCount.Enabled = False

-        

-        Me.cbLPU_List.Enabled = True

-        cbLPU_List_Change

-    Else

-        Me.tb_lpu_name.Enabled = True

-        Me.tb_lpu_name.Text = ""

-        

-        Me.tb_lpu_address.Enabled = True

-        Me.tb_lpu_address.Text = ""

-        

-        Me.tbBedsCount.Enabled = True

-        Me.tbBedsCount.Text = ""

-        

-        Me.cbLPU_List.Enabled = False

-    End If

-End Sub

-

-<<<<<<
-======================
-UserInfo
->>>>>>
-Attribute VB_Name = "UserInfo"

-Attribute VB_Base = "0{BA873669-5C2D-400A-8A8B-572ACD8CCE4C}{D11400A0-9912-4240-A78C-44C33731216A}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Tag = vbOK

-End Sub

-

-Private Sub cbCity_Change()

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_CITY") = Me.cbCity.ListIndex

-        .Calculate

-    End With

-End Sub

-

-Private Sub cbRegion_Change()

-    Dim LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        NewRangeOffsetCol = cbRegion.Value * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).address

-        NewSumRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).address

-        .Calculate

-        .Range("IDX_CITY") = 0

-        cbCity.RowSource = NewCbxRange

-

-    End With

-    cbCity.ListIndex = 0

-End Sub

-

-<<<<<<
-======================
-mREGMAN
->>>>>>
-Attribute VB_Name = "mREGMAN"

-Option Explicit

-

-Sub hwnew()

-    Dim rs As Range

-    Dim re As Object

-    

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    HWReset

-    ReSet_REGMAN_Record

-    With Worksheets("RM_QTR")

-        .ClearRMName

-        .Range("REP_QTR_INPUT_DATA").ClearContents ' Это не ошибка, названия совпадают

-'        .Range("A1").Select

-    End With

-    Worksheets(TITLE_SHEET).Select

-    With Application

-        .DisplayAlerts = False

-        .ThisWorkbook.Save

-        .Quit

-    End With

-End Sub

-

-Function CheckUser() As Boolean

-    Dim objHW() As Long

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    

-    GetHWInfo objHW()

-    i = GetHWRecords(objHW_DB)

-    

-    If i = 0 Then ' First time

-        StoreHWInfo objHW()

-    End If

-    If CheckHWInfo(objHW()) <> True Then

-        CheckUser = False

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    Else

-        CheckUser = SetupUser

-    End If

-End Function

-

-Function SetupUser() As Boolean

-    Dim cREGMAN As tREGMAN

-    Dim idx As Integer

-    Dim dlg_ui As UserInfo

-    

-    Set dlg_ui = New UserInfo

-    

-    cREGMAN = Get_REGMAN_Record()

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_REGION") = cREGMAN.Region

-        .Range("IDX_CITY") = cREGMAN.City

-    End With

-        

-    With dlg_ui

-        .cbRegion = cREGMAN.Region

-        .cbCity = cREGMAN.City

-        .tbFName = cREGMAN.FirstName

-        .tbLName = cREGMAN.LastName

-    End With

-    

-    Worksheets(REGS_SHEET).Calculate

-    

-    Dim test_Ok As Boolean

-    test_Ok = False

-    

-    On Error GoTo l1

-    

-    Do

-        dlg_ui.Show

-        If dlg_ui.Tag = vbOK Then

-            test_Ok = dlg_ui.tbFName.Value <> "" And dlg_ui.tbLName <> ""

-            If test_Ok Then

-                Exit Do

-            Else

-                MsgBox "Введите имя и фамилию", vbOKOnly, PROGRAM_NAME

-            End If

-        Else

-            Exit Do

-        End If

-    Loop Until False

-l1:

-    If test_Ok Then

-        With cREGMAN

-            .Region = dlg_ui.cbRegion.Value

-            .City = dlg_ui.cbCity.Value

-            .FirstName = dlg_ui.tbFName.Value

-            .LastName = dlg_ui.tbLName.Value

-        End With

-        Set_REGMAN_Record cREGMAN

-    Else

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .ThisWorkbook.Saved = True

-            .Quit

-        End With

-    End If

-    SetupUser = test_Ok

-End Function

-

-Sub GetHWInfo(objHW() As Long)

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    i = 1

-    For Each d In dc

-        If d.drivetype = 2 Then ' 2 - HardDisk

-            ReDim Preserve objHW(i)

-            objHW(i) = d.SerialNumber

-            i = i + 1

-        End If

-    Next

-    SortHW objHW

-End Sub

-

-Sub StoreHWInfo(objHW() As Long)

-    UpdateHWRecords objHW

-End Sub

-

-Sub SortHW(objHW() As Long)

-    Dim r As Range

-    Dim rs As Range

-    Dim re As Object

-    Dim i As Integer

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    For i = 1 To UBound(objHW)

-        r = objHW(i)

-        Set r = r.Offset(1, 0)

-    Next i

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).Sort _

-            Key1:=.Range("HW_Number"), _

-            Order1:=xlDescending, _

-            Header:=xlGuess, _

-            OrderCustom:=1, _

-            MatchCase:=False, _

-            Orientation:=xlTopToBottom

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    i = 1

-    Do While r <> ""

-        objHW(i) = r

-        Set r = r.Offset(1, 0)

-        i = i + 1

-    Loop

-End Sub

-

-Function CheckHWInfo(objHW() As Long)

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    CheckHWInfo = False

-        

-    i = GetHWRecords(objHW_DB)

-    If i > 0 Then

-        SortHW objHW_DB

-    End If

-    If UBound(objHW) = UBound(objHW_DB) Then

-        For i = 1 To UBound(objHW)

-            If objHW(i) <> objHW_DB(i) Then

-                Exit Function

-            End If

-        Next i

-        CheckHWInfo = True

-    End If

-End Function

-

-

-<<<<<<
-======================
-dbBudget
->>>>>>
-Attribute VB_Name = "dbBudget"

-Option Explicit

-

-Public Type tBUDGET

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    bdgt_NMG As Long

-    bdgt_NFG As Long

-    sale_PLAN As Long

-End Type

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function GetAll_BDGT_RecordsByLPU_ID(ByRef allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_BDGT_RecordsByLPU_ID = dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection, allBDGT, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function Get_BDGT_Record(ByVal lpu_id As Long, ByVal ent_date As String) As tBUDGET

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    Get_BDGT_Record = dbGet_BDGT_Record(dbConnection, lpu_id, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objBDGT.ID <> 0 then updatre else insert

-Public Sub Insert_BDGT_Record(objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    If objBDGT.id <> 0 Then

-        dbUpdate_BDGT_Record dbConnection, objBDGT

-    Else

-        dbInsert_BDGT_Record dbConnection, objBDGT

-    End If

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Public Sub Delete_BDGT_Record(ByRef objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    dbDelete_BDGT_Record dbConnection, objBDGT

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_BDGT_Record(dbConnection As Object, ByVal lpu_id As Long, ent_date As String) As tBUDGET

-    

-    Dim sql As String

-    Dim objBDGT As tBUDGET

-    

-    With objBDGT

-        .id = 0

-        .lpu_id = lpu_id

-        .entry_date = ent_date

-        .bdgt_NMG = 0

-        .bdgt_NFG = 0

-        .sale_PLAN = 0

-    End With

-        

-    

-    sql = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        With objBDGT

-            .entry_date = dbRecordset("entry_date")

-            .id = dbRecordset("id")

-            .lpu_id = dbRecordset("lpu_id")

-            .bdgt_NFG = dbRecordset("bdgt_NFG")

-            .bdgt_NMG = dbRecordset("bdgt_NMG")

-            .sale_PLAN = dbRecordset("sale_PLAN")

-        End With

-    End If

-    

-    dbGet_BDGT_Record = objBDGT

-End Function

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection As Object, allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_BDGT_SQL As String

-    Dim getAll_BDGT_SQL As String

-    Dim BDGT_Count As Long

-    BDGT_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_BDGT_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        BDGT_Count = dbRecordset("BDGT_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_BDGT_RecordsbyLPU_ID = BDGT_Count

-    

-    If BDGT_Count > 0 Then

-        'we have records

-        ReDim allBDGT(1 To BDGT_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_BDGT_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpBDGT As tBUDGET

-                 With tmpBDGT

-                    .entry_date = dbRecordset("entry_date")

-                    .id = dbRecordset("id")

-                    .lpu_id = dbRecordset("lpu_id")

-                    .bdgt_NFG = dbRecordset("bdgt_NFG")

-                    .bdgt_NMG = dbRecordset("bdgt_NMG")

-                    .sale_PLAN = dbRecordset("sale_PLAN")

-                 End With

-                 

-                 allBDGT(index) = tmpBDGT

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbInsert_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "lpu_budget", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    dbRecordset("entry_date") = objBDGT.entry_date

-    dbRecordset("lpu_id") = objBDGT.lpu_id

-    dbRecordset("bdgt_NMG") = objBDGT.bdgt_NMG

-    dbRecordset("bdgt_NFG") = objBDGT.bdgt_NFG

-    dbRecordset("sale_PLAN") = objBDGT.sale_PLAN

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objBDGT.id = dbRecordset("id")

-  

-End Sub

-

-Public Sub dbUpdate_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu_budget SET " & _

-    "entry_date='" & objBDGT.entry_date & "'," & _

-    "lpu_id=" & objBDGT.lpu_id & "," & _

-    "bdgt_NMG=" & objBDGT.bdgt_NMG & "," & _

-    "bdgt_NFG=" & objBDGT.bdgt_NFG & "," & _

-    "sale_PLAN=" & objBDGT.sale_PLAN & _

-    " WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-Public Sub dbDelete_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_BDGT_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbDatabase
->>>>>>
-Attribute VB_Name = "dbDatabase"

-Option Explicit

-

-

-Sub dbOpenConnection(dbConnection As Object)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-<<<<<<
-======================
-dbLPU
->>>>>>
-Attribute VB_Name = "dbLPU"

-Option Explicit

-

-Public Type tLPU

-    id As Long

-    rep_id As Long

-    name As String

-    address As String

-    beds As Integer

-End Type

-

-Function Get_LPU_Record(ByVal lpu_id As Long) As tLPU

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_LPU_Record = dbGet_LPU_Record(dbConnection, lpu_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_LPU_byQTR(allLPU() As tLPU, ent_date As String, rep_id As Long) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_LPU_byQTR = dbGetAll_LPU_byQTR(dbConnection, allLPU, ent_date, rep_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_Record(dbConnection As Object, ByVal lpu_id As Long) As tLPU

-    

-    Dim sql As String

-    Dim objLPU As tLPU

-    

-    objLPU.id = lpu_id

-    objLPU.name = ""

-    objLPU.address = ""

-    

-    sql = "SELECT * FROM lpu WHERE id=" & lpu_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objLPU.name = dbRecordset("name")

-        objLPU.address = dbRecordset("address")

-        objLPU.rep_id = dbRecordset("rep_id")

-        objLPU.beds = dbRecordset("beds")

-    End If

-    

-    dbGet_LPU_Record = objLPU

-

-End Function

-

-Function dbGetAll_LPU_byQTR(dbConnection As Object, allLPU() As tLPU, ent_date As String, rep_id As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    Dim Where As String

-    Where = "WHERE lpu_budget.entry_date like '" & ent_date & "'" & " AND lpu.id=lpu_budget.lpu_id AND lpu.rep_id=" & rep_id

-

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu_budget, lpu " & Where

-    

-    getAll_LPU_SQL = "SELECT lpu.id as id, lpu.rep_id as rep_id, lpu.name as name, lpu.address as address, lpu.beds AS beds " & _

-    "FROM lpu, lpu_budget " & Where

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_LPU_byQTR = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-dbREP
->>>>>>
-Attribute VB_Name = "dbREP"

-'Option Explicit

-'

-'Public Type tREP

-'    FirstName As String

-'    LastName As String

-'    Region As Integer

-'    City As Integer

-'End Type

-'

-'Function GetREPRecord() As tREP

-'    Dim dbConnection As Object

-'

-'    dbOpenConnection dbConnection

-'    GetREPRecord = dbGetREPRecord(dbConnection)

-'    dbCloseConnection dbConnection

-'End Function

-'

-'Sub SetREPRecord(cUser As tREP)

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbSetREPRecord dbConnection, cUser

-'    dbCloseConnection dbConnection

-'End Sub

-'

-'Sub ReSetREPRecord()

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbReSetREPRecord dbConnection

-'    dbCloseConnection dbConnection

-'End Sub

-'

-'Public Function dbGetREPRecord(dbConnection As Object) As tREP

-'

-'    Dim SQL As String

-'    Dim objREP As tREP

-'

-'    objREP.FirstName = ""

-'    objREP.LastName = ""

-'    objREP.Region = 0

-'    objREP.City = 0

-'    SQL = "SELECT firstname, lastname, region, city FROM " & _

-'          "rep"

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open SQL, dbConnection

-'    ', 3, 3

-'    If Not dbRecordset.BOF Then

-'

-'        objREP.FirstName = dbRecordset("firstname")

-'        objREP.LastName = dbRecordset("lastname")

-'        objREP.Region = dbRecordset("region")

-'        objREP.City = dbRecordset("city")

-'

-'    End If

-'

-'    dbGetREPRecord = objREP

-'

-'End Function

-'

-'Public Sub dbSetREPRecord(dbConnection As Object, ByRef objREP As tREP)

-'

-'    Dim DeleteSQL As String

-'    Dim InsertSQL As String

-'

-'    DeleteSQL = "DELETE FROM rep"

-'    InsertSQL = "INSERT INTO rep (firstname, lastname, region, city) VALUES (" & _

-'    "'" & objREP.FirstName & "', " & _

-'    "'" & objREP.LastName & "', " & _

-'    objREP.Region & ", " & _

-'    objREP.City & ")"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-'

-'End Sub

-'

-'Public Sub dbReSetREPRecord(dbConnection As Object)

-'

-'    Dim DeleteSQL As String

-'

-'    DeleteSQL = "DELETE FROM rep"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-'

-'End Sub

-'

-

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    CheckWorkBooksArround Wb

-End Sub

-

-

-Sub CheckWorkBooksArround(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If app.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKOnly, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-        Exit Sub

-    End If

-

-End Sub

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub SaveExcelState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-        ActiveWorkbook.DisplayDrawingObjects = xlDisplayShapes

-        

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars(STDBAR_NAME).Visible = False

-End Sub

-

-

-Public Sub RestoreExcelState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars(STDBAR_NAME).Visible = True

-End Sub

-

-

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Public Const STDBAR_NAME = "Worksheet Menu Bar"

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Import"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmImport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Export"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 620

-                        .OnAction = "cmExport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Exit && Restore Excel"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 548

-                        .OnAction = "cmExitRestore"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-       End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(flag As Boolean)

-    If flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars(STDBAR_NAME)

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmImport()

-    Worksheets(RM_QTR_SHEET).Select

-    ImportData

-End Sub

-

-Sub cmExport()

-    dbExport

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    Dim dlg As dlgAbout

-    Set dlg = New dlgAbout

-    

-    dlg.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlg.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlg.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlg.Show

-End Sub

-

-Sub cmMail2Support()

-    Dim err_description As String

-    Dim dlg_msg As dlg_Mail

-    Set dlg_msg = New dlg_Mail

-    With dlg_msg

-        .Show

-        If .Tag = vbOK Then

-            ThisWorkbook.Worksheets(VAR_SHEET).Range("ERR_MESSAGE") _

-                = .tbMessage.Text

-            ThisWorkbook.Save

-            ThisWorkbook.SendMail Recipients:="infra@i-rs.ru", Subject:=PROGRAM_NAME & " ver.:" & PROGRAM_VERSION

-            MsgBox "Сообщение об ошибке отправлено. Перезагрузите программу.", vbOKOnly, PROGRAM_NAME

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-    End With

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-'        helppath = "hh.exe " & .Path & "\Telfast.chm"

-'        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub set_work_mode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetupEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-End Sub

-

-Sub cmSetStandaloneMode()

-    set_work_mode

-    ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    Dim dlg As dlgGetPwd

-    rp = common_pwd

-    

-    Set dlg = New dlgGetPwd

-    dlg.edPwd = ""

-    dlg.Show

-    

-    If dlg.edPwd = rp Then

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmHomePage()

-    ThisWorkbook.Worksheets("RM_QTR").Select

-End Sub

-

-Sub cmExitRestore()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = True

-    Application.Quit

-End Sub

-

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    Dim dlg_prn As dlgPrint

-    

-    Set dlg_prn = New dlgPrint

-    

-    With dlg_prn

-        .cbMainReport = True

-        .cbMainBudget = False

-        .cbSrcData = False

-        .cbAllSheets = False

-    

-        .Show

-    

-        If .Tag = vbCancel Then

-            Exit Sub

-        End If

-    End With

-    

-    Dim PrnIdx As Integer

-    

-    With dlg_prn

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("REP_QTR", "budget", "Final")

-    Case 1111

-        plist = Array("REP_QTR", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("REP_QTR")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Clexane bar"

-Public Const common_pwd As String = "crdjhxtyjr"

-

-

-Sub SetupEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    Wb.Worksheets(TITLE_SHEET).Select

-    With Application

-        .Caption = PROGRAM_NAME & " " & PROGRAM_VERSION

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .SaveExcelState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = False

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Wb.Worksheets(TITLE_SHEET).Select

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    If cWindow.Type = xlWorkbook Then

-                        cWindow.DisplayHeadings = True

-                    End If

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu True

-        End If

-        With mobjAppState

-            .RestoreExcelState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Worksheets(TITLE_SHEET).Select

-'        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Option Explicit

-

-Sub UpdateHWRecords(objHW() As Long)

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    dbUpdateHWRecords dbConnection, objHW

-    dbCloseConnection dbConnection

-End Sub

-

-Function GetHWRecords(objHW() As Long) As Integer

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    GetHWRecords = dbGetHWRecords(dbConnection, objHW)

-    dbCloseConnection dbConnection

-End Function

-

-Sub HWReset()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbInsertHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    

-    Dim dbRecordset As Object

-    Dim i As Long

-    

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "hw", dbConnection, 2, 2

-    

-    For i = 1 To UBound(objHW)

-        dbRecordset.addnew

-        dbRecordset("num") = objHW(i)

-        dbRecordset.Update

-    Next i

-    

-End Sub

-

-Sub dbUpdateHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    dbDeleteHWRecord dbConnection

-    dbInsertHWRecords dbConnection, objHW

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-dbHir
->>>>>>
-Attribute VB_Name = "dbHir"

-Option Explicit

-

-Public Type tHIRURGIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    operations_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_ambulator_clexan_40mg As Integer

-    patients_ambulator_clexan_20mg As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-    patients_stationar_clexan_40mg As Integer

-    patients_stationar_clexan_20mg As Integer

-End Type

-

-' if objHir.ID <> 0 then updatre else insert

-Sub Insert_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objHir.id <> 0 Then

-        dbUpdate_Hir_Record dbConnection, objHir

-    Else

-        dbInsert_Hir_Record dbConnection, objHir

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Hir_RecordsByLPU_ID(ByRef allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Hir_RecordsByLPU_ID = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, allHir, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Hir_Record dbConnection, objHir

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objHir.ID <> 0 then updatre else insert

-

-Sub dbInsert_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_hir", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objHir

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("operations_per_quarter") = .operations_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_ambulator_clexan_20mg") = .patients_ambulator_clexan_20mg

-        dbRecordset("patients_ambulator_clexan_40mg") = .patients_ambulator_clexan_40mg

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-        dbRecordset("patients_stationar_clexan_20mg") = .patients_stationar_clexan_20mg

-        dbRecordset("patients_stationar_clexan_40mg") = .patients_stationar_clexan_40mg

-        

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objHir.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim UpdateSQL As String

-    

-    With objHir

-        UpdateSQL = "UPDATE lpu_hir SET " & _

-            "entry_date='" & objHir.entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "operations_per_quarter=" & .operations_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_ambulator_clexan_20mg=" & .patients_ambulator_clexan_20mg & "," & _

-            "patients_ambulator_clexan_40mg=" & .patients_ambulator_clexan_40mg & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & "," & _

-            "patients_stationar_clexan_20mg=" & .patients_stationar_clexan_20mg & "," & _

-            "patients_stationar_clexan_40mg=" & .patients_stationar_clexan_40mg & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_Hir_RecordsbyLPU_ID(dbConnection As Object, allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Hir_SQL As String

-    Dim getAll_Hir_SQL As String

-    Dim Hir_Count As Long

-    Hir_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Hir_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Hir_Count = dbRecordset("HIR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Hir_RecordsbyLPU_ID = Hir_Count

-    

-    If Hir_Count > 0 Then

-        'we have records

-        ReDim allHir(1 To Hir_Count)

-        Dim index As Integer

-        index = 1

-        dbRecordset.Open getAll_Hir_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpHir As tHIRURGIA

-                 With tmpHir

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .operations_per_quarter = dbRecordset("operations_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_ambulator_clexan_20mg = dbRecordset("patients_ambulator_clexan_20mg")

-                    .patients_ambulator_clexan_40mg = dbRecordset("patients_ambulator_clexan_40mg")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                    .patients_stationar_clexan_20mg = dbRecordset("patients_stationar_clexan_20mg")

-                    .patients_stationar_clexan_40mg = dbRecordset("patients_stationar_clexan_40mg")

-                 End With

-                 

-                 allHir(index) = tmpHir

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE ID=" & objHir.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Hir_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbTer
->>>>>>
-Attribute VB_Name = "dbTer"

-Option Explicit

-

-Public Type tTERAPIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objTer.ID <> 0 then updatre else insert

-Sub Insert_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objTer.id <> 0 Then

-        dbUpdate_Ter_Record dbConnection, objTer

-    Else

-        dbInsert_Ter_Record dbConnection, objTer

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Ter_RecordsByLPU_ID(ByRef allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Ter_RecordsByLPU_ID = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, allTer, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Ter_Record dbConnection, objTer

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objTer.ID <> 0 then updatre else insert

-

-Sub dbInsert_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_ter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objTer

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objTer.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim Update_SQL As String

-    

-    With objTer

-        Update_SQL = "UPDATE lpu_ter SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_Ter_RecordsbyLPU_ID(dbConnection As Object, allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Ter_SQL As String

-    Dim getAll_Ter_SQL As String

-    Dim Ter_Count As Long

-    Ter_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Ter_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Ter_Count = dbRecordset("TER_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Ter_RecordsbyLPU_ID = Ter_Count

-    

-    If Ter_Count > 0 Then

-        'we have records

-        ReDim allTer(1 To Ter_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_Ter_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpTer As tTERAPIA

-                 With tmpTer

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 allTer(index) = tmpTer

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE ID=" & objTer.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Ter_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-mLPU_LIST
->>>>>>
-Attribute VB_Name = "mLPU_LIST"

-Option Explicit

-

-Public Const CINP_AREA As String = "B12"

-Public Const CLPU_NAME As Integer = 0

-Public Const CLPU_NAME1 As Integer = 1

-Public Const CLPU_NAME2 As Integer = 2

-Public Const CLPU_ID As Integer = 3

-Public Const CLPU_BEDS As Integer = 4

-Public Const CLPU_NFG As Integer = 5

-Public Const CLPU_NMG As Integer = 6

-Public Const CLPU_HIR As Integer = 7

-Public Const CLPU_TER As Integer = 8

-Public Const CLPU_CAR As Integer = 9

-Public Const CLPU_FACT As Integer = 10

-Public Const CLPU_PLAN As Integer = 11

-Public Const CLPU_PAT_LPU As Integer = 16

-Public Const CLPU_BDGT As Integer = 17

-Public Const CLPU_PAT_ALL As Integer = 16

-

-

-

-Sub EditLPU(cLPU As tLPU, ent_date As String)

-    NoFunc

-End Sub

-

-Sub Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-

-End Sub

-

-Sub Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btLPU_DEL_IT()

-    Dim cLPU As tLPU

-    Dim ent_date As String

-    Dim delete_all As Integer

-    Dim dlg_del As dlg_LPU_delete

-

-    With Worksheets("LPU_LIST")

-        ent_date = .Range("ent_date")

-        cLPU.id = .getCurrentLPU_ID()

-    End With

-

-    If cLPU.id = 0 Then

-        MsgBox "Укажите удаляемый объект", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    cLPU = Get_LPU_Record(cLPU.id)

-

-    Set dlg_del = New dlg_LPU_delete

-    With dlg_del

-        .chbDeleteQTR.Value = True

-        .chbDeleteAll.Value = False

-        .lComment = ent_date & ": Удаление ЛПУ '" _

-        & cLPU.name & "', расположенного по адресу:" _

-        & cLPU.address & " не разрешено."

-        .Show

-    End With

-End Sub

-

-Sub btLPU_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        

-        Wks_select .Range("ret_addr")

-    End With

-

-End Sub

-

-

-Sub btLPU_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim lpu_id As Long

-

-    i = Worksheets(VAR_SHEET).Range("QTR_ACTION").Value

-    With Worksheets("LPU_LIST")

-        ent_date = .getEnt_date()

-

-

-        lpu_id = .getCurrentLPU_ID

-        If lpu_id = 0 And i <> 6 Then

-            i = 1

-        End If

-        Select Case i

-            Case 1

-                .SelectLPU_NAME lpu_id, ent_date

-                .Range("JUMP") = ""

-            Case 2

-                .SelectLPU_BDGT lpu_id, ent_date

-                .Range("JUMP") = "LPU_BDGT"

-            Case 3

-                .SelectLPU_HIR lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_HIR"

-

-            Case 4

-                .SelectLPU_TER lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_TER"

-

-            Case 5

-                .SelectLPU_C_ACS lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        End Select

-    End With

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-dbQTR
->>>>>>
-Attribute VB_Name = "dbQTR"

-Option Explicit

-

-Public Type tQTR

-    id As Long

-    entry_date As String

-    rep_id As Long

-    sale_PLAN As Long

-    ClxnH20mg As Long

-    ClxnH40mg As Long

-    ClxnT40mg As Long

-    ClxnC_IM As Long

-    ClxnC_ACS As Long

-End Type

-

-Function Get_QTR_Record(ByVal QTR_ID As Long) As tQTR

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_QTR_Record = dbGet_QTR_Record(dbConnection, QTR_ID)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_Record(dbConnection As Object, ByVal QTR_ID As Long) As tQTR

-    

-    Dim sql As String

-    Dim objQTR As tQTR

-    

-    With objQTR

-        .ClxnC_ACS = 0

-        .ClxnC_IM = 0

-        .ClxnH20mg = 0

-        .ClxnH40mg = 0

-        .ClxnT40mg = 0

-        .entry_date = ""

-        .id = QTR_ID

-    End With

-    

-    sql = "SELECT * FROM quarter WHERE id=" & QTR_ID

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objQTR.entry_date = dbRecordset("entry_date")

-        objQTR.rep_id = dbRecordset("rep_id")

-        objQTR.sale_PLAN = dbRecordset("sale_plan")

-        objQTR.ClxnH20mg = dbRecordset("ClxnH20mg")

-        objQTR.ClxnH40mg = dbRecordset("ClxnH40mg")

-        objQTR.ClxnT40mg = dbRecordset("ClxnT40mg")

-        objQTR.ClxnC_IM = dbRecordset("ClxnC_IM")

-        objQTR.ClxnC_ACS = dbRecordset("ClxnC_ACS")

-        objQTR.id = dbRecordset("id")

-    End If

-    

-    dbGet_QTR_Record = objQTR

-

-End Function

-

-

-Function Get_QTR_Record_by_REP(ent_date As String, rep_id As Long) As tQTR

-    Dim dbConnection As Object

-    Dim allQTR() As tQTR

-    Dim i As Long

-

-    dbOpenConnection dbConnection

-

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id)

-    If i <> 0 Then

-        Get_QTR_Record_by_REP = allQTR(1)

-    End If

-

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTR_Records_by_REP(ByRef all_QTR() As tQTR, ent_date As String, rep_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-

-    GetAll_QTR_Records_by_REP = dbGetAll_QTR_Records_By_REP(dbConnection, all_QTR, ent_date, rep_id)

-

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGetAll_QTR_Records_By_REP(dbConnection As Object, all_QTR() As tQTR, ent_date As String, rep_id As Long) As Integer

-

-    Dim getCount_QTR_SQL As String

-    Dim getAll_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter " & _

-    "WHERE entry_date like '" & ent_date & "' AND rep_id=" & rep_id

-    getAll_QTR_SQL = "SELECT * FROM quarter " & _

-    "WHERE entry_date like '" & ent_date & "' AND rep_id=" & rep_id & " ORDER BY entry_date"

-

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-

-    dbRecordset.Close

-

-    dbGetAll_QTR_Records_By_REP = QTR_Count

-

-    If QTR_Count > 0 Then

-        'we have records

-        ReDim all_QTR(1 To QTR_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTR_SQL, dbConnection

-

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTR As tQTR

-                 With tmp_QTR

-                    .entry_date = dbRecordset("entry_date")

-                    .rep_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .ClxnH20mg = dbRecordset("ClxnH20mg")

-                    .ClxnH40mg = dbRecordset("ClxnH40mg")

-                    .ClxnT40mg = dbRecordset("ClxnT40mg")

-                    .ClxnC_IM = dbRecordset("ClxnC_IM")

-                    .ClxnC_ACS = dbRecordset("ClxnC_ACS")

-                    .id = dbRecordset("id")

-                 End With

-

-                 all_QTR(index) = tmp_QTR

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-cdbQTR
->>>>>>
-Attribute VB_Name = "cdbQTR"

-Option Explicit

-

-Public Type tQTR_COMMON

-    qtr As tQTR

-    i_lcd As Long           ' число ЛПУ в СПИСКЕ

-    lcd() As tLPU_COMMON    ' список ЛПУ

-    c_beds As Long          ' сумма коек

-    c_bdgt_NFG As Long      ' общий бюджет на НФГ

-    c_bdgt_NMG As Long      ' общий бюджет на НМГ

-    c_bdgt_LPU As Long      ' общий бюджет на гепарины

-    c_sale_PLAN As Long     ' план продаж репа

-    c_sale_ALL As Long      ' продажи

-    c_sale_HIR As Long      ' в хирургии

-    c_sale_TER  As Long     ' в терапии

-    c_sale_CRD  As Long     ' в кардиологии

-    c_pat_HIR   As Long     ' пациенты

-    c_pat_TER   As Long     '

-    c_pat_CRD   As Long     '

-    c_pat_ALL   As Long     '

-    c_pat_LPU   As Long     ' Всего операций

-End Type

-

-Function GetLastQTR_fromDB() As String

-    Dim dbConnection As Object

-    Dim getCount_QTR_SQL As String

-    Dim getLast_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter"

-    getLast_QTR_SQL = "SELECT MAX(entry_date) as ent_date FROM quarter"

-    

-    dbOpenConnection dbConnection

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    If QTR_Count > 0 Then

-        'we have records

-        dbRecordset.Open getLast_QTR_SQL, dbConnection

-        getLast_QTR_SQL = dbRecordset("ent_date")

-    End If

-    GetLastQTR_fromDB = getLast_QTR_SQL

-    dbCloseConnection dbConnection

-End Function

-

-Function Get_QTR_CommonList_by_REP(ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_QTR_CommonList_by_REP = dbGet_QTR_CommonList_by_REP(dbConnection, qcd, ent_date, rep_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_CommonList_by_REP(dbConnection As Object, ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim allQTR() As tQTR

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id)

-    dbGet_QTR_CommonList_by_REP = i

-    If i > 0 Then

-        ReDim qcd(i)

-        For i = 1 To UBound(allQTR)

-            With qcd(i)

-                .qtr = allQTR(i)

-                .c_beds = 0

-                .c_bdgt_NFG = 0

-                .c_bdgt_NMG = 0

-                .c_bdgt_LPU = 0

-                .c_sale_PLAN = 0

-                .c_pat_HIR = 0

-                .c_pat_TER = 0

-                .c_pat_CRD = 0

-                .c_pat_ALL = 0

-                .c_sale_HIR = 0

-                .c_sale_TER = 0

-                .c_sale_CRD = 0

-                .c_sale_ALL = 0

-                .c_pat_LPU = 0

-                

-                j = dbGet_LPU_CommonQTR(dbConnection, .lcd, .qtr)

-                .i_lcd = j

-                If j > 0 Then

-                    For j = 1 To UBound(.lcd)

-                        .c_beds = .c_beds + .lcd(j).lpu.beds

-                        .c_bdgt_NFG = .c_bdgt_NFG + .lcd(j).bdgt.bdgt_NFG

-                        .c_bdgt_NMG = .c_bdgt_NMG + .lcd(j).bdgt.bdgt_NMG

-                        .c_bdgt_LPU = .c_bdgt_LPU + .lcd(j).bdgt_LPU

-                        .c_sale_PLAN = .c_sale_PLAN + .lcd(j).bdgt.sale_PLAN

-                        .c_pat_HIR = .c_pat_HIR + .lcd(j).pat_HIR

-                        .c_pat_TER = .c_pat_TER + .lcd(j).pat_TER

-                        .c_pat_CRD = .c_pat_CRD + .lcd(j).pat_CRD

-                        .c_pat_ALL = .c_pat_ALL + .lcd(j).pat_ALL

-                        .c_sale_HIR = .c_sale_HIR + .lcd(j).sale_HIR

-                        .c_sale_TER = .c_sale_TER + .lcd(j).sale_TER

-                        .c_sale_CRD = .c_sale_CRD + .lcd(j).sale_CRD

-                        .c_sale_ALL = .c_sale_ALL + .lcd(j).sale_ALL

-                        .c_pat_LPU = .c_pat_LPU + .lcd(j).pat_LPU

-                    Next j

-                    

-                End If

-            End With

-        Next i

-    End If

-End Function

-

-Function GetLastQtr() As String

-    Dim s As String

-    Dim r As Range

-    Set r = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Do While r.Cells(1, 1) <> ""

-        s = r.Cells(1, 1)

-        Set r = r.Cells.Offset(1, 0)

-    Loop

-    GetLastQtr = s

-End Function

-

-Function GetNextQTR(ent_date As String) As String

-    Dim rd As Range

-    Dim idx As Integer

-    Dim b As Variant

-    Dim dlg As dlg_newQTR

-    Set dlg = New dlg_newQTR

-    

-    If ent_date = "" Then

-        Dim ir As Variant

-        idx = 0

-        dlg.Show

-        b = dlg.Tag

-            

-        If IsNumeric(b) Then

-            GetNextQTR = dlg.cbQTR

-        Else

-            GetNextQTR = ""

-        End If

-    Else

-        Set rd = Worksheets(VAR_SHEET).Range("Date_Lst")

-        idx = WorksheetFunction.Match(ent_date, rd, 0)

-        GetNextQTR = WorksheetFunction.index(rd, idx + 1, 1)

-    End If

-End Function

-<<<<<<
-======================
-mRestView
->>>>>>
-Attribute VB_Name = "mRestView"

-Option Explicit

-

-Sub xlRestoreView()

-Attribute xlRestoreView.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute xlRestoreView.VB_ProcData.VB_Invoke_Func = " \n14"

-    With Application

-        .CommandBars("Standard").Visible = True

-        .CommandBars("Formatting").Visible = True

-        .DisplayFormulaBar = True

-        .DisplayStatusBar = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = True

-    End With

-End Sub

-<<<<<<
-======================
-dlg_newQTR
->>>>>>
-Attribute VB_Name = "dlg_newQTR"

-Attribute VB_Base = "0{3EA3C15A-5493-445F-9858-2F241E7D6CEA}{849C1FE1-631A-485D-BE54-A7B73124582C}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mDec2TS
->>>>>>
-Attribute VB_Name = "mDec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-CHRT_LPU_BBL
->>>>>>
-Attribute VB_Name = "CHRT_LPU_BBL"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Unprotect

-    Range("view_key") = True

-    On Error Resume Next

-    ChangeLabels

-    Range("A1").Select

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Unprotect

-    Dim s As String

-    s = Range("ret_addr")

-    Protect UserInterfaceOnly:=True

-    Wks_select (s)

-End Sub

-

-Sub BCLabelChng_Click()

-    Unprotect

-    If Range("view_key") Then

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать названия"

-    Else

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать объемы"

-    End If

-    Range("view_key") = Not Range("view_key")

-    ChangeLabels

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub ChangeLabels()

-    Dim i As Integer

-    Dim offset_text As Integer

-    Dim src As Range

-    Set src = Range("CHRT_BBL_DATA")

-    

-    offset_text = 3

-    If Range("view_key") Then

-        offset_text = 4

-    End If

-    

-    With ChartObjects(1).Chart

-        With .SeriesCollection(1)

-            For i = 1 To .Points.count

-                On Error GoTo ExitLabel

-                .Points(i).DataLabel.Characters.Text = Format(src.Cells(i, offset_text))

-            Next i

-        End With

-    End With

-ExitLabel:

-End Sub

-

-<<<<<<
-======================
-CHRT_PAT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PAT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-<<<<<<
-======================
-CHRT_PAT_LPU
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_nextQTR
->>>>>>
-Attribute VB_Name = "dlg_nextQTR"

-Attribute VB_Base = "0{B85FF7F1-50C0-4433-BC6F-8A0F2C9BDDDA}{EC2D2B9E-9ED2-4005-A1E9-EF0626D3B7E7}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-cdbLPU
->>>>>>
-Attribute VB_Name = "cdbLPU"

-Option Explicit

-

-Public Type tLPU_COMMON

-    lpu As tLPU

-    bdgt As tBUDGET

-    i_hir As Long

-    hir() As tHIRURGIA

-    i_ter As Long

-    ter() As tTERAPIA

-    i_ACS As Long

-    ACS() As tACS

-    bdgt_LPU As Long

-    sale_HIR As Long

-    sale_TER As Long

-    sale_CRD As Long

-    sale_ALL As Long

-    pat_HIR As Long

-    pat_TER As Long

-    pat_CRD As Long

-    pat_ALL As Long     ' Сумма всех пациентов на клексане

-    pat_LPU As Long     ' Число потенциальных пациентов для продаж клексана

-End Type

-

-Function Get_LPU_CommonQTR(ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    Get_LPU_CommonQTR = dbGet_LPU_CommonQTR(dbConnection, lcd, objQTR)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_CommonQTR(dbConnection As Object, ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    i = dbGetAll_LPU_byQTR(dbConnection, allLPU, objQTR.entry_date, objQTR.rep_id)

-    dbGet_LPU_CommonQTR = i

-    If i > 0 Then

-        ReDim lcd(i)

-        For i = 1 To UBound(allLPU)

-            dbGet_LPU_Common dbConnection, lcd(i), allLPU(i), objQTR

-        Next i

-    End If

-End Function

-

-Sub Get_LPU_Common(ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    dbGet_LPU_Common dbConnection, lcd, cLPU, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbGet_LPU_Common(dbConnection As Object, ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-

-    lcd.lpu = cLPU

-    lcd.bdgt = dbGet_BDGT_Record(dbConnection, cLPU.id, objQTR.entry_date)

-    lcd.i_hir = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, lcd.hir, cLPU.id, objQTR.entry_date)

-    lcd.i_ter = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, lcd.ter, cLPU.id, objQTR.entry_date)

-    lcd.i_ACS = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, lcd.ACS, cLPU.id, objQTR.entry_date)

-    With lcd

-        .bdgt_LPU = .bdgt.bdgt_NFG + .bdgt.bdgt_NMG

-        .pat_LPU = 0

-        If .i_hir > 0 Then

-            .pat_HIR = .hir(1).patients_ambulator_clexan + .hir(1).patients_stationar_clexan

-            .sale_HIR = objQTR.ClxnH20mg * (.hir(1).patients_ambulator_clexan_20mg + .hir(1).patients_stationar_clexan_20mg)

-            .sale_HIR = .sale_HIR + objQTR.ClxnH40mg * (.hir(1).patients_ambulator_clexan_40mg + .hir(1).patients_stationar_clexan_40mg)

-            .pat_LPU = .pat_LPU + .hir(1).operations_per_quarter

-        End If

-        If .i_ter > 0 Then

-            .pat_TER = .ter(1).patients_ambulator_clexan + .ter(1).patients_stationar_clexan

-            .sale_TER = .pat_TER * objQTR.ClxnT40mg

-            .pat_LPU = .pat_LPU + .ter(1).patients_per_quarter

-        End If

-        If .i_ACS > 0 Then

-            .pat_CRD = .ACS(1).patients_stationar_clexan

-            .sale_CRD = .pat_CRD * objQTR.ClxnC_ACS

-            .pat_LPU = .pat_LPU + .ACS(1).patients_per_quarter

-        End If

-        .pat_ALL = .pat_HIR + .pat_TER + .pat_CRD

-        .sale_ALL = .sale_HIR + .sale_TER + .sale_CRD

-    End With

-End Sub

-

-<<<<<<
-======================
-CHRT_PIE
->>>>>>
-Attribute VB_Name = "CHRT_PIE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    

-    Unprotect

-    

-    On Error Resume Next

-    

-    Range("P5:Q24").Sort _

-        Key1:=Range("Q5"), _

-        Order1:=xlDescending, _

-        Header:=xlGuess, _

-        OrderCustom:=1, _

-        MatchCase:=False, _

-        Orientation:=xlTopToBottom

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PLN_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PLN_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_BDGT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_BDGT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_LPU_delete
->>>>>>
-Attribute VB_Name = "dlg_LPU_delete"

-Attribute VB_Base = "0{EC96F2D1-337D-47DF-B0F1-A6DF3F8CD5CC}{7EB42A63-CBFC-45B0-AE4D-C3E3D8FE7420}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlg_Mail
->>>>>>
-Attribute VB_Name = "dlg_Mail"

-Attribute VB_Base = "0{7B669454-C2AA-4FDF-8311-7ADEDDEF3FF3}{D07A0A02-4923-46C8-8EE8-62769243087D}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dbREP_id
->>>>>>
-Attribute VB_Name = "dbREP_id"

-Public Type tREPID

-    rep_id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function GetAll_REPID_Records_by_QTR(ByRef all_REPID() As tREPID, ent_date As String) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_REPID_Records_by_QTR = dbGetAll_REPID_Records_by_QTR(dbConnection, all_REPID, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-Function Get_REPID_Record(id As Long) As tREPID

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REPID_Record = dbGet_REPID_Record(dbConnection, id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_REPID_Records(ByRef all_REPID() As tREPID) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_REPID_Records = dbGetAll_REPID_Records(dbConnection, all_REPID)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function dbGet_REPID_Record(dbConnection As Object, id As Long) As tREPID

-    

-    Dim sql As String

-    Dim objREPID As tREPID

-    

-    objREPID.FirstName = ""

-    objREPID.LastName = ""

-    objREPID.Region = 0

-    objREPID.City = 0

-    sql = "SELECT rep_id, firstname, lastname, region, city FROM " & _

-          "rep WHERE rep_id=" & id

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREPID.rep_id = dbRecordset("rep_id")

-        objREPID.FirstName = dbRecordset("firstname")

-        objREPID.LastName = dbRecordset("lastname")

-        objREPID.Region = dbRecordset("region")

-        objREPID.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REPID_Record = objREPID

-        

-End Function

-

-Function dbGetAll_REPID_Records_by_QTR(dbConnection As Object, ByRef all_REPID() As tREPID, ent_date As String) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    Dim Where As String

-    

-    REPID_Count = 0

-    Where = " WHERE lpu_budget.entry_date like '" & ent_date & "' " & _

-        "AND rep.rep_id=lpu.rep_id AND lpu.id=lpu_budget.lpu_id"

-    

-    

-    getAll_REPID_SQL = "SELECT distinct rep.* FROM rep, lpu, lpu_budget" & Where

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM (" & getAll_REPID_SQL & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records_by_QTR = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Function dbGetAll_REPID_Records(dbConnection As Object, ByRef all_REPID() As tREPID) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    REPID_Count = 0

-    

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM rep"

-    getAll_REPID_SQL = "SELECT * FROM rep"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-cdbExport
->>>>>>
-Attribute VB_Name = "cdbExport"

-Option Explicit

-

-Function GetDBSN() As String

-    Dim n As Long

-    Randomize Timer

-    n = Int((100000000 - 1000000 + 1) * Rnd + 1000000)

-    GetDBSN = Dec2ThirtySix(n)

-End Function

-

-Sub dbExport()

-    Dim src_file As String

-    Dim dst_file As String

-    

-    On Error GoTo ErrHandler

-    

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & GetLastQTR_fromDB & "_" & GetDBSN() & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Данные экспортированы в файл:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для передачи", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-Exit Sub

-

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-<<<<<<
-======================
-mRegs
->>>>>>
-Attribute VB_Name = "mRegs"

-Option Explicit

-

-Function GetRegionName(idx As Integer) As String

-    GetRegionName = Worksheets(REGS_SHEET).Range("LST_REGIONS").Cells(idx + 1, 1).Text

-End Function

-

-Function GetCityName(idx_reg As Integer, idx_city As Integer) As String

-    GetCityName = Worksheets(REGS_SHEET).Range("CITY_TABLES").Offset(idx_city + 1, idx_reg * 2).Text

-End Function

-

-Sub testReg()

-    Dim r As Integer

-    Dim c As Integer

-    Dim s As String

-    

-    r = 3

-    c = 3

-    s = GetRegionName(r)

-    s = s & ", " & GetCityName(r, c)

-    MsgBox s

-End Sub

-

-<<<<<<
-======================
-RM_QTR
->>>>>>
-Attribute VB_Name = "RM_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CRGN_QT As Integer = 0

-Const CRGN_PLN As Integer = 2

-Const CRGN_FCT As Integer = 3

-Const CRGN_BDG As Integer = 4

-Const CRGN_LPU As Integer = 5

-Const CRGN_REP As Integer = 6

-Const CRGN_HIR As Integer = 7

-Const CRGN_TER As Integer = 8

-Const CRGN_CRD As Integer = 9

-Const CRGN_CLXN_BDG As Integer = 10

-Const CRGN_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub ClearRMName()

-    Unprotect

-    Range("D4") = ""

-    Range("D5") = ""

-    Range("H4") = ""

-End Sub

-

-Sub update_history()

-    Dim objRGN() As tREGION

-    Dim i As Long

-    Dim r As Range

-    Dim cRMan As tREGMAN

-

-    cRMan = Get_REGMAN_Record

-    

-    Range("D4") = cRMan.LastName

-    Range("D5") = cRMan.FirstName

-

-    Range("H4") = GetRegionName(cRMan.Region)

-    

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetRGN_COMM_DATA(objRGN)

-    

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objRGN)

-            r.Offset(i - 1, CRGN_QT) = objRGN(i).ent_date

-            r.Offset(i - 1, CRGN_FCT) = objRGN(i).total_SALE

-            r.Offset(i - 1, CRGN_PLN) = objRGN(i).sale_PLAN

-            r.Offset(i - 1, CRGN_BDG) = objRGN(i).total_BDGT

-            r.Offset(i - 1, CRGN_LPU) = objRGN(i).total_LPU

-            r.Offset(i - 1, CRGN_REP) = objRGN(i).total_REP

-            r.Offset(i - 1, CRGN_HIR) = objRGN(i).total_HIR

-            r.Offset(i - 1, CRGN_TER) = objRGN(i).total_TER

-            r.Offset(i - 1, CRGN_CRD) = objRGN(i).total_ACS

-            If objRGN(i).total_BDGT <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_BDG) = objRGN(i).total_SALE / objRGN(i).total_BDGT

-            End If

-            If objRGN(i).total_BDGT_NMG <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_NMG) = objRGN(i).total_SALE / objRGN(i).total_BDGT_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRGN_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRM_QtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR_RM

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR_RM

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR_RM

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = RM_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect UserInterfaceOnly:=True

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CRGN_QT + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    If r = "" Then

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = currRange.address

-        With Worksheets("REP_LIST")

-            .Range("ret_addr") = "RM_QTR"

-            .Range("ent_date") = r

-            .Range("VIEW_ONLY") = True

-        End With

-    End If

-    Cancel = True

-    btRM_QTR_Do_IT

-End Sub

-

-<<<<<<
-======================
-dbREG_MAN
->>>>>>
-Attribute VB_Name = "dbREG_MAN"

-Option Explicit

-

-Public Type tREGMAN

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function Get_REGMAN_Record() As tREGMAN

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REGMAN_Record = dbGet_REGMAN_Record(dbConnection)

-    dbCloseConnection dbConnection

-End Function

-

-Sub Set_REGMAN_Record(cREGMAN As tREGMAN)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbSet_REGMAN_Record dbConnection, cREGMAN

-    dbCloseConnection dbConnection

-End Sub

-

-Sub ReSet_REGMAN_Record()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbReSet_REGMAN_Record dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_REGMAN_Record(dbConnection As Object) As tREGMAN

-    

-    Dim sql As String

-    Dim objREGMAN As tREGMAN

-    

-    objREGMAN.FirstName = ""

-    objREGMAN.LastName = ""

-    objREGMAN.Region = 0

-    objREGMAN.City = 0

-    sql = "SELECT firstname, lastname, region, city FROM " & _

-          "reg_man"

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREGMAN.FirstName = dbRecordset("firstname")

-        objREGMAN.LastName = dbRecordset("lastname")

-        objREGMAN.Region = dbRecordset("region")

-        objREGMAN.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REGMAN_Record = objREGMAN

-        

-End Function

-

-Public Sub dbSet_REGMAN_Record(dbConnection As Object, ByRef objREGMAN As tREGMAN)

-  

-    Dim DeleteSQL As String

-    Dim InsertSQL As String

-    

-    DeleteSQL = "DELETE FROM reg_man"

-    InsertSQL = "INSERT INTO reg_man (firstname, lastname, region, city) VALUES (" & _

-    "'" & objREGMAN.FirstName & "', " & _

-    "'" & objREGMAN.LastName & "', " & _

-    objREGMAN.Region & ", " & _

-    objREGMAN.City & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    dbRecordset.Open InsertSQL, dbConnection

-       

-End Sub

-

-Public Sub dbReSet_REGMAN_Record(dbConnection As Object)

-  

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM reg_man"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    

-End Sub

-

-

-<<<<<<
-======================
-dbDatabaseMerge
->>>>>>
-Attribute VB_Name = "dbDatabaseMerge"

-Option Explicit

-

-Public Type tDBFIELD

-    name As String

-End Type

-

-Public Type tDBTABLE

-    name As String

-    field() As tDBFIELD

-End Type

-

-

-Function dbGetConnection(dbAccessFileFullPath As String) As Object

-    Dim dbConnection As Object

-    Dim dbAccessFilePasswd As String

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFileFullPath & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    Set dbGetConnection = dbConnection

-End Function

-

-Sub dbCloseOpenedConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteOpenedSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-Function dbMergeREP(from_dbConnection As Object, to_dbConnection As Object) As Long

-

-    Dim getRecordset As Object

-    Dim getREPData_SQL As String

-    Dim REP_fn As String

-    Dim REP_ln As String

-    Dim REP_region As String

-    Dim REP_city As String

-

-

-    getREPData_SQL = "SELECT * FROM rep"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getREPData_SQL, from_dbConnection

-        

-        If Not getRecordset.BOF Then

-            REP_fn = getRecordset("firstname")

-            REP_ln = getRecordset("lastname")

-            REP_city = getRecordset("city")

-            REP_region = getRecordset("region")

-        Else

-            MsgBox "There is no information about rep! This database cannot be merged!!!"

-            dbMergeREP = -1

-            Exit Function

-        End If

-    

-    Dim insertRecordset As Object

-    Set insertRecordset = CreateObject("ADODB.Recordset")

-        

-    insertRecordset.Open "rep", to_dbConnection, 2, 2

-    insertRecordset.addnew

-        

-    insertRecordset("firstname") = REP_fn

-    insertRecordset("lastname") = REP_ln

-    insertRecordset("region") = REP_region

-    insertRecordset("city") = REP_city

-    insertRecordset.Update

-    insertRecordset.MoveLast

-    'new ID

-    

-    dbMergeREP = insertRecordset("rep_id")

-    

-End Function

-

-Sub dbMergeLPU(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getLPU_SQL As String

-    Dim getRecordset As Object

-    Dim idx As Long

-    idx = 1

-    

-    getLPU_SQL = "SELECT * FROM lpu"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getLPU_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            ReDim Preserve objLPU(1 To idx)

-            objLPU(idx).old_lpu_id = getRecordset("id")

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "lpu", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("name") = getRecordset("name")

-            insRS("address") = getRecordset("address")

-            insRS("beds") = getRecordset("beds")

-            insRS.Update

-            insRS.MoveLast

-            'new ID

-            

-            objLPU(idx).new_lpu_id = insRS("id")

-                        

-            idx = idx + 1

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about LPU! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-

-Sub dbMergeLPURelated(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object)

-

-    ' 6 tables to change

-    Dim tables(1 To 5) As tDBTABLE

-    

-    'lpu budget

-    tables(1).name = "lpu_budget"

-    ReDim tables(1).field(1 To 4)

-    

-    tables(1).field(1).name = "entry_date"

-    tables(1).field(2).name = "bdgt_NMG"

-    tables(1).field(3).name = "bdgt_NFG"

-    tables(1).field(4).name = "sale_PLAN"

-    

-    'lpu hir

-    tables(2).name = "lpu_hir"

-    ReDim tables(2).field(1 To 13)

-    

-    tables(2).field(1).name = "entry_date"

-    tables(2).field(2).name = "operations_per_quarter"

-    tables(2).field(3).name = "risk_percent"

-    tables(2).field(4).name = "patients_with_risk_ON"

-    tables(2).field(5).name = "patients_ambulator"

-    tables(2).field(6).name = "patients_ambulator_nmg"

-    tables(2).field(7).name = "patients_ambulator_clexan"

-    tables(2).field(8).name = "patients_ambulator_clexan_40mg"

-    tables(2).field(9).name = "patients_ambulator_clexan_20mg"

-    tables(2).field(10).name = "patients_stationar_nmg"

-    tables(2).field(11).name = "patients_stationar_clexan"

-    tables(2).field(12).name = "patients_stationar_clexan_40mg"

-    tables(2).field(13).name = "patients_stationar_clexan_20mg"

-    

-    

-    'lpu acs

-    tables(3).name = "lpu_acs"

-    ReDim tables(3).field(1 To 5)

-    

-    tables(3).field(1).name = "entry_date"

-    tables(3).field(2).name = "patients_with_geparins"

-    tables(3).field(3).name = "patients_per_quarter"

-    tables(3).field(4).name = "patients_stationar_nmg"

-    tables(3).field(5).name = "patients_stationar_clexan"

-    

-    'lpu acs

-    tables(4).name = "lpu_im"

-    ReDim tables(4).field(1 To 5)

-    

-    tables(4).field(1).name = "entry_date"

-    tables(4).field(2).name = "patients_with_geparins"

-    tables(4).field(3).name = "patients_per_quarter"

-    tables(4).field(4).name = "patients_stationar_nmg"

-    tables(4).field(5).name = "patients_stationar_clexan"

-    

-    

-    'lpu acs

-    tables(5).name = "lpu_ter"

-    ReDim tables(5).field(1 To 9)

-    

-    tables(5).field(1).name = "entry_date"

-    tables(5).field(2).name = "patients_per_quarter"

-    tables(5).field(3).name = "risk_percent"

-    tables(5).field(4).name = "patients_with_risk_ON"

-    tables(5).field(5).name = "patients_ambulator"

-    tables(5).field(6).name = "patients_ambulator_nmg"

-    tables(5).field(7).name = "patients_ambulator_clexan"

-    tables(5).field(8).name = "patients_stationar_nmg"

-    tables(5).field(9).name = "patients_stationar_clexan"

-    

-    

-    

-    Dim tbl_idx As Integer

-    

-    For tbl_idx = 1 To UBound(tables)

-        

-        Dim getSQL As String

-        Dim getRS As Object

-        

-        

-        

-        Set getRS = CreateObject("ADODB.Recordset")

-        

-        getSQL = "SELECT * FROM " & tables(tbl_idx).name

-        getRS.Open getSQL, from_db

-        

-        If Not getRS.BOF Then

-            Do While Not getRS.EOF

-                Dim insRS As Object

-                Set insRS = CreateObject("ADODB.Recordset")

-                

-                insRS.Open tables(tbl_idx).name, to_db, 2, 2

-                insRS.addnew

-                Dim fld_idx As Integer

-    

-                    For fld_idx = 1 To UBound(tables(tbl_idx).field)

-                        insRS(tables(tbl_idx).field(fld_idx).name) = getRS(tables(tbl_idx).field(fld_idx).name)

-                        insRS("lpu_id") = findNewLPU_IDByOld(objLPU, getRS("lpu_id"))

-                    Next fld_idx

-                    

-                insRS.Update

-                insRS.MoveLast

-                getRS.MoveNext

-            Loop

-        End If

-        

-        

-    Next tbl_idx

-

-End Sub

-

-Function findNewLPU_IDByOld(objLPU() As tLPUCONVERTION, old_id As Long)

-

-Dim i As Integer

-For i = 1 To UBound(objLPU)

-    If objLPU(i).old_lpu_id = old_id Then

-        findNewLPU_IDByOld = objLPU(i).new_lpu_id

-        Exit Function

-    End If

-Next i

-

-findNewLPU_IDByOld = -1

-End Function

-

-

-

-

-

-Sub dbMergeQTR(from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getQTR_SQL As String

-    Dim getRecordset As Object

-    

-    getQTR_SQL = "SELECT * FROM quarter"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getQTR_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "quarter", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("entry_date") = getRecordset("entry_date")

-            insRS("sale_plan") = getRecordset("sale_plan")

-            insRS("ClxnH20mg") = getRecordset("ClxnH20mg")

-            insRS("ClxnH40mg") = getRecordset("ClxnH40mg")

-            insRS("ClxnT40mg") = getRecordset("ClxnT40mg")

-            insRS("ClxnC_IM") = getRecordset("ClxnC_IM")

-            insRS("ClxnC_ACS") = getRecordset("ClxnC_ACS")

-            

-            

-            insRS.Update

-            

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about quarter budget! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-dbMerge
->>>>>>
-Attribute VB_Name = "dbMerge"

-Option Explicit

-

-Public Type tLPUCONVERTION

-    old_lpu_id As Long

-    new_lpu_id As Long

-End Type

-

-Sub Merge_BackUp_All_Data()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim time_stump As String

-    

-    On Error GoTo ErrHandler

-    

-    time_stump = Format(Date, "yy-mm-dd_") & Format(Time, "hh-mm")

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_BACKUPNAME & time_stump & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Старые данные сохранены в файле:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для восстановления данных в случае утери", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-    Exit Sub

-    

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-

-Sub Merge_Clear_All_Data(access_file_full_path As String)

-    

-    Dim db As Object

-    Dim tables_to_clear() As String

-    On Error GoTo ErrHandler

-    

-    ReDim tables_to_clear(1 To 8)

-    tables_to_clear(1) = "rep"

-    tables_to_clear(2) = "lpu"

-    tables_to_clear(3) = "lpu_budget"

-    tables_to_clear(4) = "lpu_hir"

-    tables_to_clear(5) = "lpu_ter"

-    tables_to_clear(6) = "lpu_acs"

-    tables_to_clear(7) = "lpu_im"

-    tables_to_clear(8) = "quarter"

-    

-    Set db = dbGetConnection(access_file_full_path)

-

-    Dim i As Integer

-    

-    For i = 1 To UBound(tables_to_clear)

-        

-        If tables_to_clear(i) <> "" Then

-            Dim Clear_SQL As String

-            Clear_SQL = "DELETE FROM " & tables_to_clear(i)

-            dbExecuteOpenedSQL db, Clear_SQL

-        Else

-            'do nothing or show message

-        End If

-    Next i

-    

-    dbCloseOpenedConnection db

-    Set db = Nothing

-    

-'    Dim Engine As Object

-'    Set Engine = CreateObject("JRO.JetEngine")

-'    Engine.CompactDatabase "Password=password;Data Source=" & access_file_full_path, _

-'    "Password=password;Data Source=c:\tmp\1.mdb"

-    

-Exit Sub

-

-ErrHandler:

-    MsgBox "something wrong: " & err.Description

-    Resume Next

-    

-End Sub

-

-Function MergeREP(from_file As String, to_file As String) As Long

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    Dim new_rep_id As Long

-

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    MergeREP = dbMergeREP(db1, db2)

-    'MsgBox "new rep ID is " & new_rep_id

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Function

-

-Sub MergeQTR(from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeQTR db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-

-Sub MergeLPU(objLPU() As tLPUCONVERTION, from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeLPU objLPU, db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-Sub MergeLPURelated(objLPU() As tLPUCONVERTION, from_file As String, to_file As String)

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    dbMergeLPURelated objLPU, db1, db2

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-

-End Sub

-

-Sub MergeGlobal(rep_files() As String, rm_file As String)

-

-    Dim i As Integer

-    'clear output file content

-    Merge_Clear_All_Data rm_file

-    

-    For i = 1 To UBound(rep_files)

-        

-        Dim rep_file As String

-        'setup input and output files

-        rep_file = rep_files(i)

-        

-        Dim new_rep_id As Long

-        ' insert REP data and get new rep_id

-        new_rep_id = MergeREP(rep_file, rm_file)

-        

-        Dim objLPU() As tLPUCONVERTION

-        'insert all LPU using new generated rep_id

-        'and populate objLPU old->new relation object

-        

-        MergeLPU objLPU, rep_file, rm_file, new_rep_id

-        'insert quarter data using new rep_id

-        MergeQTR rep_file, rm_file, new_rep_id

-        

-        

-        ' and.... insert all another data (5 tables excl version and hw)

-        'using objLPU old->new relation object

-        MergeLPURelated objLPU, rep_file, rm_file

-    

-    

-    Next i

-    

-End Sub

-

-Function GetDBList(MyPath() As String, ByRef dblist() As String) As Integer

-    Dim i As Integer

-    Dim MyName, MyMask

-    MyMask = MyPath(0) & MyPath(1) & PROGRAM_DATAEXT

-    i = 0

-    MyName = Dir(MyMask)      ' Retrieve the first entry.

-    Do While MyName <> ""    ' Start the loop.

-        ' Ignore the current directory and the encompassing directory.

-        If MyName <> "." And MyName <> ".." Then

-            ' Use bitwise comparison to make sure MyName is a directory.

-            i = i + 1

-            ReDim Preserve dblist(i)

-            dblist(i) = MyPath(0) & MyName

-        End If

-        MyName = Dir    ' Get next entry.

-    Loop

-    GetDBList = i

-End Function

-

-<<<<<<
-======================
-dlgImprtDB
->>>>>>
-Attribute VB_Name = "dlgImprtDB"

-Attribute VB_Base = "0{D5892870-2C88-40C8-A817-AC9B1CF37C2C}{9853EBEA-4E48-41F9-89C0-6F753EB6A0C2}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Private Sub btSelAll_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = True

-    Next i

-End Sub

-

-Private Sub btUnselect_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = False

-    Next i

-End Sub

-<<<<<<
-======================
-dbQTR_RM
->>>>>>
-Attribute VB_Name = "dbQTR_RM"

-Option Explicit

-

-Public Type tQTRRM

-    id As Long

-    entry_date As String

-    rm_id As Long

-    sale_PLAN As Long

-End Type

-

-

-Sub Insert_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objQTRRM.id <> 0 Then

-        dbUpdate_QTRRM_Record dbConnection, objQTRRM

-    Else

-        dbInsert_QTRRM_Record dbConnection, objQTRRM

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-Function Get_QTRRM_Record(ent_date As String) As tQTRRM

-    Dim dbConnection As Object

-    Dim allQTRRM() As tQTRRM

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    i = dbGetAll_QTRRM_Records(dbConnection, allQTRRM, ent_date)

-    If i <> 0 Then

-        Get_QTRRM_Record = allQTRRM(1)

-    End If

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTRRM_Records(ByRef all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_QTRRM_Records = dbGetAll_QTRRM_Records(dbConnection, all_QTRRM, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_QTRRM_Record dbConnection, objQTRRM

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objQTRRM.ID <> 0 then updatre else insert

-Sub dbInsert_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "quarter_rm", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objQTRRM

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("sale_plan") = .sale_PLAN

-        dbRecordset("rm_id") = .rm_id

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objQTRRM.id = dbRecordset("id")

-

-End Sub

-

-Sub dbUpdate_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim Update_SQL As String

-    

-    With objQTRRM

-        Update_SQL = "UPDATE quarter_rm SET " & _

-            "entry_date='" & .entry_date & "'" & "," & _

-            "rm_id=" & .rm_id & "," & _

-            "sale_plan=" & .sale_PLAN & "," & _

-            " WHERE id=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if ent_date = % then all_records

-Function dbGetAll_QTRRM_Records(dbConnection As Object, all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    

-    Dim getCount_QTRRM_SQL As String

-    Dim getAll_QTRRM_SQL As String

-    Dim QTRRM_Count As Long

-    QTRRM_Count = 0

-    

-    getCount_QTRRM_SQL = "SELECT COUNT(*) AS QTRRM_TOTAL FROM quarter_rm WHERE entry_date like '" & ent_date & "'"

-    getAll_QTRRM_SQL = "SELECT * FROM quarter_rm WHERE entry_date like '" & ent_date & "' ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTRRM_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTRRM_Count = dbRecordset("QTRRM_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_QTRRM_Records = QTRRM_Count

-    

-    If QTRRM_Count > 0 Then

-        'we have records

-        ReDim all_QTRRM(1 To QTRRM_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTRRM_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTRRM As tQTRRM

-                 With tmp_QTRRM

-                    .entry_date = dbRecordset("entry_date")

-                    .rm_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .id = dbRecordset("id")

-                 End With

-                 

-                 all_QTRRM(index) = tmp_QTRRM

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM quarter_rm " & _

-    "WHERE id=" & objQTRRM.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-    

-    'delete related budget entries

-    MsgBox "remember delete related"

-'    dbDelete_BDGT_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Hir_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Ter_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_ACS_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-       

-End Sub

-

-

-<<<<<<
-======================
-REP_LIST
->>>>>>
-Attribute VB_Name = "REP_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentREP_ID() As Long

-    Dim r As Range

-

-    With Worksheets("REP_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CREP_ID)

-    End With

-

-    getCurrentREP_ID = r

-End Function

-

-Public Sub REP_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Rep_Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Rep_Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Rep_Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Rep_Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectREP_LPU(rep_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim r_id As Long

-    

-    Range("JUMP") = "LPU_LIST"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-        .Range("ent_date") = ent_date

-    End With

-End Sub

-

-Public Sub SelectREP_QTR(rep_id As Long)

-    Dim vo As Boolean

-    Dim r_id As Long

-    

-    Range("JUMP") = "REP_QTR"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("REP_QTR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateREPList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim rep_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CREP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CREP_AREA).row, CREP_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    rep_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CREP_AREA).Column

-    

-    If i < 4 Then

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 1

-    Else

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 2

-    End If

-    

-    If rep_id = 0 Then

-        Range("LAST_FOCUS") = Range(CREP_AREA).address

-    End If

-

-    If rep_id = 0 Then

-        i = CREP_NAME

-        Range("JUMP") = ""

-    Else

-        btREP_LIST_DO_IT

-    End If

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateREPList()

-    Dim rcd() As tREPID_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-

-    ent_date = getEnt_date

-

-    i = Get_REP_CommonList_by_QTR(rcd, ent_date)

-

-    With ThisWorkbook.Worksheets("REP_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(rcd)

-            r.Offset(i - 1, CREP_NAME) = rcd(i).rep.FirstName & " " & rcd(i).rep.LastName

-            r.Offset(i - 1, CREP_ID) = rcd(i).rep.rep_id

-            r.Offset(i - 1, CREP_BEDS) = rcd(i).qtrs(1).c_beds

-

-            r.Offset(i - 1, CREP_NFG) = rcd(i).qtrs(1).c_bdgt_NFG

-            r.Offset(i - 1, CREP_NMG) = rcd(i).qtrs(1).c_bdgt_NMG

-

-            r.Offset(i - 1, CREP_PLAN) = rcd(i).qtrs(1).qtr.sale_PLAN

-

-            r.Offset(i - 1, CREP_HIR) = rcd(i).qtrs(1).c_pat_HIR

-            r.Offset(i - 1, CREP_TER) = rcd(i).qtrs(1).c_pat_TER

-            r.Offset(i - 1, CREP_CAR) = rcd(i).qtrs(1).c_pat_CRD

-            r.Offset(i - 1, CREP_FACT) = rcd(i).qtrs(1).c_sale_ALL

-            r.Offset(i - 1, CREP_PAT_LPU) = rcd(i).qtrs(1).c_pat_LPU

-            r.Offset(i - 1, CREP_BDGT) = rcd(i).qtrs(1).c_bdgt_LPU

-            If rcd(i).qtrs(1).c_bdgt_LPU > 0 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = rcd(i).qtrs(1).c_sale_ALL / rcd(i).qtrs(1).c_bdgt_LPU

-            End If

-            If r.Offset(i - 1, CREP_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-

-

-<<<<<<
-======================
-mREP_LIST
->>>>>>
-Attribute VB_Name = "mREP_LIST"

-Option Explicit

-

-Public Const CREP_AREA As String = "B12"

-Public Const CREP_NAME As Integer = 0

-Public Const CREP_NAME1 As Integer = 1

-Public Const CREP_NAME2 As Integer = 2

-Public Const CREP_ID As Integer = 3

-Public Const CREP_BEDS As Integer = 4

-Public Const CREP_NFG As Integer = 5

-Public Const CREP_NMG As Integer = 6

-Public Const CREP_HIR As Integer = 7

-Public Const CREP_TER As Integer = 8

-Public Const CREP_CAR As Integer = 9

-Public Const CREP_FACT As Integer = 10

-Public Const CREP_PLAN As Integer = 11

-Public Const CREP_PAT_LPU As Integer = 16

-Public Const CREP_BDGT As Integer = 17

-Public Const CREP_PAT_ALL As Integer = 16

-

-

-

-Sub EditREP(cRep As tREPID, ent_date As String)

-    NoFunc

-End Sub

-

-Sub Rep_Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btREP_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = "RM_QTR"

-    End With

-    ThisWorkbook.Worksheets("RM_QTR").Activate

-End Sub

-

-

-Sub btREP_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim rep_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("REP_LST_DETALS")

-    With Worksheets("REP_LIST")

-        rep_id = .getCurrentREP_ID

-        

-        Select Case i

-            Case 1:

-                .SelectREP_QTR rep_id

-            Case 2:

-                ent_date = .getEnt_date()

-                .SelectREP_LPU rep_id, ent_date

-        End Select

-    End With

-    

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-

-

-

-<<<<<<
-======================
-cdbREP
->>>>>>
-Attribute VB_Name = "cdbREP"

-Option Explicit

-

-Public Type tREPID_COMMON

-    rep As tREPID

-    i_qtrs As Integer

-    qtrs() As tQTR_COMMON

-End Type

-

-Function Get_REP_CommonList_by_QTR(ByRef rcd() As tREPID_COMMON, ent_date As String) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_REP_CommonList_by_QTR = dbGet_REP_CommonList_by_QTR(dbConnection, rcd, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_REP_CommonList_by_QTR(dbConnection As Object, ByRef rcd() As tREPID_COMMON, ent_date As String) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim k As Long

-    Dim allREPID() As tREPID

-    

-    i = dbGetAll_REPID_Records_by_QTR(dbConnection, allREPID, ent_date)

-    dbGet_REP_CommonList_by_QTR = i

-    If i > 0 Then

-        ReDim rcd(i)

-        For i = 1 To UBound(allREPID)

-            rcd(i).rep = allREPID(i)

-            rcd(i).i_qtrs = Get_QTR_CommonList_by_REP(rcd(i).qtrs, ent_date, allREPID(i).rep_id)

-        Next i

-    End If

-End Function

-

-

-

-<<<<<<
-======================
-CHRT_PAT_LPU_A
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU_A"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-cdbRegion
->>>>>>
-Attribute VB_Name = "cdbRegion"

-Option Explicit

-

-Type tREGION

-    ent_date As String

-    total_SALE As Long ' общий объем продаж

-    total_BDGT As Long ' бюджет всех ЛПУ

-    total_BDGT_NMG As Long ' бюджет всех ЛПУ на НМГ

-    total_LPU As Long ' число ЛПУ

-    total_REP   As Long ' число репов

-    total_BEDS As Long ' общее число коек

-    total_HIR As Long '  общее число пациентов на клексане в хирургии

-    total_TER As Long '  общее число пациентов на клексане в терапии

-    total_ACS As Long '  общее число пациентов на клексане в кардиологии

-    sale_PLAN As Long '  план продаж Авентиса

-End Type

-

-Function GetRGN_COMM_DATA(ByRef reg_data() As tREGION) As Integer

-    Dim q_date() As String

-    Dim q_count As Integer, i As Integer

-    

-    q_count = getAllQTRNames(q_date)

-    If q_count > 0 Then

-        ReDim reg_data(q_count)

-        For i = 1 To q_count

-            Dim current_rep_count As Integer

-            current_rep_count = getREGION_by_QTR(q_date(i), reg_data(i))

-        Next i

-    End If

-    

-    GetRGN_COMM_DATA = q_count

-End Function

-

-Function getAllQTRNames(ByRef qtr_lst() As String) As Integer

-    

-    Dim sql As String

-    Dim i As Integer

-    Dim db As Object, rs As Object

-    

-    

-    sql = "SELECT DISTINCT entry_date FROM lpu_budget"

-    i = 0

-    

-    dbOpenConnection db

-    Set rs = CreateObject("ADODB.Recordset")

-    

-    rs.Open sql, db

-        

-        If Not rs.BOF Then

-            Do While Not rs.EOF

-                i = i + 1

-                ReDim Preserve qtr_lst(i)

-                qtr_lst(i) = rs("entry_date")

-                rs.MoveNext

-            Loop

-        Else

-            getAllQTRNames = 0

-            Exit Function

-        End If

-    getAllQTRNames = i

-    dbCloseConnection db

-End Function

-

-Function getREGION_by_QTR(ent_date As String, treg As tREGION) As Integer

-    Dim rep_count As Integer

-    rep_count = 0

-    

-    Dim reps() As tREPID_COMMON

-    rep_count = Get_REP_CommonList_by_QTR(reps, ent_date)

-    

-    treg.ent_date = ent_date

-    treg.total_BDGT = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.total_BDGT_NMG = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.sale_PLAN = 0 ' quarter.sale_plan

-    treg.total_SALE = 0 'summ of

-    ' hir = (amb40+st40)*pr40 + (amb20+st20)*pr20

-    'ter (amb_clx+stat_clx)*price

-    ' acs xxx

-    'price per rep

-    treg.total_HIR = 0 'patiens clxn

-    treg.total_TER = 0 'patiens clxn

-    treg.total_ACS = 0 'patiens clxn

-    treg.total_LPU = 0 'lpu

-    treg.total_BEDS = 0 'lpu.beds

-    treg.total_REP = 0 '

-    

-    If rep_count > 0 Then

-        Dim i As Integer

-        

-        For i = 1 To UBound(reps)

-            ' current rep is reps(i)

-            With reps(i)

-                treg.total_BDGT = treg.total_BDGT + .qtrs(1).c_bdgt_NFG + .qtrs(1).c_bdgt_NMG

-                treg.total_BDGT_NMG = treg.total_BDGT_NMG + .qtrs(1).c_bdgt_NMG

-                treg.sale_PLAN = treg.sale_PLAN + .qtrs(1).c_sale_PLAN

-                treg.total_SALE = treg.total_SALE + .qtrs(1).c_sale_ALL

-                treg.total_HIR = treg.total_HIR + .qtrs(1).c_pat_HIR

-                treg.total_TER = treg.total_TER + .qtrs(1).c_pat_TER

-                treg.total_ACS = treg.total_ACS + .qtrs(1).c_pat_CRD

-                treg.total_LPU = treg.total_LPU + .qtrs(1).i_lcd

-                treg.total_BEDS = treg.total_BEDS + .qtrs(1).c_beds

-                treg.total_REP = treg.total_REP + 1

-            End With

-            

-        Next i

-        

-    End If

-    

-    getREGION_by_QTR = treg.total_REP

-End Function

-

-<<<<<<
-======================
-mRM_QTR
->>>>>>
-Attribute VB_Name = "mRM_QTR"

-Option Explicit

-

-Sub btRM_QTR_Do_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    

-    idx = Worksheets(VAR_SHEET).Range("RM_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            ImportData

-        Case 2

-            Worksheets("REP_LIST").Select

-        Case 3

-            cmExport

-    End Select

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-End Sub

-

-Sub ImportData()

-    Dim i As Integer

-    Dim def_dir As String

-    Dim flist() As String

-    

-    def_dir = GetWBPath(ThisWorkbook.FullName)

-    If GetImportDirectory(def_dir, flist) Then

-        Dim ImpMask() As String

-        ImpMask = Split(flist(1), Chr(95), Compare:=vbBinaryCompare)

-        flist(1) = ImpMask(0) & "*"

-        Dim db_list() As String

-        i = GetDBList(flist(), db_list)

-        If i > 0 Then

-            Merge_BackUp_All_Data

-            MergeGlobal db_list, GetWBPath(ThisWorkbook.FullName) & "clexane-rm.mdb"

-        End If

-    End If

-    Worksheets(RM_QTR_SHEET).update_history

-End Sub

-<<<<<<
-======================
-mImport
->>>>>>
-Attribute VB_Name = "mImport"

-    Option Explicit

-

-Const OFN_ALLOWMULTISELECT As Long = 512

-Const OFN_EXPLORER As Long = 524288

-Const OFN_HIDEREADONLY As Long = 4

-Const OFN_NONETWORKBUTTON As Long = 131072

-Const OFN_READONLY As Long = 1

-       

-Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _

-    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

-

-Private Type OPENFILENAME

-    lStructSize As Long

-    hWndOwner As Long

-    hInstance As Long

-    lpstrFilter As String

-    lpstrCustomFilter As String

-    nMaxCustFilter As Long

-    nFilterIndex As Long

-    lpstrFile As String

-    nMaxFile As Long

-    lpstrFileTitle As String

-    nMaxFileTitle As Long

-    lpstrInitialDir As String

-    lpstrTitle As String

-    flags As Long

-    nFileOffset As Integer

-    nFileExtension As Integer

-    lpstrDefExt As String

-    lCustData As Long

-    lpfnHook As Long

-    lpTemplateName As String

-End Type

-

-Function GetImportDirectory(DB_dir As String, flist() As String) As Boolean

-    Dim OpenFile As OPENFILENAME

-    Dim lReturn As Long

-    Dim sFilter As String

-    

-    OpenFile.lStructSize = Len(OpenFile)

-    '         OpenFile.hwndOwner = Form1.hWnd

-    '         OpenFile.hInstance = App.hInstance

-    sFilter = "Clexane Data Files" & Chr(0) & "mr*.mdb" & Chr(0)

-    OpenFile.lpstrFilter = sFilter

-    OpenFile.nFilterIndex = 1

-    OpenFile.lpstrFile = String(257, 0)

-    OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1

-    OpenFile.lpstrFileTitle = OpenFile.lpstrFile

-    OpenFile.nMaxFileTitle = OpenFile.nMaxFile

-    OpenFile.lpstrInitialDir = DB_dir

-    OpenFile.lpstrTitle = "Импорт данных"

-    OpenFile.flags = OFN_HIDEREADONLY + OFN_EXPLORER

-    lReturn = GetOpenFileName(OpenFile)

-    If lReturn = 0 Then

-        GetImportDirectory = False

-    Else

-        GetImportDirectory = True

-        flist = Split(OpenFile.lpstrFile, Chr(0), Compare:=vbBinaryCompare)

-        Dim i As Integer

-        i = 0

-        Do While flist(i) <> ""

-            i = i + 1

-        Loop

-        If i = 1 Then

-            flist(1) = flist(0)

-            flist(0) = GetWBPath(flist(1))

-            flist(1) = GetWBName(flist(1))

-        Else

-            flist(0) = flist(0) & "\"

-        End If

-    End If

-End Function

-<<<<<<
-Project Name : 'ClexaneMR'
-Quirk - duff tag length======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).ClearRepName

-    

-    Application.EnableEvents = True

-    Set MyAppEvents.app = Application

-    

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    

-    MyAppEvents.CheckWorkBooksArround ThisWorkbook

-    

-    cmSetStandaloneMode

-    

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-    

-    Application.ScreenUpdating = True

-    

-    If CheckUser Then

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-        ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-        ThisWorkbook.Worksheets(REP_QTR_SHEET).update_history

-        Application.Calculate

-    End If

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    

-    Dim RestMode As Boolean

-    RestMode = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE")

-    

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-'        If RestMode Then

-            ThisWorkbook.Saved = True

-'        Else

-'            ThisWorkbook.Save

-'        End If

-    End If

-    If RestMode Then

-        xlRestoreView

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    End If

-    Application.Caption = Empty

-    Application.CommandBars(STDBAR_NAME).Reset

-    

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-    Dim MaxX, MaxY As Integer

-    With ThisWorkbook.Worksheets(REP_QTR_SHEET)

-        MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-        MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-    End With

-

-    With ThisWorkbook.Application

-        .ScreenUpdating = False

-        .WindowState = xlNormal

-        .Height = MaxY

-        .Width = MaxX

-    End With

-End Sub

-

-

-

-

-

-<<<<<<
-======================
-REP_QTR
->>>>>>
-Attribute VB_Name = "REP_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CQTR_QT As Integer = 0

-Const CQTR_ID As Integer = 1

-Const CQTR_PLN As Integer = 2

-Const CQTR_FCT As Integer = 3

-Const CQTR_BDG As Integer = 4

-Const CQTR_CNT As Integer = 5

-Const CQTR_BEDS As Integer = 6

-Const CQTR_HIR As Integer = 7

-Const CQTR_TER As Integer = 8

-Const CQTR_CRD As Integer = 9

-Const CQTR_CLXN_BDG As Integer = 10

-Const CQTR_CLXN_NMG As Integer = 11

-Const CQTR_PAT_ALL As Integer = 16

-Const CQTR_BDGT_ALL As Integer = 17

-

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub ClearRepName()

-    Unprotect

-    Range("D4") = ""

-    Range("D5") = ""

-    Range("H4") = ""

-    Range("H5") = ""

-End Sub

-

-Sub update_history()

-    Dim objQTR() As tQTR

-    Dim i As Long

-    Dim r As Range

-    Dim cRep As tREP

-    

-    cRep = GetREPRecord

-    Range("D4") = cRep.LastName

-    Range("D5") = cRep.FirstName

-    

-    Range("H4") = GetRegionName(cRep.Region)

-    Range("H5") = GetCityName(cRep.Region, cRep.City)

-    

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    i = GetAll_QTR_Records(objQTR, "%")

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CQTR_QT) = objQTR(i).entry_date

-        Next i

-    End If

-    Dim qcd() As tQTR_COMMON

-    i = Get_QTR_CommonList(qcd)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(qcd)

-            r.Offset(i - 1, CQTR_QT) = qcd(i).qtr.entry_date

-            r.Offset(i - 1, CQTR_ID) = qcd(i).qtr.id

-            r.Offset(i - 1, CQTR_PLN) = qcd(i).qtr.sale_plan

-            r.Offset(i - 1, CQTR_FCT) = qcd(i).c_sale_ALL

-            r.Offset(i - 1, CQTR_BDG) = qcd(i).c_bdgt_LPU

-            r.Offset(i - 1, CQTR_CNT) = qcd(i).i_lcd

-            r.Offset(i - 1, CQTR_BEDS) = qcd(i).c_beds

-            r.Offset(i - 1, CQTR_HIR) = qcd(i).c_pat_HIR

-            r.Offset(i - 1, CQTR_TER) = qcd(i).c_pat_TER

-            r.Offset(i - 1, CQTR_CRD) = qcd(i).c_pat_CRD

-            If qcd(i).c_bdgt_LPU <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_BDG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_LPU

-            End If

-            If qcd(i).c_bdgt_NMG <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_NMG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_BBL_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-

-End Sub

-

-Sub Draw_PAT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CQTR_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRepQtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-

-Private Sub Worksheet_Activate()

-  

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-    

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.Count > 1 And r_sel.Columns.Count < CRow_Width Or r_sel.Rows.Count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.Count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.Count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.Count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CQTR_ID + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    i = currRange.Column - Range(CINP_AREA).Column

-    

-    QTR_ID = r

-

-    If QTR_ID = 0 Then

-        Worksheets(VAR_SHEET).Range("USER_ACTION") = 1

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        If i > CQTR_FCT Then

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-            Range("LAST_FOCUS") = currRange.address

-        Else

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 3

-            Range("LAST_FOCUS") = currRange.address

-        End If

-    End If

-    Cancel = True

-    btHomeDo_IT

-End Sub

-

-<<<<<<
-======================
-mRep_QTR
->>>>>>
-Attribute VB_Name = "mRep_QTR"

-Option Explicit

-

-Sub DO_New_qtr()

-    Dim res As Variant

-    Dim objQTR As tQTR

-    Dim s As String

-    s = GetLastQtr

-    objQTR.entry_date = GetNextQTR(s)

-    

-    If objQTR.entry_date = "" Then

-        Exit Sub

-    End If

-    

-    DO_Price_qtr objQTR.entry_date

-

-End Sub

-

-Sub DO_Price_qtr(ent_date As String)

-    If ent_date = "" Then

-        DO_New_qtr

-    Else

-        Dim qtr As tQTR

-        Dim res As Integer

-        

-        qtr = Get_QTR_Record(ent_date)

-        

-        If qtr.id = 0 Then

-            qtr.entry_date = ent_date

-    

-            With Worksheets(VAR_SHEET)

-                qtr.ClxnH20mg = .Range("ClxnH20mg")

-                qtr.ClxnH40mg = .Range("ClxnH40mg")

-                qtr.ClxnT40mg = .Range("ClxnT40mg")

-                qtr.ClxnC_ACS = .Range("ClxnC_ACS")

-                qtr.ClxnC_IM = .Range("ClxnC_IM")

-            End With

-        End If

-        

-        Dim dlg_nq As dlg_nextQTR

-        Set dlg_nq = New dlg_nextQTR

-        

-        With dlg_nq

-            .tb_qtr_name = qtr.entry_date

-            .tb_bdgt_avts = qtr.sale_plan

-            .tb_qtr_name = qtr.entry_date

-            .tb_ClxnH20mg = qtr.ClxnH20mg

-            .tb_ClxnH40mg = qtr.ClxnH40mg

-            .tb_ClxnT40mg = qtr.ClxnT40mg

-            .tb_ClxnC_ACS = qtr.ClxnC_ACS

-            .tb_ClxnC_IM = qtr.ClxnC_IM

-        End With

-        

-        dlg_nq.Show

-        res = dlg_nq.Tag

-        

-        If res = vbOK Then

-            With dlg_nq

-                If Not IsNumeric(.tb_bdgt_avts) Then

-                    MsgBox "Введите план продаж", vbOK, PROGRAM_NAME

-                Else

-                    If .tb_bdgt_avts = 0 Then

-                        MsgBox "Введите план продаж", vbOK, PROGRAM_NAME

-                        Exit Sub

-                    End If

-                End If

-                Dim bool As Boolean

-                bool = IsNumeric(.tb_ClxnH20mg) _

-                    And IsNumeric(.tb_ClxnH40mg) _

-                    And IsNumeric(.tb_ClxnT40mg) _

-                    And IsNumeric(.tb_ClxnC_ACS) _

-                    And IsNumeric(.tb_ClxnC_IM)

-                If Not bool Then

-                    MsgBox "Вводите правильно цыфры", vbOK, PROGRAM_NAME

-                    Exit Sub

-                End If

-                qtr.sale_plan = .tb_bdgt_avts

-                qtr.entry_date = .tb_qtr_name

-                qtr.ClxnH20mg = .tb_ClxnH20mg

-                qtr.ClxnH40mg = .tb_ClxnH40mg

-                qtr.ClxnT40mg = .tb_ClxnT40mg

-                qtr.ClxnC_ACS = .tb_ClxnC_ACS

-                qtr.ClxnC_IM = .tb_ClxnC_IM

-            End With

-            Insert_QTR_Record qtr

-        End If

-    End If

-End Sub

-

-Sub DO_Edit_qtr(ent_date As String)

-    If ent_date = "" Then

-        DO_New_qtr

-    Else

-        With ThisWorkbook.Worksheets("LPU_LIST")

-            .Range("VIEW_ONLY") = False

-            .Range("ent_date") = ent_date

-            .Select

-        End With

-    End If

-End Sub

-

-Sub DO_Delete_qtr(ent_date As String)

-    If ent_date <> "" Then

-        Dim i As Integer

-        i = MsgBox("Удалить данные за период [" & ent_date & "]?", vbDefaultButton2 + vbOKCancel, PROGRAM_NAME)

-        If i = vbOK Then

-            Dim objQTR As tQTR

-            If ent_date <> "" Then

-                objQTR.entry_date = ent_date

-                objQTR = Get_QTR_Record(ent_date)

-                Delete_QTR_Record objQTR

-                Worksheets(TITLE_SHEET).Select

-                Worksheets(REP_QTR_SHEET).Select

-            End If

-        End If

-    End If

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-

-Sub btHomeDo_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    idx = Worksheets(VAR_SHEET).Range("USER_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            DO_New_qtr

-            ' Обновляем экран

-        Case 2

-            DO_Edit_qtr ent_date

-        Case 3

-            DO_Price_qtr ent_date

-        Case 4

-            dbExport

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    End Select

-    If idx <> 2 Then

-        With ThisWorkbook

-            .Worksheets(TITLE_SHEET).Select

-            .Worksheets(REP_QTR_SHEET).Select

-        End With

-    End If

-End Sub

-

-Sub Delete_qtr()

-    Dim ent_date As String

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    DO_Delete_qtr ent_date

-End Sub

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane[MR]"

-Public Const PROGRAM_VERSION As String = "version 1.6"

-Public Const PROGRAM_FILENAME As String = "clexane-mr"

-Public Const PROGRAM_EXPORTNAME As String = "mr-ex-"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20030329

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "O40"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-End Sub

-

-Function Double2Str(ByVal d As Double, ByVal precision As Integer, Optional Delim As String = ".") As String

-    Dim s As String

-    If Not precision > 0 Then

-        s = Round(d)

-    Else

-        Dim i As Integer

-        i = Fix(d)

-        s = i & Delim

-        d = Abs(d - i)

-        Do

-            precision = precision - 1

-            d = d * 10

-            If precision > 0 Then

-                i = Fix(d)

-            Else

-                i = Round(d)

-            End If

-            If i < 1 Then

-                s = s & "0"

-            Else

-                s = s & i

-                d = d - i

-            End If

-        Loop While precision > 0

-    End If

-    Double2Str = s

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.Count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.name = VAR_SHEET Or sh.name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-<<<<<<
-======================
-Var
->>>>>>
-Attribute VB_Name = "Var"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-title
->>>>>>
-Attribute VB_Name = "title"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LPU_LIST
->>>>>>
-Attribute VB_Name = "LPU_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentLPU_ID() As Long

-    Dim r As Range

-    

-    With Worksheets("LPU_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CLPU_ID)

-    End With

-    

-    getCurrentLPU_ID = r

-End Function

-

-Public Sub LPU_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectLPU_NAME(lpu_id As Long, ent_date As String)

-    If Range("VIEW_ONLY") = True Then

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    Dim cLPU As tLPU

-    If lpu_id = 0 Then

-        cLPU.id = 0

-        cLPU.rep_id = 0

-        cLPU.address = ""

-        cLPU.name = ""

-    Else

-        cLPU = Get_LPU_Record(lpu_id)

-    End If

-    EditLPU cLPU, getEnt_date

-    Worksheet_Activate

-End Sub

-        

-Sub SelectLPU_BDGT(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    If lpu_id = 0 Then

-        SelectLPU_NAME lpu_id, ent_date

-    Else

-        With ThisWorkbook.Worksheets("LPU_BDGT")

-            .Range("VIEW_ONLY") = vo

-            .Range("ret_addr") = "LPU_LIST"

-            .Range("ent_date") = ent_date

-            .Range("lpu_id") = lpu_id

-        End With

-    End If

-End Sub

-

-Sub SelectLPU_HIR(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_CLSN_HIR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-                   

-Sub SelectLPU_TER(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_CLSN_TER")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-       

-Sub SelectLPU_C_ACS(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_CLSN_C_ACS")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateLPUList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.Count > 1 And r_sel.Columns.Count < CINP_WIDTH Or r_sel.Rows.Count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.Count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.Count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.Count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim lpu_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-    

-    ent_date = getEnt_date

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-    

-    Set r = Range(CINP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CINP_AREA).row, CLPU_ID)

-        

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-    

-    lpu_id = r

-    

-    i = Range(Range("LAST_FOCUS")).Column - Range(CINP_AREA).Column

-    

-    If lpu_id = 0 Then

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    End If

-    

-    If lpu_id = 0 Then

-        i = CLPU_NAME

-        Range("JUMP") = ""

-    End If

-    Select Case i

-        Case CLPU_NAME, CLPU_NAME1, CLPU_NAME2, CLPU_BEDS

-            SelectLPU_NAME lpu_id, ent_date

-            Range("JUMP") = ""

-

-        Case CLPU_NMG, CLPU_NFG, CLPU_PLAN, CLPU_FACT

-            SelectLPU_BDGT lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-            

-        Case CLPU_HIR

-            SelectLPU_HIR lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_HIR"

-        

-        Case CLPU_TER

-            SelectLPU_TER lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_TER"

-        

-        Case CLPU_CAR

-            SelectLPU_C_ACS lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_C_ACS"

-        

-        Case Else

-            Range("JUMP") = ""

-    End Select

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-    

-    is_input_range = INPUT_NO

-    

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateLPUList()

-    Dim lcd() As tLPU_COMMON

-    

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-    Dim objQTR As tQTR

-    Dim cRep As tREP

-    

-    ' ent_date = "%" ' % - all records

-    ent_date = getEnt_date

-    

-    objQTR = Get_QTR_Record(ent_date)

-    i = Get_LPU_CommonQTR(lcd, objQTR)

-     

-    ' стираем ФИО

-    Range("C3:C4").ClearContents

-    cRep = GetREPRecord

-    

-    Range("C3") = cRep.LastName

-    Range("C4") = cRep.FirstName

-    Range("G3") = GetRegionName(cRep.Region)

-    Range("G4") = GetCityName(cRep.Region, cRep.City)

-    Range("G5") = objQTR.sale_plan

-    

-

-    

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-        

-        For i = 1 To UBound(lcd)

-            r.Offset(i - 1, CLPU_NAME) = lcd(i).lpu.name

-            r.Offset(i - 1, CLPU_ID) = lcd(i).lpu.id

-            r.Offset(i - 1, CLPU_BEDS) = lcd(i).lpu.beds

-            

-         

-            r.Offset(i - 1, CLPU_NFG) = lcd(i).bdgt.bdgt_NFG

-            r.Offset(i - 1, CLPU_NMG) = lcd(i).bdgt.bdgt_NMG

-            r.Offset(i - 1, CLPU_PLAN) = lcd(i).bdgt.sale_plan

-            

-            r.Offset(i - 1, CLPU_HIR) = lcd(i).pat_HIR

-            r.Offset(i - 1, CLPU_TER) = lcd(i).pat_TER

-            r.Offset(i - 1, CLPU_CAR) = lcd(i).pat_CRD

-            r.Offset(i - 1, CLPU_FACT) = lcd(i).sale_ALL

-            r.Offset(i - 1, CLPU_PAT_LPU) = lcd(i).pat_LPU

-            r.Offset(i - 1, CLPU_BDGT) = lcd(i).bdgt_LPU

-            If lcd(i).bdgt_LPU > 0 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = lcd(i).sale_ALL / lcd(i).bdgt_LPU

-            End If

-            If r.Offset(i - 1, CLPU_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = 1

-            End If

-            

-        Next i

-    End If

-End Sub

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{566B33D6-957A-43E4-8444-D8EA3889700C}{42EE65B8-F8C6-4F95-9F52-7738BF6FCEAD}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-dbACS
->>>>>>
-Attribute VB_Name = "dbACS"

-Option Explicit

-

-Public Type tACS

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    patients_with_geparins As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objACS.ID <> 0 then updatre else insert

-Sub Insert_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objACS.id <> 0 Then

-        dbUpdate_ACS_Record dbConnection, objACS

-    Else

-        dbInsert_ACS_Record dbConnection, objACS

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_ACS_RecordsByLPU_ID(ByRef all_ACS_() As tACS, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_ACS_RecordsByLPU_ID = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, all_ACS_, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_ACS_Record dbConnection, objACS

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub dbInsert_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_acs", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objACS

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("patients_with_geparins") = .patients_with_geparins

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objACS.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim Update_SQL As String

-    

-    With objACS

-        Update_SQL = "UPDATE lpu_acs SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "patients_with_geparins=" & .patients_with_geparins & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_ACS_RecordsbyLPU_ID(dbConnection As Object, all_ACS() As tACS, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_ACS_SQL As String

-    Dim getAll_ACS_SQL As String

-    Dim ACS_Count As Long

-    ACS_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_ACS_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        ACS_Count = dbRecordset("ACS_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_ACS_RecordsbyLPU_ID = ACS_Count

-    

-    If ACS_Count > 0 Then

-        'we have records

-        ReDim all_ACS(1 To ACS_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_ACS_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_ACS As tACS

-                 With tmp_ACS

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .patients_with_geparins = dbRecordset("patients_with_geparins")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 all_ACS(index) = tmp_ACS

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE ID=" & objACS.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_ACS_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_HIR
->>>>>>
-Attribute VB_Name = "LPU_CLSN_HIR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-    

-        Dim objHir As tHIRURGIA

-        

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objHir

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .operations_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L9")

-                .patients_ambulator_clexan_20mg = Range("L10")

-                .patients_ambulator_clexan_40mg = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L19")

-                .patients_stationar_clexan_20mg = Range("L20")

-                .patients_stationar_clexan_40mg = Range("L21")

-            End With

-            Insert_Hir_Record objHir

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objHir.id = Range("rec_id")

-                    If objHir.id <> 0 Then

-                        Delete_Hir_Record objHir

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objHir As tHIRURGIA)

-    Dim qtr As tQTR

-    Dim formula As String

-

-    With objHir

-        Range("rec_id") = .id

-        Range("F6") = .operations_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L9") = .patients_ambulator_clexan

-        Range("L10") = .patients_ambulator_clexan_20mg

-        Range("I21") = .patients_stationar_nmg

-        Range("L19") = .patients_stationar_clexan

-        Range("L20") = .patients_stationar_clexan_20mg

-        

-        qtr = Get_QTR_Record(.entry_date)

-        formula = "=" & qtr.ClxnH20mg & "*($L$10+$L$20)+" & qtr.ClxnH40mg & "*($L$11+$L$21)"

-        Range("F11").formula = formula

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-    

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Range("h_DepFlag") = False

-    

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objHir() As tHIRURGIA

-        Dim i As Integer

-        i = GetAll_Hir_RecordsByLPU_ID(objHir, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.3

-        Else

-            SetupData objHir(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-mSapes
->>>>>>
-Attribute VB_Name = "mSapes"

-Option Explicit

-

-Const SHAPE_COLOR As Integer = 1

-Const SHAPE_NAME As Integer = 2

-

-

-Sub ShapeView(r_sh_finite_state As Range)

-    Dim chk As Range

-    Dim s As String

-    Dim c, idx As Integer

-    For Each chk In r_sh_finite_state

-        idx = 0

-        If chk = "+" Then

-            c = chk.Offset(0, idx + SHAPE_COLOR)

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While c <> 0

-                ShapeFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s)), c

-                idx = idx + 2

-                c = chk.Offset(0, idx + SHAPE_COLOR)

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        Else

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While s <> ""

-                ShapeUnFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s))

-                idx = idx + 2

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        End If

-    Next chk

-End Sub

-

-Sub ShapeFill(sh As ShapeRange, ByVal color As Integer)

-    sh.Fill.Visible = msoTrue

-    sh.Fill.Solid

-    sh.Fill.ForeColor.SchemeColor = color

-    sh.Fill.Transparency = 0#

-End Sub

-

-Sub ShapeUnFill(sh As ShapeRange)

-    sh.Fill.Visible = msoFalse

-    sh.Fill.Transparency = 0#

-End Sub

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Public Const INPUT_NO = 0

-Public Const INPUT_NUMBER = 1

-Public Const INPUT_PERCENT = 2

-Public Const INPUT_STRING = 3

-Public Const INPUT_CHECK = 4

-

-Public Const INP_IDX_TYPE = 1

-Public Const INP_IDX_NEXT = 2

-Public Const INP_IDX_MIN = 3

-Public Const INP_IDX_MAX = 4

-Public Const INP_IDX_DEP = 5

-Public Const INP_IDX_ALT = 7

-

-

-Public Type tInputSet

-    vType As Integer

-    vMin As Long

-    vMax As Long

-    rChk As String

-End Type

-

-Function is_input_cell(ByVal Target As Range, inputs As Range) As tInputSet

-    Dim t As Range

-    Dim iset As tInputSet

-    Dim test As Range

-    iset.vType = INPUT_NO

-    iset.vMin = 0

-    iset.vMax = 0

-    iset.rChk = ""

-    is_input_cell = iset

-

-' Закоментировать следующую сточку для работы

-'  Exit Function

-

-    Set test = Target.Cells(1, 1)

-    For Each t In inputs

-        If Range(t).Column = test.Column And Range(t).row = test.row Then

-            iset.vType = t.Offset(0, INP_IDX_TYPE).Value

-            Select Case iset.vType

-                Case INPUT_CHECK

-                    iset.rChk = t.Offset(0, INP_IDX_ALT)

-                Case INPUT_NUMBER, INPUT_PERCENT

-                    iset.vMin = t.Offset(0, INP_IDX_MIN).Value

-                    iset.vMax = t.Offset(0, INP_IDX_MAX).Value

-            End Select

-            is_input_cell = iset

-            Exit Function

-        End If

-    Next t

-End Function

-

-Function GetFocusAddress(ByVal r As Range, f_next As Range) As String

-    Dim chk, t As Range

-    

-    For Each chk In f_next

-        For Each t In r

-            If t.address = chk Then

-                GetFocusAddress = chk

-                Exit Function

-            End If

-            If Range(chk).Column = t.Column - 1 And Range(chk).row = t.row _

-            Or Range(chk).Column = t.Column And Range(chk).row = t.row - 1 _

-            Then

-                If Range(chk) <> "" Then

-                    If Range(chk) = 0 Then

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_ALT)).address

-                    Else

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_NEXT)).address

-                    End If

-                Else

-                    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-                End If

-                Exit Function

-            End If

-        Next t

-    Next chk

-    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-End Function

-

-Sub SetDependet(r As Range, inputs As Range)

-    Dim chk As Range

-    Dim s, serr As String

-    Dim idx As Integer

-    Dim iset As tInputSet

-    Dim err_found As Boolean

-    

-    If r.Count > 1 Then

-        Exit Sub

-    End If

-    

-    err_found = False

-    For Each chk In inputs

-        idx = INP_IDX_DEP

-        

-        

-        iset.vType = chk.Offset(0, INP_IDX_TYPE).Value

-        Select Case iset.vType

-            Case INPUT_NUMBER, INPUT_PERCENT

-                iset.vMin = chk.Offset(0, INP_IDX_MIN).Value

-                iset.vMax = chk.Offset(0, INP_IDX_MAX).Value

-                

-                If Range(chk) > iset.vMax Then

-                    err_found = True

-                    Range(chk) = iset.vMax

-                    serr = "Выход за дозволенный диапазон [" & iset.vMin & ".." & iset.vMax & "]! Данные скорректированы."

-                End If

-                

-                If Range(chk) = "" Then

-                    s = chk.Offset(0, idx)

-                    Do While s <> ""

-                        Range(s) = ""

-                        idx = idx + 1

-                        s = chk.Offset(0, idx)

-                    Loop

-                End If

-        End Select

-    Next chk

-    If err_found Then

-        MsgBox serr, vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Function CheckInputData(inputs As Range) As Boolean

-    Dim r As Range

-    

-    CheckInputData = True

-    For Each r In inputs

-        If Range(r) = "" Then

-            CheckInputData = False

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100.", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Sub Check_Int_Number(Target As Range, Def_Val As Long)

-    Dim err As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    err = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                err = True

-            End If

-        End If

-    Next r

-    If err Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_TER
->>>>>>
-Attribute VB_Name = "LPU_CLSN_TER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim objTer As tTERAPIA

-        

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objTer

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .patients_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L20")

-            End With

-            Insert_Ter_Record objTer

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objTer.id = Range("rec_id")

-                    If objTer.id <> 0 Then

-                        Delete_Ter_Record objTer

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objTer As tTERAPIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    With objTer

-        Range("rec_id") = .id

-        Range("F6") = .patients_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L11") = .patients_ambulator_clexan

-        Range("I21") = .patients_stationar_nmg

-        Range("L20") = .patients_stationar_clexan

-        

-        qtr = Get_QTR_Record(.entry_date)

-        formula = "=" & qtr.ClxnT40mg & "*($L$12+$L$20)"

-        Range("F11").formula = formula

-        

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-    

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Range("h_DepFlag") = False

-    

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objTer() As tTERAPIA

-        Dim i As Integer

-        i = GetAll_Ter_RecordsByLPU_ID(objTer, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.25

-        Else

-            SetupData objTer(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-    

-    Dim s As String

-    Dim iset As tInputSet

-    

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    

-    Select Case iset.vType

-        Case INPUT_NO

-        

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-            

-            Application.ScreenUpdating = False

-            

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-            

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-        

-        Case INPUT_STRING

-        

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{EBA94131-180E-4709-A2A3-B60D48987620}{47A860A1-BF92-4EBB-A333-AB7E83FAB868}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-LPU_BDGT
->>>>>>
-Attribute VB_Name = "LPU_BDGT"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub SetDefFocus()

-    Range(Range("DEF_FOCUS")).Select

-End Sub

-

-Public Sub ClearData()

-    ClearSheetData

-End Sub

-

-Sub ClearSheetData()

-    If Range("F10") = 0 And Range("F13") = 0 Then

-        Range("F11:F18") = ""

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("F11:F13") = ""

-    End If

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim bdgt As tBUDGET

-        Dim sum As Long

-        Dim test As Boolean

-        With bdgt

-            .lpu_id = Range("lpu_id")

-            .id = Range("rec_id")

-            .entry_date = Range("ent_date")

-            .bdgt_NMG = Round(Range("F11").Value, 0)

-            .bdgt_NFG = Round(Range("F12").Value, 0)

-            .sale_plan = Round(Range("F13").Value, 0)

-            

-            sum = .bdgt_NFG + .bdgt_NMG - .sale_plan

-            test = .bdgt_NFG <> 0 Or .bdgt_NMG <> 0 Or .sale_plan <> 0

-        End With

-        If test Then

-            If sum < 0 Then

-                MsgBox _

-                    "Ваш план превышает выделенный на гепарины бюджет. Сохранить данные?", _

-                    vbOKOnly, PROGRAM_NAME

-            End If

-            If test Then

-                Insert_BDGT_Record bdgt

-            End If

-        Else

-            If bdgt.id <> 0 Then

-                If vbYes = MsgBox("Сохранить нулевые значения?", vbYesNo, PROGRAM_NAME) Then

-                    Insert_BDGT_Record bdgt

-                End If

-                ret_back Range("DEF_FOCUS").Worksheet

-                Exit Sub

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-    End If

-    

-   ClearData

-   ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(cLPU As tLPU_COMMON)

-    Dim t_sum As Long

-    t_sum = 0

-' Setup budget data

-    Range("F11") = cLPU.bdgt.bdgt_NMG

-    Range("F12") = cLPU.bdgt.bdgt_NFG

-    Range("F13") = cLPU.bdgt.sale_plan

-    

-    With cLPU

-        Range("F14") = .pat_ALL

-        Range("F15") = .pat_HIR

-        Range("F16") = .pat_TER

-        Range("F17") = .pat_CRD

-        Range("F18") = .sale_ALL

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    ws_activate

-End Sub

-

-

-Sub ws_activate()

-    Dim cLPU As tLPU_COMMON

-    Dim objQTR As tQTR

-    Dim objLPU As tLPU

-    Dim ent_date As String

-    Dim id As Long

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    id = Range("lpu_id").Value

-    ent_date = Range("ent_date")

-    objQTR = Get_QTR_Record(ent_date)

-    objLPU = Get_LPU_Record(id)

-    Get_LPU_Common cLPU, objLPU, objQTR

-    

-    If cLPU.lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = cLPU.lpu.beds

-        Range("lpu_name") = cLPU.lpu.name

-        Range("lpu_addr") = cLPU.lpu.address

-        Range("rec_id") = cLPU.bdgt.id

-        

-        SetupData cLPU

-        

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-'    MsgBox Target.address

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Dim s As String

-    Dim iset As tInputSet

-    

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    

-    Select Case iset.vType

-        Case INPUT_NO

-        

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-            

-        Case INPUT_PERCENT

-        

-        Case INPUT_STRING

-        

-        Case INPUT_CHECK

-            

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{E3F10C5A-A4B4-42FF-A2C9-6F8198210A07}{563D0F3D-F79D-48F1-AFE4-A2136809B982}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mSheets
->>>>>>
-Attribute VB_Name = "mSheets"

-Option Explicit

-

-Function am_load_now() As Boolean

-    am_load_now = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE")

-End Function

-

-Sub Wks_select(RetSheet As String)

-    Dim sheet As Worksheet

-    For Each sheet In ThisWorkbook.Worksheets

-        If sheet.name = RetSheet Then

-            ThisWorkbook.Worksheets(RetSheet).Select

-            Exit Sub

-        End If

-    Next sheet

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub ret_back(sh As Worksheet)

-    Dim RetSheet As String

-    RetSheet = sh.Range("ret_addr")

-    sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    sh.Range("ret_addr") = ""

-    sh.Range("rec_id") = ""

-    sh.Range("lpu_id") = ""

-    sh.Range("ent_date") = ""

-    sh.Range("lpu_name") = ""

-    sh.Range("lpu_addr") = ""

-    sh.Range("lpu_beds") = ""

-    Wks_select RetSheet

-End Sub

-

-Sub ClearSheetData(r_start As Range)

-    If r_start <> "" Then

-        r_start.Worksheet.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        r_start = ""

-    Else

-        ret_back r_start.Worksheet

-    End If

-End Sub

-

-Sub wks_sel_chng(iset As tInputSet, ByVal Target As Range, sh As Worksheet)

-    Dim DebugMode As Boolean

-    Dim in_range As Range

-    

-    DebugMode = Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-

-    If DebugMode Then

-        sh.Unprotect

-    Else

-        sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    End If

-

-    If iset.vType = INPUT_CHECK Then

-        Set in_range = Target.Worksheet.Range(iset.rChk)

-    Else

-        Set in_range = Target

-    End If

-    

-    Dim str As String

-    str = GetFocusAddress(in_range, sh.Range("h_inputs"))

-

-'    MsgBox Target.Address & "; " & str

-    If str <> Target.address Then

-        sh.Range(str).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-Dlg_lpu_card
->>>>>>
-Attribute VB_Name = "Dlg_lpu_card"

-Attribute VB_Base = "0{137EDDE5-3DB4-4BAD-A245-324DC31ABB36}{3BD7159A-BF6C-403F-B3DF-4834FA9E4D92}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbLPU_List_Change()

-    Dim src As Range

-    Dim idx_src As Integer

-    

-    Set src = Worksheets(VAR_SHEET).Range(Me.cbLPU_List.RowSource)

-    idx_src = Me.cbLPU_List.ListIndex + 1

-    Me.tb_lpu_name.Text = src.Cells(idx_src, 1)

-    Me.tb_lpu_address.Text = src.Cells(idx_src, 2)

-    Me.tbBedsCount.Text = src.Cells(idx_src, 3)

-End Sub

-

-

-Private Sub cbxLPU_List_Enable_Click()

-    

-    If Me.cbxLPU_List_Enable Then

-        

-        Me.tb_lpu_name.Text = ""

-        Me.tb_lpu_name.Enabled = False

-        

-        Me.tb_lpu_address.Text = ""

-        Me.tb_lpu_address.Enabled = False

-        

-        Me.tbBedsCount.Text = ""

-        Me.tbBedsCount.Enabled = False

-        

-        Me.cbLPU_List.Enabled = True

-        cbLPU_List_Change

-    Else

-        Me.tb_lpu_name.Enabled = True

-        Me.tb_lpu_name.Text = ""

-        

-        Me.tb_lpu_address.Enabled = True

-        Me.tb_lpu_address.Text = ""

-        

-        Me.tbBedsCount.Enabled = True

-        Me.tbBedsCount.Text = ""

-        

-        Me.cbLPU_List.Enabled = False

-    End If

-End Sub

-

-<<<<<<
-======================
-UserInfo
->>>>>>
-Attribute VB_Name = "UserInfo"

-Attribute VB_Base = "0{8EB80D4C-3476-421A-A370-6332A07DE509}{A7542905-C9F8-4F39-AD67-B62A88F8F4E6}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Tag = vbOK

-End Sub

-

-Private Sub cbCity_Change()

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_CITY") = Me.cbCity.ListIndex

-        .Calculate

-    End With

-End Sub

-

-Private Sub cbRegion_Change()

-    Dim LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        NewRangeOffsetCol = cbRegion.Value * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).address

-        NewSumRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).address

-        .Calculate

-        .Range("IDX_CITY") = 0

-        cbCity.RowSource = NewCbxRange

-

-    End With

-    cbCity.ListIndex = 0

-End Sub

-

-<<<<<<
-======================
-mREP
->>>>>>
-Attribute VB_Name = "mREP"

-Option Explicit

-

-Sub hwnew()

-    Dim rs As Range

-    Dim re As Object

-    

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    HWReset

-    ReSetREPRecord

-    With Worksheets("REP_QTR")

-        .ClearRepName

-        .Range("REP_QTR_INPUT_DATA").ClearContents

-        .Range("QTR_SEL") = ""

-    End With

-    Worksheets(TITLE_SHEET).Select

-    With Application

-        .DisplayAlerts = False

-        .ThisWorkbook.Save

-        .Quit

-    End With

-End Sub

-

-Function CheckUser() As Boolean

-    Dim objHW() As Long

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    

-    GetHWInfo objHW()

-    i = GetHWRecords(objHW_DB)

-    

-    If i = 0 Then ' First time

-        StoreHWInfo objHW()

-        Worksheets("REP_QTR").Range("QTR_SEL") = ""

-    End If

-    If CheckHWInfo(objHW()) <> True Then

-        CheckUser = False

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    Else

-        CheckUser = SetupUser

-    End If

-End Function

-

-Function SetupUser() As Boolean

-    Dim cUser As tREP

-    Dim idx As Integer

-    Dim dlg_ui As UserInfo

-    

-    Set dlg_ui = New UserInfo

-    

-    cUser = GetREPRecord()

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_REGION") = cUser.Region

-        .Range("IDX_CITY") = cUser.City

-    End With

-        

-    With dlg_ui

-        .cbRegion = cUser.Region

-        .cbCity = cUser.City

-        .tbFName = cUser.FirstName

-        .tbLName = cUser.LastName

-    End With

-    

-    Worksheets(REGS_SHEET).Calculate

-    

-    Dim test_Ok As Boolean

-    test_Ok = False

-    

-    On Error GoTo l1

-

-    Do

-        dlg_ui.Show

-        If dlg_ui.Tag = vbOK Then

-            test_Ok = dlg_ui.tbFName.Value <> "" And dlg_ui.tbLName <> ""

-            If test_Ok Then

-                Exit Do

-            Else

-                MsgBox "Введите имя и фамилию", vbOKOnly, PROGRAM_NAME

-            End If

-        Else

-            Exit Do

-        End If

-    Loop Until False

-l1:

-    If test_Ok Then

-        With cUser

-            .Region = dlg_ui.cbRegion.Value

-            .City = dlg_ui.cbCity.Value

-            .FirstName = dlg_ui.tbFName.Value

-            .LastName = dlg_ui.tbLName.Value

-        End With

-        SetREPRecord cUser

-    Else

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .ThisWorkbook.Saved = True

-            .Quit

-        End With

-    End If

-    SetupUser = test_Ok

-End Function

-

-Sub GetHWInfo(objHW() As Long)

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    i = 1

-    For Each d In dc

-        If d.drivetype = 2 Then ' 2 - HardDisk

-            ReDim Preserve objHW(i)

-            objHW(i) = d.SerialNumber

-            i = i + 1

-        End If

-    Next

-    SortHW objHW

-End Sub

-

-Sub StoreHWInfo(objHW() As Long)

-    UpdateHWRecords objHW

-End Sub

-

-Sub SortHW(objHW() As Long)

-    Dim r As Range

-    Dim rs As Range

-    Dim re As Object

-    Dim i As Integer

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    For i = 1 To UBound(objHW)

-        r = objHW(i)

-        Set r = r.Offset(1, 0)

-    Next i

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).Sort _

-            Key1:=.Range("HW_Number"), _

-            Order1:=xlDescending, _

-            Header:=xlGuess, _

-            OrderCustom:=1, _

-            MatchCase:=False, _

-            Orientation:=xlTopToBottom

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    i = 1

-    Do While r <> ""

-        objHW(i) = r

-        Set r = r.Offset(1, 0)

-        i = i + 1

-    Loop

-End Sub

-

-Function CheckHWInfo(objHW() As Long)

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    CheckHWInfo = False

-        

-    i = GetHWRecords(objHW_DB)

-    If i > 0 Then

-        SortHW objHW_DB

-    End If

-    If UBound(objHW) = UBound(objHW_DB) Then

-        For i = 1 To UBound(objHW)

-            If objHW(i) <> objHW_DB(i) Then

-                Exit Function

-            End If

-        Next i

-        CheckHWInfo = True

-    End If

-End Function

-<<<<<<
-======================
-dbBudget
->>>>>>
-Attribute VB_Name = "dbBudget"

-Option Explicit

-

-Public Type tBUDGET

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    bdgt_NMG As Long

-    bdgt_NFG As Long

-    sale_plan As Long

-End Type

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function GetAll_BDGT_RecordsByLPU_ID(ByRef allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_BDGT_RecordsByLPU_ID = dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection, allBDGT, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function Get_BDGT_Record(ByVal lpu_id As Long, ByVal ent_date As String) As tBUDGET

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    Get_BDGT_Record = dbGet_BDGT_Record(dbConnection, lpu_id, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objBDGT.ID <> 0 then updatre else insert

-Public Sub Insert_BDGT_Record(objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    If objBDGT.id <> 0 Then

-        dbUpdate_BDGT_Record dbConnection, objBDGT

-    Else

-        dbInsert_BDGT_Record dbConnection, objBDGT

-    End If

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Public Sub Delete_BDGT_Record(ByRef objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    dbDelete_BDGT_Record dbConnection, objBDGT

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_BDGT_Record(dbConnection As Object, ByVal lpu_id As Long, ent_date As String) As tBUDGET

-    

-    Dim SQL As String

-    Dim objBDGT As tBUDGET

-    

-    With objBDGT

-        .id = 0

-        .lpu_id = lpu_id

-        .entry_date = ent_date

-        .bdgt_NMG = 0

-        .bdgt_NFG = 0

-        .sale_plan = 0

-    End With

-        

-    

-    SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        With objBDGT

-            .entry_date = dbRecordset("entry_date")

-            .id = dbRecordset("id")

-            .lpu_id = dbRecordset("lpu_id")

-            .bdgt_NFG = dbRecordset("bdgt_NFG")

-            .bdgt_NMG = dbRecordset("bdgt_NMG")

-            .sale_plan = dbRecordset("sale_PLAN")

-        End With

-    End If

-    

-    dbGet_BDGT_Record = objBDGT

-End Function

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection As Object, allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_BDGT_SQL As String

-    Dim getAll_BDGT_SQL As String

-    Dim BDGT_Count As Long

-    BDGT_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_BDGT_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        BDGT_Count = dbRecordset("BDGT_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_BDGT_RecordsbyLPU_ID = BDGT_Count

-    

-    If BDGT_Count > 0 Then

-        'we have records

-        ReDim allBDGT(1 To BDGT_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_BDGT_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpBDGT As tBUDGET

-                 With tmpBDGT

-                    .entry_date = dbRecordset("entry_date")

-                    .id = dbRecordset("id")

-                    .lpu_id = dbRecordset("lpu_id")

-                    .bdgt_NFG = dbRecordset("bdgt_NFG")

-                    .bdgt_NMG = dbRecordset("bdgt_NMG")

-                    .sale_plan = dbRecordset("sale_PLAN")

-                 End With

-                 

-                 allBDGT(index) = tmpBDGT

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbInsert_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "lpu_budget", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    dbRecordset("entry_date") = objBDGT.entry_date

-    dbRecordset("lpu_id") = objBDGT.lpu_id

-    dbRecordset("bdgt_NMG") = objBDGT.bdgt_NMG

-    dbRecordset("bdgt_NFG") = objBDGT.bdgt_NFG

-    dbRecordset("sale_PLAN") = objBDGT.sale_plan

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objBDGT.id = dbRecordset("id")

-  

-End Sub

-

-Public Sub dbUpdate_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu_budget SET " & _

-    "entry_date='" & objBDGT.entry_date & "'," & _

-    "lpu_id=" & objBDGT.lpu_id & "," & _

-    "bdgt_NMG=" & objBDGT.bdgt_NMG & "," & _

-    "bdgt_NFG=" & objBDGT.bdgt_NFG & "," & _

-    "sale_PLAN=" & objBDGT.sale_plan & _

-    " WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-Public Sub dbDelete_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_BDGT_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbDatabase
->>>>>>
-Attribute VB_Name = "dbDatabase"

-Option Explicit

-

-

-Sub dbOpenConnection(dbConnection As Object)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, SQL As String)

-    dbConnection.Execute (SQL)

-End Sub

-

-<<<<<<
-======================
-dbLPU
->>>>>>
-Attribute VB_Name = "dbLPU"

-Option Explicit

-

-Public Type tLPU

-    id As Long

-    rep_id As Long

-    name As String

-    address As String

-    beds As Integer

-End Type

-

-Function Get_LPU_Record(ByVal lpu_id As Long) As tLPU

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_LPU_Record = dbGet_LPU_Record(dbConnection, lpu_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAllLPU(allLPU() As tLPU) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAllLPU = dbGetAllLPU(dbConnection, allLPU)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAllLPUbyQTR(allLPU() As tLPU, ent_date As String) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAllLPUbyQTR = dbGetAllLPUbyQTR(dbConnection, allLPU, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objLPU.id = 0 then insert else update

-Sub Insert_LPU_Record(ByRef objLPU As tLPU)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    If objLPU.id = 0 Then

-        dbInsert_LPU_Record dbConnection, objLPU

-    Else

-        dbUpdate_LPU_Record dbConnection, objLPU

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub Delete_LPU_Record(ByRef objLPU As tLPU)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDelete_LPU_Record dbConnection, objLPU

-    dbCloseConnection dbConnection

-End Sub

-

-Sub Delete_LPU_RecordQTR(ByRef objLPU As tLPU, ent_date As String)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Hir_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Ter_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_ACS_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    

-    dbCloseConnection dbConnection

-    

-End Sub

-

-Function dbGet_LPU_Record(dbConnection As Object, ByVal lpu_id As Long) As tLPU

-    

-    Dim SQL As String

-    Dim objLPU As tLPU

-    

-    objLPU.id = lpu_id

-    objLPU.name = ""

-    objLPU.address = ""

-    

-    SQL = "SELECT * FROM lpu WHERE id=" & lpu_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objLPU.name = dbRecordset("name")

-        objLPU.address = dbRecordset("address")

-        objLPU.rep_id = dbRecordset("rep_id")

-        objLPU.beds = dbRecordset("beds")

-    End If

-    

-    dbGet_LPU_Record = objLPU

-

-End Function

-

-Sub dbInsert_LPU_Record(dbConnection As Object, ByRef objLPU As tLPU)

-  

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu", dbConnection, 2, 2

-    dbRecordset.addnew

-    dbRecordset("name") = objLPU.name

-    dbRecordset("address") = objLPU.address

-    dbRecordset("rep_id") = objLPU.rep_id

-    dbRecordset("beds") = objLPU.beds

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objLPU.id = dbRecordset("id")

-  

-End Sub

-

-Sub dbUpdate_LPU_Record(dbConnection As Object, ByRef objLPU As tLPU)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu SET " & _

-    "name='" & objLPU.name & "'," & _

-    "address='" & objLPU.address & "'," & _

-    "beds=" & objLPU.beds & "," & _

-    "rep_id=" & objLPU.rep_id& & _

-    " WHERE id=" & objLPU.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-

-Function dbGetAllLPU(dbConnection As Object, allLPU() As tLPU) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu"

-    getAll_LPU_SQL = "SELECT * FROM lpu"

-

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAllLPU = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-Function dbGetAllLPUbyQTR(dbConnection As Object, allLPU() As tLPU, ent_date As String) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    Dim where As String

-    where = "WHERE lpu_budget.entry_date like '" & ent_date & "'"

-    

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu_budget " & where

-    

-    getAll_LPU_SQL = "SELECT lpu.id as id, lpu.rep_id as rep_id, lpu.name as name, lpu.address as address, lpu.beds AS beds " & _

-    "FROM lpu, lpu_budget " & where & " AND lpu.id=lpu_budget.lpu_id"

-    

-

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAllLPUbyQTR = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-Sub dbDelete_LPU_Record(dbConnection As Object, ByRef objLPU As tLPU)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu " & _

-    "WHERE id=" & objLPU.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByLPU_ID dbConnection, objLPU.id

-    dbDelete_Hir_RecordsByLPU_ID dbConnection, objLPU.id

-    dbDelete_Ter_RecordsByLPU_ID dbConnection, objLPU.id

-    dbDelete_ACS_RecordsByLPU_ID dbConnection, objLPU.id

-    

-End Sub

-

-Sub dbDelete_LPU_RecordQTR(dbConnection As Object, ByRef objLPU As tLPU, ent_date As String)

-    

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Hir_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Ter_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_ACS_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    

-End Sub

-

-<<<<<<
-======================
-dbREP
->>>>>>
-Attribute VB_Name = "dbREP"

-Option Explicit

-

-Public Type tREP

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function GetREPRecord() As tREP

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetREPRecord = dbGetREPRecord(dbConnection)

-    dbCloseConnection dbConnection

-End Function

-

-Sub SetREPRecord(cUser As tREP)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbSetREPRecord dbConnection, cUser

-    dbCloseConnection dbConnection

-End Sub

-

-Sub ReSetREPRecord()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbReSetREPRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGetREPRecord(dbConnection As Object) As tREP

-    

-    Dim SQL As String

-    Dim objREP As tREP

-    

-    objREP.FirstName = ""

-    objREP.LastName = ""

-    objREP.Region = 0

-    objREP.City = 0

-    SQL = "SELECT firstname, lastname, region, city FROM " & _

-          "rep"

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open SQL, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREP.FirstName = dbRecordset("firstname")

-        objREP.LastName = dbRecordset("lastname")

-        objREP.Region = dbRecordset("region")

-        objREP.City = dbRecordset("city")

-        

-    End If

-    

-    dbGetREPRecord = objREP

-        

-End Function

-

-Public Sub dbSetREPRecord(dbConnection As Object, ByRef objREP As tREP)

-  

-    Dim DeleteSQL As String

-    Dim InsertSQL As String

-    

-    DeleteSQL = "DELETE FROM rep"

-    InsertSQL = "INSERT INTO rep (firstname, lastname, region, city) VALUES (" & _

-    "'" & objREP.FirstName & "', " & _

-    "'" & objREP.LastName & "', " & _

-    objREP.Region & ", " & _

-    objREP.City & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    dbRecordset.Open InsertSQL, dbConnection

-End Sub

-

-Public Sub dbReSetREPRecord(dbConnection As Object)

-  

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM rep"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    CheckWorkBooksArround Wb

-End Sub

-

-

-Sub CheckWorkBooksArround(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If app.Workbooks.Count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKOnly, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-        Exit Sub

-    End If

-

-End Sub

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub SaveExcelState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-        ActiveWorkbook.DisplayDrawingObjects = xlDisplayShapes

-        

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.Count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars(STDBAR_NAME).Visible = False

-End Sub

-

-

-Public Sub RestoreExcelState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars(STDBAR_NAME).Visible = True

-End Sub

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Public Const STDBAR_NAME = "Worksheet Menu Bar"

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Export"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 620

-                        .OnAction = "cmExport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Exit && Restore Excel"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 548

-                        .OnAction = "cmExitRestore"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(flag As Boolean)

-    If flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars(STDBAR_NAME)

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmExport()

-    dbExport

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    Dim dlg As dlgAbout

-    Set dlg = New dlgAbout

-    

-    dlg.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlg.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlg.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlg.Show

-End Sub

-

-Sub cmMail2Support()

-    Dim err_description As String

-    Dim dlg_msg As dlg_Mail

-    Set dlg_msg = New dlg_Mail

-    With dlg_msg

-        .Show

-        If .Tag = vbOK Then

-            ThisWorkbook.Worksheets(VAR_SHEET).Range("ERR_MESSAGE") _

-                = .tbMessage.Text

-            ThisWorkbook.Save

-            ThisWorkbook.SendMail Recipients:="infra@i-rs.ru", Subject:=PROGRAM_NAME & " ver.:" & PROGRAM_VERSION

-            MsgBox "Сообщение об ошибке отправлено. Перезагрузите программу.", vbOKOnly, PROGRAM_NAME

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-    End With

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-'        helppath = "hh.exe " & .Path & "\Telfast.chm"

-'        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub set_work_mode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetupEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-End Sub

-

-Sub cmSetStandaloneMode()

-    set_work_mode

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    Dim dlg As dlgGetPwd

-    rp = common_pwd

-    

-    Set dlg = New dlgGetPwd

-    dlg.edPwd = ""

-    dlg.Show

-    

-    If dlg.edPwd = rp Then

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmHomePage()

-    ThisWorkbook.Worksheets("REP_QTR").Select

-End Sub

-

-Sub cmExitRestore()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = True

-    Application.Quit

-End Sub

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    Dim dlg_prn As dlgPrint

-    

-    Set dlg_prn = New dlgPrint

-    

-    With dlg_prn

-        .cbMainReport = True

-        .cbMainBudget = False

-        .cbSrcData = False

-        .cbAllSheets = False

-    

-        .Show

-    

-        If .Tag = vbCancel Then

-            Exit Sub

-        End If

-    End With

-    

-    Dim PrnIdx As Integer

-    

-    With dlg_prn

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("REP_QTR", "budget", "Final")

-    Case 1111

-        plist = Array("REP_QTR", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("REP_QTR")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Clexane bar"

-Public Const common_pwd As String = "crdjhxtyjr"

-

-

-Sub SetupEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    Wb.Worksheets(TITLE_SHEET).Select

-    With Application

-        .Caption = PROGRAM_NAME & " " & PROGRAM_VERSION

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .SaveExcelState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = False

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Wb.Worksheets(TITLE_SHEET).Select

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-'                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    If cWindow.Type = xlWorkbook Then

-                        cWindow.DisplayHeadings = True

-                    End If

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu True

-        End If

-        With mobjAppState

-            .RestoreExcelState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Worksheets(TITLE_SHEET).Select

-'        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Option Explicit

-

-Sub UpdateHWRecords(objHW() As Long)

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    dbUpdateHWRecords dbConnection, objHW

-    dbCloseConnection dbConnection

-End Sub

-

-Function GetHWRecords(objHW() As Long) As Integer

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    GetHWRecords = dbGetHWRecords(dbConnection, objHW)

-    dbCloseConnection dbConnection

-End Function

-

-Sub HWReset()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbInsertHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    

-    Dim dbRecordset As Object

-    Dim i As Long

-    

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "hw", dbConnection, 2, 2

-    

-    For i = 1 To UBound(objHW)

-        dbRecordset.addnew

-        dbRecordset("num") = objHW(i)

-        dbRecordset.Update

-    Next i

-    

-End Sub

-

-Sub dbUpdateHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    dbDeleteHWRecord dbConnection

-    dbInsertHWRecords dbConnection, objHW

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-dbHir
->>>>>>
-Attribute VB_Name = "dbHir"

-Option Explicit

-

-Public Type tHIRURGIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    operations_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_ambulator_clexan_40mg As Integer

-    patients_ambulator_clexan_20mg As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-    patients_stationar_clexan_40mg As Integer

-    patients_stationar_clexan_20mg As Integer

-End Type

-

-' if objHir.ID <> 0 then updatre else insert

-Sub Insert_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objHir.id <> 0 Then

-        dbUpdate_Hir_Record dbConnection, objHir

-    Else

-        dbInsert_Hir_Record dbConnection, objHir

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Hir_RecordsByLPU_ID(ByRef allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Hir_RecordsByLPU_ID = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, allHir, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Hir_Record dbConnection, objHir

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objHir.ID <> 0 then updatre else insert

-

-Sub dbInsert_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_hir", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objHir

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("operations_per_quarter") = .operations_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_ambulator_clexan_20mg") = .patients_ambulator_clexan_20mg

-        dbRecordset("patients_ambulator_clexan_40mg") = .patients_ambulator_clexan_40mg

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-        dbRecordset("patients_stationar_clexan_20mg") = .patients_stationar_clexan_20mg

-        dbRecordset("patients_stationar_clexan_40mg") = .patients_stationar_clexan_40mg

-        

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objHir.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim UpdateSQL As String

-    

-    With objHir

-        UpdateSQL = "UPDATE lpu_hir SET " & _

-            "entry_date='" & objHir.entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "operations_per_quarter=" & .operations_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_ambulator_clexan_20mg=" & .patients_ambulator_clexan_20mg & "," & _

-            "patients_ambulator_clexan_40mg=" & .patients_ambulator_clexan_40mg & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & "," & _

-            "patients_stationar_clexan_20mg=" & .patients_stationar_clexan_20mg & "," & _

-            "patients_stationar_clexan_40mg=" & .patients_stationar_clexan_40mg & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_Hir_RecordsbyLPU_ID(dbConnection As Object, allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Hir_SQL As String

-    Dim getAll_Hir_SQL As String

-    Dim Hir_Count As Long

-    Hir_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Hir_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Hir_Count = dbRecordset("HIR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Hir_RecordsbyLPU_ID = Hir_Count

-    

-    If Hir_Count > 0 Then

-        'we have records

-        ReDim allHir(1 To Hir_Count)

-        Dim index As Integer

-        index = 1

-        dbRecordset.Open getAll_Hir_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpHir As tHIRURGIA

-                 With tmpHir

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .operations_per_quarter = dbRecordset("operations_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_ambulator_clexan_20mg = dbRecordset("patients_ambulator_clexan_20mg")

-                    .patients_ambulator_clexan_40mg = dbRecordset("patients_ambulator_clexan_40mg")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                    .patients_stationar_clexan_20mg = dbRecordset("patients_stationar_clexan_20mg")

-                    .patients_stationar_clexan_40mg = dbRecordset("patients_stationar_clexan_40mg")

-                 End With

-                 

-                 allHir(index) = tmpHir

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE ID=" & objHir.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Hir_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbTer
->>>>>>
-Attribute VB_Name = "dbTer"

-Option Explicit

-

-Public Type tTERAPIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objTer.ID <> 0 then updatre else insert

-Sub Insert_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objTer.id <> 0 Then

-        dbUpdate_Ter_Record dbConnection, objTer

-    Else

-        dbInsert_Ter_Record dbConnection, objTer

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Ter_RecordsByLPU_ID(ByRef allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Ter_RecordsByLPU_ID = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, allTer, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Ter_Record dbConnection, objTer

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objTer.ID <> 0 then updatre else insert

-

-Sub dbInsert_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_ter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objTer

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("risk_percent") = Double2Str(.risk_percent, 3)

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objTer.id = dbRecordset("ID")

-

-End Sub

-

-Sub test()

-    Dim s As String

-    Dim d As Single

-    d = 1235.6789

-    s = Format(d, "####0,00")

-    MsgBox s

-End Sub

-

-Sub dbUpdate_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim Update_SQL As String

-    

-    With objTer

-        Update_SQL = "UPDATE lpu_ter SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_Ter_RecordsbyLPU_ID(dbConnection As Object, allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Ter_SQL As String

-    Dim getAll_Ter_SQL As String

-    Dim Ter_Count As Long

-    Ter_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Ter_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Ter_Count = dbRecordset("TER_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Ter_RecordsbyLPU_ID = Ter_Count

-    

-    If Ter_Count > 0 Then

-        'we have records

-        ReDim allTer(1 To Ter_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_Ter_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpTer As tTERAPIA

-                 With tmpTer

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 allTer(index) = tmpTer

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE ID=" & objTer.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Ter_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-mLPU_LIST
->>>>>>
-Attribute VB_Name = "mLPU_LIST"

-Option Explicit

-

-Public Const CINP_AREA As String = "B12"

-Public Const CLPU_NAME As Integer = 0

-Public Const CLPU_NAME1 As Integer = 1

-Public Const CLPU_NAME2 As Integer = 2

-Public Const CLPU_ID As Integer = 3

-Public Const CLPU_BEDS As Integer = 4

-Public Const CLPU_NFG As Integer = 5

-Public Const CLPU_NMG As Integer = 6

-Public Const CLPU_HIR As Integer = 7

-Public Const CLPU_TER As Integer = 8

-Public Const CLPU_CAR As Integer = 9

-Public Const CLPU_FACT As Integer = 10

-Public Const CLPU_PLAN As Integer = 11

-Public Const CLPU_PAT_LPU As Integer = 16

-Public Const CLPU_BDGT As Integer = 17

-Public Const CLPU_PAT_ALL As Integer = 16

-

-

-

-Sub EditLPU(cLPU As tLPU, ent_date As String)

-    Dim del_request As Integer

-    Dim allLPU() As tLPU

-    Dim lpu_count As Integer

-    Dim i As Integer

-    Dim tmp_LPU_List As Range

-    Dim tmp_LPU_List_Addr As String

-    Dim r_end As Range

-    Dim dlg As Dlg_lpu_card

-    

-    Set dlg = New Dlg_lpu_card

-    

-    lpu_count = GetAllLPU(allLPU)

-    With Worksheets(VAR_SHEET)

-        Set tmp_LPU_List = .Range("tmp_LPU_List")

-        Set r_end = .Range(tmp_LPU_List, tmp_LPU_List.End(xlDown))

-        Set r_end = .Range(r_end, r_end.End(xlToRight))

-        .Range(tmp_LPU_List, r_end).ClearContents

-    End With

-        

-    If lpu_count <> 0 Then

-        dlg.cbxLPU_List_Enable.Enabled = True

-        For i = 1 To UBound(allLPU)

-            tmp_LPU_List.Cells(i, 1) = allLPU(i).name

-            tmp_LPU_List.Cells(i, 2) = allLPU(i).address

-            tmp_LPU_List.Cells(i, 3) = allLPU(i).beds

-            tmp_LPU_List.Cells(i, 4) = allLPU(i).id

-        Next i

-    Else

-        dlg.cbxLPU_List_Enable.Enabled = False

-    End If

-    

-    tmp_LPU_List_Addr = Worksheets(VAR_SHEET).name & "!" & _

-            Worksheets(VAR_SHEET).Range(tmp_LPU_List, tmp_LPU_List.End(xlDown)).address

-

-    With dlg

-        .cbLPU_List.RowSource = tmp_LPU_List_Addr

-        .cbLPU_List.ListIndex = 0

-        .cbxLPU_List_Enable = False

-        .cbLPU_List.Enabled = False

-        If cLPU.id <> 0 Then

-            .cbxLPU_List_Enable.Enabled = False

-        Else

-            If lpu_count <> 0 Then

-                .cbxLPU_List_Enable.Enabled = True

-            Else

-                .cbxLPU_List_Enable.Enabled = False

-            End If

-        End If

-        .tb_lpu_name.Text = cLPU.name

-        .tb_lpu_address.Text = cLPU.address

-        .tbBedsCount = cLPU.beds

-

-        .Tag = vbCancel

-    End With

-    

-    dlg.Show

-    

-    If Not IsNumeric(dlg.Tag) Then

-        Exit Sub

-    End If

-    

-    If dlg.Tag = vbOK Then

-        Dim n As Variant

-        Dim test As Integer

-        test = 0

-        n = dlg.tbBedsCount.Value

-        If Not IsNumeric(n) Then

-            test = 1

-        Else

-            If n = 0 Then

-                test = 1

-            End If

-        End If

-        If test = 0 Then

-            

-            cLPU.name = dlg.tb_lpu_name.Text

-            cLPU.address = dlg.tb_lpu_address.Text

-            cLPU.beds = dlg.tbBedsCount.Value

-                                    

-            If cLPU.name = "" Or cLPU.address = "" Then

-                test = 2

-            End If

-        End If

-        Select Case test

-            Case 0

-                If dlg.cbxLPU_List_Enable.Value = True Then

-                    cLPU.id = tmp_LPU_List.Cells(dlg.cbLPU_List.ListIndex + 1, 4)

-                End If

-                Insert_LPU_Record cLPU

-                ' Проверить наличие данных для ЛПУ в квартале

-                Dim bdgt As tBUDGET

-                bdgt = Get_BDGT_Record(cLPU.id, ent_date)

-                ' Записи нет: создать пустую запись в lpu_budget

-                If bdgt.id = 0 Then

-                    bdgt.lpu_id = cLPU.id

-                    bdgt.entry_date = ent_date

-                    Insert_BDGT_Record bdgt

-                End If

-            Case 1

-                MsgBox "Коечная мощьность измеряется числом более чем 1!", vbOKOnly, PROGRAM_NAME

-            Case 2

-                MsgBox "Наименование и адрес ЛПУ не должны быть пустыми!", vbOKOnly, PROGRAM_NAME

-        End Select

-    End If

-End Sub

-

-Sub Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-

-End Sub

-

-Sub Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btLPU_DEL_IT()

-    Dim cLPU As tLPU

-    Dim ent_date As String

-    Dim delete_all As Integer

-    Dim dlg_del As dlg_LPU_delete

-    

-    With Worksheets("LPU_LIST")

-        ent_date = .Range("ent_date")

-        cLPU.id = .getCurrentLPU_ID()

-    End With

-    

-    If cLPU.id = 0 Then

-        MsgBox "Укажите удаляемый объект", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    cLPU = Get_LPU_Record(cLPU.id)

-    

-    Set dlg_del = New dlg_LPU_delete

-    With dlg_del

-        .chbDeleteQTR.Value = True

-        .chbDeleteAll.Value = False

-        .lComment = ent_date & ": Удаление ЛПУ '" _

-        & cLPU.name & "', расположенного по адресу:" _

-        & cLPU.address & "."

-        .Show

-        

-        If .Tag = vbOK Then

-            If .chbDeleteAll.Value Then

-                delete_all = _

-                    MsgBox("Все записи об ЛПУ с именем '" & cLPU.name & _

-                    "' будут удалены навсегда.", vbOK, PROGRAM_NAME)

-                If delete_all = vbOK Then

-                    Delete_LPU_Record cLPU

-                End If

-            Else

-                Delete_LPU_RecordQTR cLPU, ent_date

-            End If

-        End If

-    End With

-    

-    With ThisWorkbook

-        .Worksheets(TITLE_SHEET).Select

-        .Worksheets("LPU_LIST").Select

-    End With

-End Sub

-

-Sub btLPU_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Activate

-End Sub

-

-

-Sub btLPU_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim lpu_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("QTR_ACTION").Value

-    With Worksheets("LPU_LIST")

-        ent_date = .getEnt_date()

-        

-    

-        lpu_id = .getCurrentLPU_ID

-        If lpu_id <> 0 And i = 1 Then

-            lpu_id = 0

-        End If

-        If lpu_id = 0 Then

-            i = 1

-        End If

-        Select Case i

-            Case 1, 6

-                .SelectLPU_NAME lpu_id, ent_date

-                .Range("JUMP") = ""

-            Case 2

-                If lpu_id <> 0 Then

-                    .SelectLPU_BDGT lpu_id, ent_date

-                    .Range("JUMP") = "LPU_BDGT"

-                End If

-            Case 3

-                If lpu_id <> 0 Then

-                    .SelectLPU_HIR lpu_id, ent_date

-                    .Range("JUMP") = "LPU_CLSN_HIR"

-                End If

-            Case 4

-                If lpu_id <> 0 Then

-                    .SelectLPU_TER lpu_id, ent_date

-                    .Range("JUMP") = "LPU_CLSN_TER"

-                End If

-            Case 5

-                If lpu_id <> 0 Then

-                    .SelectLPU_C_ACS lpu_id, ent_date

-                    .Range("JUMP") = "LPU_CLSN_C_ACS"

-                End If

-        End Select

-    End With

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-dbQTR
->>>>>>
-Attribute VB_Name = "dbQTR"

-Option Explicit

-

-Public Type tQTR

-    id As Long

-    entry_date As String

-    rep_id As Long

-    sale_plan As Long

-    ClxnH20mg As Long

-    ClxnH40mg As Long

-    ClxnT40mg As Long

-    ClxnC_IM As Long

-    ClxnC_ACS As Long

-End Type

-

-

-Function GetLastQTR_fromDB() As String

-    Dim dbConnection As Object

-    Dim getCount_QTR_SQL As String

-    Dim getLast_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter"

-    getLast_QTR_SQL = "SELECT MAX(entry_date) as ent_date FROM quarter"

-    

-    dbOpenConnection dbConnection

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    If QTR_Count > 0 Then

-        'we have records

-        dbRecordset.Open getLast_QTR_SQL, dbConnection

-        getLast_QTR_SQL = dbRecordset("ent_date")

-    Else

-        getLast_QTR_SQL = ""

-    End If

-    

-    GetLastQTR_fromDB = getLast_QTR_SQL

-    dbCloseConnection dbConnection

-End Function

-

-Sub Insert_QTR_Record(ByRef objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objQTR.id <> 0 Then

-        dbUpdate_QTR_Record dbConnection, objQTR

-    Else

-        dbInsert_QTR_Record dbConnection, objQTR

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-Function Get_QTR_Record(ent_date As String) As tQTR

-    Dim dbConnection As Object

-    Dim allQTR() As tQTR

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    i = dbGetAll_QTR_Records(dbConnection, allQTR, ent_date)

-    If i <> 0 Then

-        Get_QTR_Record = allQTR(1)

-    End If

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTR_Records(ByRef All_QTR() As tQTR, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_QTR_Records = dbGetAll_QTR_Records(dbConnection, All_QTR, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_QTR_Record(ByRef objQTR As tQTR)

-    Dim dbConnection As Object

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_QTR_Record dbConnection, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objQTR.ID <> 0 then updatre else insert

-Sub dbInsert_QTR_Record(dbConnection As Object, ByRef objQTR As tQTR)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "quarter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objQTR

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("sale_plan") = .sale_plan

-        dbRecordset("rep_id") = .rep_id

-        dbRecordset("ClxnH20mg") = .ClxnH20mg

-        dbRecordset("ClxnH40mg") = .ClxnH40mg

-        dbRecordset("ClxnT40mg") = .ClxnT40mg

-        dbRecordset("ClxnC_IM") = .ClxnC_IM

-        dbRecordset("ClxnC_ACS") = .ClxnC_ACS

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objQTR.id = dbRecordset("id")

-

-End Sub

-

-Sub dbUpdate_QTR_Record(dbConnection As Object, ByRef objQTR As tQTR)

-    Dim Update_SQL As String

-    

-    With objQTR

-        Update_SQL = "UPDATE quarter SET " & _

-            "entry_date='" & .entry_date & "'" & "," & _

-            "rep_id=" & .rep_id & "," & _

-            "sale_plan=" & .sale_plan & "," & _

-            "ClxnH20mg=" & .ClxnH20mg & "," & _

-            "ClxnH40mg=" & .ClxnH40mg & "," & _

-            "ClxnT40mg=" & .ClxnT40mg & "," & _

-            "ClxnC_IM=" & .ClxnC_IM & "," & _

-            "ClxnC_ACS=" & .ClxnC_ACS & _

-            " WHERE id=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if ent_date = % then all_records

-Function dbGetAll_QTR_Records(dbConnection As Object, All_QTR() As tQTR, ent_date As String) As Integer

-    

-    Dim getCount_QTR_SQL As String

-    Dim getAll_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter WHERE entry_date like '" & ent_date & "'"

-    getAll_QTR_SQL = "SELECT * FROM quarter WHERE entry_date like '" & ent_date & "' ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_QTR_Records = QTR_Count

-    

-    If QTR_Count > 0 Then

-        'we have records

-        ReDim All_QTR(1 To QTR_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTR_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTR As tQTR

-                 With tmp_QTR

-                    .entry_date = dbRecordset("entry_date")

-                    .rep_id = dbRecordset("rep_id")

-                    .sale_plan = dbRecordset("sale_plan")

-                    .ClxnH20mg = dbRecordset("ClxnH20mg")

-                    .ClxnH40mg = dbRecordset("ClxnH40mg")

-                    .ClxnT40mg = dbRecordset("ClxnT40mg")

-                    .ClxnC_IM = dbRecordset("ClxnC_IM")

-                    .ClxnC_ACS = dbRecordset("ClxnC_ACS")

-                    .id = dbRecordset("id")

-                 End With

-                 

-                 All_QTR(index) = tmp_QTR

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_QTR_Record(dbConnection As Object, ByRef objQTR As tQTR)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM quarter " & _

-    "WHERE id=" & objQTR.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByQTR dbConnection, objQTR.entry_date

-    dbDelete_Hir_RecordsByQTR dbConnection, objQTR.entry_date

-    dbDelete_Ter_RecordsByQTR dbConnection, objQTR.entry_date

-    dbDelete_ACS_RecordsByQTR dbConnection, objQTR.entry_date

-       

-End Sub

-<<<<<<
-======================
-cdbQTR
->>>>>>
-Attribute VB_Name = "cdbQTR"

-Option Explicit

-

-Public Type tQTR_COMMON

-    qtr As tQTR

-    i_lcd As Long           ' число ЛПУ в СПИСКЕ

-    lcd() As tLPU_COMMON    ' список ЛПУ

-    c_beds As Long          ' сумма коек

-    c_bdgt_NFG As Long      ' общий бюджет на НФГ

-    c_bdgt_NMG As Long      ' общий бюджет на НМГ

-    c_bdgt_LPU As Long      ' общий бюджет на гепарины

-    c_sale_PLAN As Long     ' план продаж репа

-    c_sale_ALL As Long      ' продажи

-    c_sale_HIR As Long      ' в хирургии

-    c_sale_TER  As Long     ' в терапии

-    c_sale_CRD  As Long     ' в кардиологии

-    c_pat_HIR   As Long     ' пациенты

-    c_pat_TER   As Long     '

-    c_pat_CRD   As Long     '

-    c_pat_ALL   As Long     '

-    c_pat_LPU   As Long     ' Всего операций

-End Type

-

-Function Get_QTR_CommonList(ByRef qcd() As tQTR_COMMON) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_QTR_CommonList = dbGet_QTR_CommonList(dbConnection, qcd)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_CommonList(dbConnection As Object, ByRef qcd() As tQTR_COMMON) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim allQTR() As tQTR

-    i = dbGetAll_QTR_Records(dbConnection, allQTR, "%")

-    dbGet_QTR_CommonList = i

-    If i > 0 Then

-        ReDim qcd(i)

-        For i = 1 To UBound(allQTR)

-            With qcd(i)

-                .qtr = allQTR(i)

-                .c_beds = 0

-                .c_bdgt_NFG = 0

-                .c_bdgt_NMG = 0

-                .c_bdgt_LPU = 0

-                .c_sale_PLAN = 0

-                .c_pat_HIR = 0

-                .c_pat_TER = 0

-                .c_pat_CRD = 0

-                .c_pat_ALL = 0

-                .c_sale_HIR = 0

-                .c_sale_TER = 0

-                .c_sale_CRD = 0

-                .c_sale_ALL = 0

-                .c_pat_LPU = 0

-                

-                j = dbGet_LPU_CommonQTR(dbConnection, .lcd, .qtr)

-                .i_lcd = j

-                If j > 0 Then

-                    For j = 1 To UBound(.lcd)

-                        .c_beds = .c_beds + .lcd(j).lpu.beds

-                        .c_bdgt_NFG = .c_bdgt_NFG + .lcd(j).bdgt.bdgt_NFG

-                        .c_bdgt_NMG = .c_bdgt_NMG + .lcd(j).bdgt.bdgt_NMG

-                        .c_bdgt_LPU = .c_bdgt_LPU + .lcd(j).bdgt_LPU

-                        .c_sale_PLAN = .c_sale_PLAN + .lcd(j).bdgt.sale_plan

-                        .c_pat_HIR = .c_pat_HIR + .lcd(j).pat_HIR

-                        .c_pat_TER = .c_pat_TER + .lcd(j).pat_TER

-                        .c_pat_CRD = .c_pat_CRD + .lcd(j).pat_CRD

-                        .c_pat_ALL = .c_pat_ALL + .lcd(j).pat_ALL

-                        .c_sale_HIR = .c_sale_HIR + .lcd(j).sale_HIR

-                        .c_sale_TER = .c_sale_TER + .lcd(j).sale_TER

-                        .c_sale_CRD = .c_sale_CRD + .lcd(j).sale_CRD

-                        .c_sale_ALL = .c_sale_ALL + .lcd(j).sale_ALL

-                        .c_pat_LPU = .c_pat_LPU + .lcd(j).pat_LPU

-                    Next j

-                    

-                End If

-            End With

-        Next i

-    End If

-End Function

-

-Function GetLastQtr() As String

-    Dim s As String

-    Dim r As Range

-    Set r = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Do While r.Cells(1, 1) <> ""

-        s = r.Cells(1, 1)

-        Set r = r.Cells.Offset(1, 0)

-    Loop

-    GetLastQtr = s

-End Function

-

-Function GetNextQTR(ent_date As String) As String

-    Dim rd As Range

-    Dim idx As Integer

-    Dim b As Variant

-    Dim dlg As dlg_newQTR

-    Set dlg = New dlg_newQTR

-    

-    On Error GoTo l_exit

-    If ent_date = "" Then

-        Dim ir As Variant

-        idx = 0

-        dlg.Show

-        b = dlg.Tag

-            

-        If IsNumeric(b) Then

-            GetNextQTR = dlg.cbQTR

-        Else

-            GetNextQTR = ""

-        End If

-    Else

-        Set rd = Worksheets(VAR_SHEET).Range("Date_Lst")

-        idx = WorksheetFunction.Match(ent_date, rd, 0)

-        GetNextQTR = WorksheetFunction.index(rd, idx + 1, 1)

-    End If

-l_exit:

-End Function

-<<<<<<
-======================
-mRestView
->>>>>>
-Attribute VB_Name = "mRestView"

-Option Explicit

-

-Sub xlRestoreView()

-Attribute xlRestoreView.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute xlRestoreView.VB_ProcData.VB_Invoke_Func = " \n14"

-    With Application

-        .CommandBars("Standard").Visible = True

-        .CommandBars("Formatting").Visible = True

-        .DisplayFormulaBar = True

-        .DisplayStatusBar = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = True

-        .EditDirectlyInCell = True

-    End With

-End Sub

-<<<<<<
-======================
-dlg_newQTR
->>>>>>
-Attribute VB_Name = "dlg_newQTR"

-Attribute VB_Base = "0{2FC04B4C-EB99-433E-ACDB-A920D02B9B5B}{777B85CC-ADE3-4188-94C8-9E07DA8B5076}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mDec2TS
->>>>>>
-Attribute VB_Name = "mDec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-CHRT_LPU_BBL
->>>>>>
-Attribute VB_Name = "CHRT_LPU_BBL"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Unprotect

-    Range("view_key") = True

-    On Error Resume Next

-    ChangeLabels

-    Range("A1").Select

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Unprotect

-    Dim s As String

-    s = Range("ret_addr")

-    Protect UserInterfaceOnly:=True

-    Wks_select (s)

-End Sub

-

-Sub BCLabelChng_Click()

-    Unprotect

-    If Range("view_key") Then

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать названия"

-    Else

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать объемы"

-    End If

-    Range("view_key") = Not Range("view_key")

-    ChangeLabels

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub ChangeLabels()

-    Dim i As Integer

-    Dim offset_text As Integer

-    Dim src As Range

-    Set src = Range("CHRT_BBL_DATA")

-    

-    offset_text = 3

-    If Range("view_key") Then

-        offset_text = 4

-    End If

-    

-    On Error GoTo ExitLabel

-    

-    With ChartObjects(1).Chart

-        With .SeriesCollection(1)

-            For i = 1 To .Points.Count

-                On Error Resume Next

-                .Points(i).DataLabel.Characters.Text = Format(src.Cells(i, offset_text))

-            Next i

-        End With

-    End With

-ExitLabel:

-End Sub

-

-<<<<<<
-======================
-CHRT_PAT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PAT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-<<<<<<
-======================
-CHRT_PAT_LPU
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_nextQTR
->>>>>>
-Attribute VB_Name = "dlg_nextQTR"

-Attribute VB_Base = "0{3F7D7D75-90F6-4829-9E24-CA5391BB2A03}{A1A0F296-0D28-4123-8E38-82FA6EE6F2EF}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-

-<<<<<<
-======================
-cdbLPU
->>>>>>
-Attribute VB_Name = "cdbLPU"

-Option Explicit

-

-Public Type tLPU_COMMON

-    lpu As tLPU

-    bdgt As tBUDGET

-    i_hir As Long

-    hir() As tHIRURGIA

-    i_ter As Long

-    ter() As tTERAPIA

-    i_ACS As Long

-    ACS() As tACS

-    bdgt_LPU As Long

-    sale_HIR As Long

-    sale_TER As Long

-    sale_CRD As Long

-    sale_ALL As Long

-    pat_HIR As Long

-    pat_TER As Long

-    pat_CRD As Long

-    pat_ALL As Long     ' Сумма всех пациентов на клексане

-    pat_LPU As Long     ' Число потенциальных пациентов для продаж клексана

-End Type

-

-Function Get_LPU_CommonQTR(ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    Get_LPU_CommonQTR = dbGet_LPU_CommonQTR(dbConnection, lcd, objQTR)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_CommonQTR(dbConnection As Object, ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    i = dbGetAllLPUbyQTR(dbConnection, allLPU, objQTR.entry_date)

-    dbGet_LPU_CommonQTR = i

-    If i > 0 Then

-        ReDim lcd(i)

-        For i = 1 To UBound(allLPU)

-            dbGet_LPU_Common dbConnection, lcd(i), allLPU(i), objQTR

-        Next i

-    End If

-End Function

-

-Sub Get_LPU_Common(ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    dbGet_LPU_Common dbConnection, lcd, cLPU, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbGet_LPU_Common(dbConnection As Object, ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-

-    lcd.lpu = cLPU

-    lcd.bdgt = dbGet_BDGT_Record(dbConnection, cLPU.id, objQTR.entry_date)

-    lcd.i_hir = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, lcd.hir, cLPU.id, objQTR.entry_date)

-    lcd.i_ter = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, lcd.ter, cLPU.id, objQTR.entry_date)

-    lcd.i_ACS = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, lcd.ACS, cLPU.id, objQTR.entry_date)

-    With lcd

-        .bdgt_LPU = .bdgt.bdgt_NFG + .bdgt.bdgt_NMG

-        .pat_LPU = 0

-        If .i_hir > 0 Then

-            .pat_HIR = .hir(1).patients_ambulator_clexan + .hir(1).patients_stationar_clexan

-            .sale_HIR = objQTR.ClxnH20mg * (.hir(1).patients_ambulator_clexan_20mg + .hir(1).patients_stationar_clexan_20mg)

-            .sale_HIR = .sale_HIR + objQTR.ClxnH40mg * (.hir(1).patients_ambulator_clexan_40mg + .hir(1).patients_stationar_clexan_40mg)

-            .pat_LPU = .pat_LPU + .hir(1).operations_per_quarter

-        End If

-        If .i_ter > 0 Then

-            .pat_TER = .ter(1).patients_ambulator_clexan + .ter(1).patients_stationar_clexan

-            .sale_TER = .pat_TER * objQTR.ClxnT40mg

-            .pat_LPU = .pat_LPU + .ter(1).patients_per_quarter

-        End If

-        If .i_ACS > 0 Then

-            .pat_CRD = .ACS(1).patients_stationar_clexan

-            .sale_CRD = .pat_CRD * objQTR.ClxnC_ACS

-            .pat_LPU = .pat_LPU + .ACS(1).patients_per_quarter

-        End If

-        .pat_ALL = .pat_HIR + .pat_TER + .pat_CRD

-        .sale_ALL = .sale_HIR + .sale_TER + .sale_CRD

-    End With

-End Sub

-

-<<<<<<
-======================
-CHRT_PIE
->>>>>>
-Attribute VB_Name = "CHRT_PIE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-   

-    Unprotect

-    On Error Resume Next

-    Range("P5:Q24").Sort _

-        Key1:=Range("Q5"), _

-        Order1:=xlDescending, _

-        Header:=xlGuess, _

-        OrderCustom:=1, _

-        MatchCase:=False, _

-        Orientation:=xlTopToBottom

-        

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PLN_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PLN_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_BDGT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_BDGT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_LPU_delete
->>>>>>
-Attribute VB_Name = "dlg_LPU_delete"

-Attribute VB_Base = "0{91AE5FA0-01C7-4C10-9E5F-D1D2DDF29401}{5726592A-BC0A-4E79-A963-35D354045716}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlg_Mail
->>>>>>
-Attribute VB_Name = "dlg_Mail"

-Attribute VB_Base = "0{FB055133-927F-41FF-BC90-442833A40591}{11BCAB43-1EDD-440B-AB0E-20CD6E42E11A}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dbREP_id
->>>>>>
-Attribute VB_Name = "dbREP_id"

-Public Type tID_REP

-    id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Public Type tID_REP_COMMON

-    id_rep As tID_REP

-    i_qtr As Long

-    qtrs As tQTR_COMMON

-End Type

-<<<<<<
-======================
-cdbExport
->>>>>>
-Attribute VB_Name = "cdbExport"

-Option Explicit

-

-Function GetDBSN() As String

-    Dim n As Long

-    Randomize Timer

-    n = Int((100000000 - 1000000 + 1) * Rnd + 1000000)

-    GetDBSN = Dec2ThirtySix(n)

-End Function

-

-Sub dbExport()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim last_qtr As String

-    

-    On Error GoTo ErrHandler

-    

-    last_qtr = GetLastQTR_fromDB

-    If last_qtr = "" Then

-        MsgBox "Нет записей в базе данных. Экспорт невозможен.", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & last_qtr & "_" & GetDBSN() & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Данные экспортированы в файл:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для передачи", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-Exit Sub

-

-ErrHandler:

-    If err.number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-<<<<<<
-======================
-mRegs
->>>>>>
-Attribute VB_Name = "mRegs"

-Option Explicit

-

-Function GetRegionName(idx As Integer) As String

-    GetRegionName = Worksheets(REGS_SHEET).Range("LST_REGIONS").Cells(idx + 1, 1).Text

-End Function

-

-Function GetCityName(idx_reg As Integer, idx_city As Integer) As String

-    GetCityName = Worksheets(REGS_SHEET).Range("CITY_TABLES").Offset(idx_city + 1, idx_reg * 2).Text

-End Function

-

-Sub t()

-    Dim r As Integer

-    Dim c As Integer

-    Dim s As String

-    

-    r = 3

-    c = 3

-    s = GetRegionName(r)

-    s = s & ", " & GetCityName(r, c)

-    MsgBox s

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Save

-End Sub

-

-Private Sub Workbook_Open()

-    FindRestoreData

-End Sub

-

-Sub FindRestoreData()

-    Dim i As Integer

-    Dim def_dir As String

-    Dim dbname As String

-    Dim caption As String

-    caption = PROGRAM_NAME + " " + PROGRAM_VERSION

-    If MsgBox("Восстановление данных. Продолжить?", vbYesNo, caption) = vbYes Then

-        def_dir = "C:\CLEXANE"

-        If GetDBName(def_dir, dbname) Then

-            HWReset dbname

-            MsgBox "Данные в файле " + dbname + " восстановлены :)", vbOKOnly, caption

-        Else

-            MsgBox "Выход без изменений"

-        End If

-    End If

-    With Application

-        .DisplayAlerts = False

-        .Quit

-    End With

-End Sub

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mDataBase
->>>>>>
-Attribute VB_Name = "mDataBase"

-Option Explicit

-

-Sub dbOpenConnection(dbConnection As Object, dbname As String)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = dbname

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, SQL As String)

-    dbConnection.Execute (SQL)

-End Sub

-

-

-

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-End Sub

-

-Function Double2Str(ByVal d As Double, ByVal precision As Integer, Optional Delim As String = ".") As String

-    Dim s As String

-    If Not precision > 0 Then

-        s = Round(d)

-    Else

-        Dim i As Integer

-        i = Fix(d)

-        s = i & Delim

-        d = Abs(d - i)

-        Do

-            precision = precision - 1

-            d = d * 10

-            If precision > 0 Then

-                i = Fix(d)

-            Else

-                i = Round(d)

-            End If

-            If i < 1 Then

-                s = s & "0"

-            Else

-                s = s & i

-                d = d - i

-            End If

-        Loop While precision > 0

-    End If

-    Double2Str = s

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetWBName(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBName = Right(FullName, s_len - pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.Count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.Name = VAR_SHEET Or sh.Name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane"

-Public Const PROGRAM_VERSION As String = "version 1.6"

-Public Const PROGRAM_FILENAME As String = "clexane-mr"

-Public Const PROGRAM_EXPORTNAME As String = "mr-ex-"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20030329

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "O40"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Sub HWReset(dbname As String)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection, dbname

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-mGetDBName
->>>>>>
-Attribute VB_Name = "mGetDBName"

-Option Explicit

-

-Const OFN_ALLOWMULTISELECT As Long = 512

-Const OFN_EXPLORER As Long = 524288

-Const OFN_HIDEREADONLY As Long = 4

-Const OFN_NONETWORKBUTTON As Long = 131072

-Const OFN_READONLY As Long = 1

-       

-Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _

-    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

-

-Private Type OPENFILENAME

-    lStructSize As Long

-    hWndOwner As Long

-    hInstance As Long

-    lpstrFilter As String

-    lpstrCustomFilter As String

-    nMaxCustFilter As Long

-    nFilterIndex As Long

-    lpstrFile As String

-    nMaxFile As Long

-    lpstrFileTitle As String

-    nMaxFileTitle As Long

-    lpstrInitialDir As String

-    lpstrTitle As String

-    flags As Long

-    nFileOffset As Integer

-    nFileExtension As Integer

-    lpstrDefExt As String

-    lCustData As Long

-    lpfnHook As Long

-    lpTemplateName As String

-End Type

-

-Function GetDBName(DB_dir As String, dbname As String) As Boolean

-    Dim OpenFile As OPENFILENAME

-    Dim lReturn As Long

-    Dim sFilter As String

-    

-    OpenFile.lStructSize = Len(OpenFile)

-    '         OpenFile.hwndOwner = Form1.hWnd

-    '         OpenFile.hInstance = App.hInstance

-    sFilter = "Clexane Data Files" & Chr(0) & "clexane*.mdb" & Chr(0)

-    OpenFile.lpstrFilter = sFilter

-    OpenFile.nFilterIndex = 1

-    OpenFile.lpstrFile = String(257, 0)

-    OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1

-    OpenFile.lpstrFileTitle = OpenFile.lpstrFile

-    OpenFile.nMaxFileTitle = OpenFile.nMaxFile

-    OpenFile.lpstrInitialDir = DB_dir

-    OpenFile.lpstrTitle = "Исправление данных"

-    OpenFile.flags = OFN_HIDEREADONLY + OFN_EXPLORER

-    lReturn = GetOpenFileName(OpenFile)

-    If lReturn = 0 Then

-        GetDBName = False

-        dbname = ""

-    Else

-        GetDBName = True

-        Dim flist() As String

-        flist = Split(OpenFile.lpstrFile, Chr(0), Compare:=vbBinaryCompare)

-        dbname = flist(0)

-    End If

-End Function

-

-

-<<<<<<
-Project Name : 'ClexaneRM'
-Quirk - duff tag length======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    ThisWorkbook.Worksheets(RM_QTR_SHEET).ClearRMName

-    

-    Application.EnableEvents = True

-    Set MyAppEvents.app = Application

-    

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    

-    MyAppEvents.CheckWorkBooksArround ThisWorkbook

-    

-    cmSetStandaloneMode

-    

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-    

-    Application.ScreenUpdating = True

-    

-    If CheckUser Then

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).update_history

-        Application.Calculate

-    End If

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    

-    Dim RestMode As Boolean

-    RestMode = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE")

-    

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-'        If RestMode Then

-            ThisWorkbook.Saved = True

-'        Else

-'            ThisWorkbook.Save

-'        End If

-    End If

-    Application.Caption = Empty

-    Application.CommandBars(STDBAR_NAME).Reset

-    If RestMode Then

-        xlRestoreView

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    End If

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-    Dim MaxX, MaxY As Integer

-    With ThisWorkbook.Worksheets(TITLE_SHEET)

-        MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-        MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-    End With

-

-    With ThisWorkbook.Application

-        .ScreenUpdating = False

-        .WindowState = xlNormal

-        .Height = MaxY

-        .Width = MaxX

-    End With

-End Sub

-

-

-

-

-

-<<<<<<
-======================
-REP_QTR
->>>>>>
-Attribute VB_Name = "REP_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CQTR_QT As Integer = 0

-Const CQTR_ID As Integer = 1

-Const CQTR_PLN As Integer = 2

-Const CQTR_FCT As Integer = 3

-Const CQTR_BDG As Integer = 4

-Const CQTR_CNT As Integer = 5

-Const CQTR_BEDS As Integer = 6

-Const CQTR_HIR As Integer = 7

-Const CQTR_TER As Integer = 8

-Const CQTR_CRD As Integer = 9

-Const CQTR_CLXN_BDG As Integer = 10

-Const CQTR_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub update_history()

-    Dim objQTR() As tQTR

-    Dim i As Long

-    Dim r As Range

-    Dim cRep As tREPID

-

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    Range("D4") = cRep.LastName

-    Range("D5") = cRep.FirstName

-

-    Range("H4") = GetRegionName(cRep.Region)

-    Range("H5") = GetCityName(cRep.Region, cRep.City)

-

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetAll_QTR_Records_by_REP(objQTR, "%", cRep.rep_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CQTR_QT) = objQTR(i).entry_date

-        Next i

-    End If

-    Dim qcd() As tQTR_COMMON

-    i = Get_QTR_CommonList_by_REP(qcd, "%", cRep.rep_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(qcd)

-            r.Offset(i - 1, CQTR_QT) = qcd(i).qtr.entry_date

-            r.Offset(i - 1, CQTR_ID) = qcd(i).qtr.id

-            r.Offset(i - 1, CQTR_PLN) = qcd(i).qtr.sale_PLAN

-            r.Offset(i - 1, CQTR_FCT) = qcd(i).c_sale_ALL

-            r.Offset(i - 1, CQTR_BDG) = qcd(i).c_bdgt_LPU

-            r.Offset(i - 1, CQTR_CNT) = qcd(i).i_lcd

-            r.Offset(i - 1, CQTR_BEDS) = qcd(i).c_beds

-            r.Offset(i - 1, CQTR_HIR) = qcd(i).c_pat_HIR

-            r.Offset(i - 1, CQTR_TER) = qcd(i).c_pat_TER

-            r.Offset(i - 1, CQTR_CRD) = qcd(i).c_pat_CRD

-            If qcd(i).c_bdgt_LPU <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_BDG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_LPU

-            End If

-            If qcd(i).c_bdgt_NMG <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_NMG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CQTR_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRepQtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect UserInterfaceOnly:=True

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CQTR_ID + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    i = currRange.Column - Range(CINP_AREA).Column

-

-    QTR_ID = r

-

-    If QTR_ID = 0 Then

-        Worksheets(VAR_SHEET).Range("USER_ACTION") = 1

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        If i > CQTR_FCT Then

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-            Range("LAST_FOCUS") = currRange.address

-        Else

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 3

-            Range("LAST_FOCUS") = currRange.address

-        End If

-    End If

-    Cancel = True

-    btHomeDo_IT

-End Sub

-

-<<<<<<
-======================
-mRep_QTR
->>>>>>
-Attribute VB_Name = "mRep_QTR"

-Option Explicit

-

-Sub NoFunc()

-    MsgBox "Функция не доступна", vbOKOnly, PROGRAM_NAME

-End Sub

-

-Sub DO_Price_qtr(ent_date As String)

-    Dim qtr As tQTR

-    Dim res As Integer

-    Dim cRep As tREPID

-

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    qtr = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-

-    If qtr.id = 0 Then

-        qtr.entry_date = ent_date

-

-        With Worksheets(VAR_SHEET)

-            qtr.ClxnH20mg = .Range("ClxnH20mg")

-            qtr.ClxnH40mg = .Range("ClxnH40mg")

-            qtr.ClxnT40mg = .Range("ClxnT40mg")

-            qtr.ClxnC_ACS = .Range("ClxnC_ACS")

-            qtr.ClxnC_IM = .Range("ClxnC_IM")

-        End With

-    End If

-

-    Dim dlg_nq As dlg_nextQTR

-    Set dlg_nq = New dlg_nextQTR

-

-    With dlg_nq

-        .tb_qtr_name = qtr.entry_date

-        .tb_bdgt_avts = qtr.sale_PLAN

-        .tb_qtr_name = qtr.entry_date

-        .tb_ClxnH20mg = qtr.ClxnH20mg

-        .tb_ClxnH40mg = qtr.ClxnH40mg

-        .tb_ClxnT40mg = qtr.ClxnT40mg

-        .tb_ClxnC_ACS = qtr.ClxnC_ACS

-        .tb_ClxnC_IM = qtr.ClxnC_IM

-    End With

-

-    dlg_nq.Show

-End Sub

-

-Sub DO_Edit_qtr(ent_date As String)

-    If ent_date = "" Then

-        NoFunc

-    Else

-        Dim rep_id As Long

-        rep_id = Worksheets(REP_QTR_SHEET).Range("REP_ID")

-        With ThisWorkbook.Worksheets("LPU_LIST")

-            .Range("VIEW_ONLY") = True

-            .Range("ent_date") = ent_date

-            .Range("REP_ID") = rep_id

-            .Select

-        End With

-    End If

-End Sub

-

-Sub DO_Delete_qtr(ent_date As String)

-    If ent_date <> "" Then

-        MsgBox "Удалить данные за период [" & ent_date & "] нельзя ", vbOKOnly, PROGRAM_NAME

-    End If

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-

-Sub btHomeDo_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    idx = Worksheets(VAR_SHEET).Range("USER_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            NoFunc

-            ' Обновляем экран

-        Case 2

-            DO_Edit_qtr ent_date

-        Case 3

-            DO_Price_qtr ent_date

-        Case 4

-            NoFunc

-    End Select

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-Sub Delete_qtr()

-'    Dim ent_date As String

-'    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-'    DO_Delete_qtr ent_date

-End Sub

-

-Sub btREP_QTR_RET_IT()

-    Dim s As String

-    With Worksheets("REP_QTR")

-        .Range("LAST_FOCUS") = ""

-        s = .Range("ret_addr")

-        .Range("ret_addr") = ""

-    End With

-    If s <> "" Then

-        ThisWorkbook.Worksheets(s).Select

-    Else

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane[RM]"

-Public Const PROGRAM_VERSION As String = "version 1.3"

-Public Const PROGRAM_FILENAME As String = "clexane-rm"

-Public Const PROGRAM_BACKUPNAME As String = "rm-backup-"

-Public Const PROGRAM_EXPORTNAME As String = "rm-ex-"

-Public Const PROGRAM_IMPORTNAME As String = "mr-ex-*"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20030329

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "O40"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-Public Const RM_QTR_SHEET As String = "RM_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-

-End Sub

-

-Function Double2Str(ByVal d As Double, ByVal precision As Integer, Optional Delim As String = ".") As String

-    Dim s As String

-    If Not precision > 0 Then

-        s = Round(d)

-    Else

-        Dim i As Integer

-        i = Fix(d)

-        s = i & Delim

-        d = Abs(d - i)

-        Do

-            precision = precision - 1

-            d = d * 10

-            If precision > 0 Then

-                i = Fix(d)

-            Else

-                i = Round(d)

-            End If

-            If i < 1 Then

-                s = s & "0"

-            Else

-                s = s & i

-                d = d - i

-            End If

-        Loop While precision > 0

-    End If

-    Double2Str = s

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetWBName(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBName = Right(FullName, s_len - pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.name = VAR_SHEET Or sh.name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-<<<<<<
-======================
-Var
->>>>>>
-Attribute VB_Name = "Var"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-title
->>>>>>
-Attribute VB_Name = "title"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LPU_LIST
->>>>>>
-Attribute VB_Name = "LPU_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentLPU_ID() As Long

-    Dim r As Range

-

-    With Worksheets("LPU_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CLPU_ID)

-    End With

-

-    getCurrentLPU_ID = r

-End Function

-

-Public Sub LPU_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectLPU_NAME(lpu_id As Long, ent_date As String)

-    If Range("VIEW_ONLY") = True Then

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    Dim cLPU As tLPU

-    If lpu_id = 0 Then

-        cLPU.id = 0

-        cLPU.rep_id = 0

-        cLPU.address = ""

-        cLPU.name = ""

-    Else

-        cLPU = Get_LPU_Record(lpu_id)

-    End If

-    EditLPU cLPU, getEnt_date

-    Worksheet_Activate

-End Sub

-

-Sub SelectLPU_BDGT(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    vo = Range("VIEW_ONLY")

-    If lpu_id = 0 Then

-        SelectLPU_NAME lpu_id, ent_date

-    Else

-        With ThisWorkbook.Worksheets("LPU_BDGT")

-            .Range("VIEW_ONLY") = vo

-            .Range("ret_addr") = "LPU_LIST"

-            .Range("REP_ID") = r_id

-            .Range("ent_date") = ent_date

-            .Range("lpu_id") = lpu_id

-        End With

-    End If

-End Sub

-

-Sub SelectLPU_HIR(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_HIR")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Sub SelectLPU_TER(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_TER")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Sub SelectLPU_C_ACS(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_C_ACS")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect UserInterfaceOnly:=True

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateLPUList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim lpu_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CINP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CINP_AREA).row, CLPU_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    lpu_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CINP_AREA).Column

-

-    If lpu_id = 0 Then

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    End If

-

-    If lpu_id = 0 Then

-        i = CLPU_NAME

-        Range("JUMP") = ""

-    End If

-    Select Case i

-        Case CLPU_NAME, CLPU_NAME1, CLPU_NAME2, CLPU_BEDS

-            SelectLPU_NAME lpu_id, ent_date

-            Range("JUMP") = ""

-

-        Case CLPU_NMG, CLPU_NFG, CLPU_PLAN, CLPU_FACT

-            SelectLPU_BDGT lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-

-        Case CLPU_HIR

-            SelectLPU_HIR lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_HIR"

-

-        Case CLPU_TER

-            SelectLPU_TER lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_TER"

-

-        Case CLPU_CAR

-            SelectLPU_C_ACS lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        Case Else

-            Range("JUMP") = ""

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateLPUList()

-    Dim lcd() As tLPU_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-    Dim objQTR As tQTR

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    ent_date = getEnt_date

-

-'     ent_date = "%" ' % - all records

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-    i = Get_LPU_CommonQTR(lcd, objQTR)

-

-'     стираем ФИО

-    Range("C3:C4").ClearContents

-

-    Range("C3") = cRep.LastName

-    Range("C4") = cRep.FirstName

-    Range("G3") = GetRegionName(cRep.Region)

-    Range("G4") = GetCityName(cRep.Region, cRep.City)

-    Range("G5") = objQTR.sale_PLAN

-

-

-

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(lcd)

-            r.Offset(i - 1, CLPU_NAME) = lcd(i).lpu.name

-            r.Offset(i - 1, CLPU_ID) = lcd(i).lpu.id

-            r.Offset(i - 1, CLPU_BEDS) = lcd(i).lpu.beds

-

-

-            r.Offset(i - 1, CLPU_NFG) = lcd(i).bdgt.bdgt_NFG

-            r.Offset(i - 1, CLPU_NMG) = lcd(i).bdgt.bdgt_NMG

-            r.Offset(i - 1, CLPU_PLAN) = lcd(i).bdgt.sale_PLAN

-

-            r.Offset(i - 1, CLPU_HIR) = lcd(i).pat_HIR

-            r.Offset(i - 1, CLPU_TER) = lcd(i).pat_TER

-            r.Offset(i - 1, CLPU_CAR) = lcd(i).pat_CRD

-            r.Offset(i - 1, CLPU_FACT) = lcd(i).sale_ALL

-            r.Offset(i - 1, CLPU_PAT_LPU) = lcd(i).pat_LPU

-            r.Offset(i - 1, CLPU_BDGT) = lcd(i).bdgt_LPU

-            If lcd(i).bdgt_LPU > 0 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = lcd(i).sale_ALL / lcd(i).bdgt_LPU

-            End If

-            If r.Offset(i - 1, CLPU_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{F2A5159C-AEB6-4066-B85F-339184DAFECD}{712D78F6-CCB6-499E-9674-B992A7482317}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-dbACS
->>>>>>
-Attribute VB_Name = "dbACS"

-Option Explicit

-

-Public Type tACS

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    patients_with_geparins As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objACS.ID <> 0 then updatre else insert

-Sub Insert_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objACS.id <> 0 Then

-        dbUpdate_ACS_Record dbConnection, objACS

-    Else

-        dbInsert_ACS_Record dbConnection, objACS

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_ACS_RecordsByLPU_ID(ByRef all_ACS_() As tACS, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_ACS_RecordsByLPU_ID = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, all_ACS_, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_ACS_Record dbConnection, objACS

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub dbInsert_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_acs", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objACS

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("patients_with_geparins") = .patients_with_geparins

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objACS.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim Update_SQL As String

-    

-    With objACS

-        Update_SQL = "UPDATE lpu_acs SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "patients_with_geparins=" & .patients_with_geparins & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_ACS_RecordsbyLPU_ID(dbConnection As Object, all_ACS() As tACS, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_ACS_SQL As String

-    Dim getAll_ACS_SQL As String

-    Dim ACS_Count As Long

-    ACS_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_ACS_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        ACS_Count = dbRecordset("ACS_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_ACS_RecordsbyLPU_ID = ACS_Count

-    

-    If ACS_Count > 0 Then

-        'we have records

-        ReDim all_ACS(1 To ACS_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_ACS_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_ACS As tACS

-                 With tmp_ACS

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .patients_with_geparins = dbRecordset("patients_with_geparins")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 all_ACS(index) = tmp_ACS

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE ID=" & objACS.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_ACS_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_HIR
->>>>>>
-Attribute VB_Name = "LPU_CLSN_HIR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-

-        Dim objHir As tHIRURGIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objHir

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .operations_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L9")

-                .patients_ambulator_clexan_20mg = Range("L10")

-                .patients_ambulator_clexan_40mg = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L19")

-                .patients_stationar_clexan_20mg = Range("L20")

-                .patients_stationar_clexan_40mg = Range("L21")

-            End With

-            Insert_Hir_Record objHir

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objHir.id = Range("rec_id")

-                    If objHir.id <> 0 Then

-                        Delete_Hir_Record objHir

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objHir As tHIRURGIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    With objHir

-        Range("rec_id") = .id

-        Range("F6") = .operations_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L9") = .patients_ambulator_clexan

-        Range("L10") = .patients_ambulator_clexan_20mg

-        Range("I21") = .patients_stationar_nmg

-        Range("L19") = .patients_stationar_clexan

-        Range("L20") = .patients_stationar_clexan_20mg

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id)

-

-        formula = "=" & qtr.ClxnH20mg & "*($L$10+$L$20)+" & qtr.ClxnH40mg & "*($L$11+$L$21)"

-        Range("F11").formula = formula

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objHir() As tHIRURGIA

-        Dim i As Integer

-        i = GetAll_Hir_RecordsByLPU_ID(objHir, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.3

-        Else

-            SetupData objHir(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-mSapes
->>>>>>
-Attribute VB_Name = "mSapes"

-Option Explicit

-

-Const SHAPE_COLOR As Integer = 1

-Const SHAPE_NAME As Integer = 2

-

-

-Sub ShapeView(r_sh_finite_state As Range)

-    Dim chk As Range

-    Dim s As String

-    Dim c, idx As Integer

-    For Each chk In r_sh_finite_state

-        idx = 0

-        If chk = "+" Then

-            c = chk.Offset(0, idx + SHAPE_COLOR)

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While c <> 0

-                ShapeFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s)), c

-                idx = idx + 2

-                c = chk.Offset(0, idx + SHAPE_COLOR)

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        Else

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While s <> ""

-                ShapeUnFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s))

-                idx = idx + 2

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        End If

-    Next chk

-End Sub

-

-Sub ShapeFill(sh As ShapeRange, ByVal color As Integer)

-    sh.Fill.Visible = msoTrue

-    sh.Fill.Solid

-    sh.Fill.ForeColor.SchemeColor = color

-    sh.Fill.Transparency = 0#

-End Sub

-

-Sub ShapeUnFill(sh As ShapeRange)

-    sh.Fill.Visible = msoFalse

-    sh.Fill.Transparency = 0#

-End Sub

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Public Const INPUT_NO = 0

-Public Const INPUT_NUMBER = 1

-Public Const INPUT_PERCENT = 2

-Public Const INPUT_STRING = 3

-Public Const INPUT_CHECK = 4

-

-Public Const INP_IDX_TYPE = 1

-Public Const INP_IDX_NEXT = 2

-Public Const INP_IDX_MIN = 3

-Public Const INP_IDX_MAX = 4

-Public Const INP_IDX_DEP = 5

-Public Const INP_IDX_ALT = 7

-

-

-Public Type tInputSet

-    vType As Integer

-    vMin As Long

-    vMax As Long

-    rChk As String

-End Type

-

-Function is_input_cell(ByVal Target As Range, inputs As Range) As tInputSet

-    Dim t As Range

-    Dim iset As tInputSet

-    Dim test As Range

-    iset.vType = INPUT_NO

-    iset.vMin = 0

-    iset.vMax = 0

-    iset.rChk = ""

-    is_input_cell = iset

-

-' Закоментировать следующую сточку для работы

-'  Exit Function

-

-    Set test = Target.Cells(1, 1)

-    For Each t In inputs

-        If Range(t).Column = test.Column And Range(t).row = test.row Then

-            iset.vType = t.Offset(0, INP_IDX_TYPE).Value

-            Select Case iset.vType

-                Case INPUT_CHECK

-                    iset.rChk = t.Offset(0, INP_IDX_ALT)

-                Case INPUT_NUMBER, INPUT_PERCENT

-                    iset.vMin = t.Offset(0, INP_IDX_MIN).Value

-                    iset.vMax = t.Offset(0, INP_IDX_MAX).Value

-            End Select

-            is_input_cell = iset

-            Exit Function

-        End If

-    Next t

-End Function

-

-Function GetFocusAddress(ByVal r As Range, f_next As Range) As String

-    Dim chk, t As Range

-    

-    For Each chk In f_next

-        For Each t In r

-            If t.address = chk Then

-                GetFocusAddress = chk

-                Exit Function

-            End If

-            If Range(chk).Column = t.Column - 1 And Range(chk).row = t.row _

-            Or Range(chk).Column = t.Column And Range(chk).row = t.row - 1 _

-            Then

-                If Range(chk) <> "" Then

-                    If Range(chk) = 0 Then

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_ALT)).address

-                    Else

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_NEXT)).address

-                    End If

-                Else

-                    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-                End If

-                Exit Function

-            End If

-        Next t

-    Next chk

-    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-End Function

-

-Sub SetDependet(r As Range, inputs As Range)

-    Dim chk As Range

-    Dim s, serr As String

-    Dim idx As Integer

-    Dim iset As tInputSet

-    Dim err_found As Boolean

-    

-    If r.count > 1 Then

-        Exit Sub

-    End If

-    

-    err_found = False

-    For Each chk In inputs

-        idx = INP_IDX_DEP

-        

-        

-        iset.vType = chk.Offset(0, INP_IDX_TYPE).Value

-        Select Case iset.vType

-            Case INPUT_NUMBER, INPUT_PERCENT

-                iset.vMin = chk.Offset(0, INP_IDX_MIN).Value

-                iset.vMax = chk.Offset(0, INP_IDX_MAX).Value

-                

-                If Range(chk) > iset.vMax Then

-                    err_found = True

-                    Range(chk) = iset.vMax

-                    serr = "Выход за дозволенный диапазон [" & iset.vMin & ".." & iset.vMax & "]! Данные скорректированы."

-                End If

-                

-                If Range(chk) = "" Then

-                    s = chk.Offset(0, idx)

-                    Do While s <> ""

-                        Range(s) = ""

-                        idx = idx + 1

-                        s = chk.Offset(0, idx)

-                    Loop

-                End If

-        End Select

-    Next chk

-    If err_found Then

-        MsgBox serr, vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Function CheckInputData(inputs As Range) As Boolean

-    Dim r As Range

-    

-    CheckInputData = True

-    For Each r In inputs

-        If Range(r) = "" Then

-            CheckInputData = False

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100.", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Sub Check_Int_Number(Target As Range, Def_Val As Long)

-    Dim err As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    err = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                err = True

-            End If

-        End If

-    Next r

-    If err Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_TER
->>>>>>
-Attribute VB_Name = "LPU_CLSN_TER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim objTer As tTERAPIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objTer

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .patients_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L20")

-            End With

-            Insert_Ter_Record objTer

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objTer.id = Range("rec_id")

-                    If objTer.id <> 0 Then

-                        Delete_Ter_Record objTer

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objTer As tTERAPIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    With objTer

-        Range("rec_id") = .id

-        Range("F6") = .patients_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L11") = .patients_ambulator_clexan

-        Range("I21") = .patients_stationar_nmg

-        Range("L20") = .patients_stationar_clexan

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id)

-        formula = "=" & qtr.ClxnT40mg & "*($L$12+$L$20)"

-        Range("F11").formula = formula

-

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objTer() As tTERAPIA

-        Dim i As Integer

-        i = GetAll_Ter_RecordsByLPU_ID(objTer, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.25

-        Else

-            SetupData objTer(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{5D2CB2D2-3E5E-4B6E-9E0C-2EEBA5E10E17}{C891C133-B6B4-43D3-B411-B4A821905C23}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-LPU_BDGT
->>>>>>
-Attribute VB_Name = "LPU_BDGT"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub SetDefFocus()

-    Range(Range("DEF_FOCUS")).Select

-End Sub

-

-Public Sub ClearData()

-    ClearSheetData

-End Sub

-

-Sub ClearSheetData()

-    If Range("F10") = 0 And Range("F13") = 0 Then

-        Range("F11:F18") = ""

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("F11:F13") = ""

-    End If

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim bdgt As tBUDGET

-        Dim test As Boolean

-        Dim sum As Long

-        With bdgt

-            .lpu_id = Range("lpu_id")

-            .id = Range("rec_id")

-            .entry_date = Range("ent_date")

-            .bdgt_NMG = Round(Range("F11").Value, 0)

-            .bdgt_NFG = Round(Range("F12").Value, 0)

-            .sale_PLAN = Round(Range("F13").Value, 0)

-

-            sum = .bdgt_NFG + .bdgt_NMG - .sale_PLAN

-            test = .bdgt_NFG <> 0 Or .bdgt_NMG <> 0 Or .sale_PLAN <> 0

-        End With

-        If test Then

-            If sum < 0 Then

-                MsgBox _

-                    "Ваш план превышает выделенный на гепарины бюджет. Сохранить данные?", _

-                    vbOKOnly, PROGRAM_NAME

-            End If

-            If test Then

-                Insert_BDGT_Record bdgt

-            End If

-        Else

-            If bdgt.id <> 0 Then

-                If vbYes = MsgBox("Удалить данные из базы!", vbYesNo, PROGRAM_NAME) Then

-                    Delete_BDGT_Record bdgt

-                End If

-                ret_back Range("DEF_FOCUS").Worksheet

-                Exit Sub

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-    End If

-

-   ClearData

-   ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(cLPU As tLPU_COMMON)

-    Dim t_sum As Long

-    t_sum = 0

-' Setup budget data

-    Range("F11") = cLPU.bdgt.bdgt_NMG

-    Range("F12") = cLPU.bdgt.bdgt_NFG

-    Range("F13") = cLPU.bdgt.sale_PLAN

-

-    With cLPU

-        Range("F14") = .pat_ALL

-        Range("F15") = .pat_HIR

-        Range("F16") = .pat_TER

-        Range("F17") = .pat_CRD

-        Range("F18") = .sale_ALL

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-    ws_activate

-End Sub

-

-

-Sub ws_activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Dim cLPU As tLPU_COMMON

-    Dim objQTR As tQTR

-    Dim objLPU As tLPU

-    Dim ent_date As String

-    Dim id As Long

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    id = Range("lpu_id").Value

-    ent_date = Range("ent_date")

-    

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-

-    objLPU = Get_LPU_Record(id)

-    Get_LPU_Common cLPU, objLPU, objQTR

-

-    If cLPU.lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = cLPU.lpu.beds

-        Range("lpu_name") = cLPU.lpu.name

-        Range("lpu_addr") = cLPU.lpu.address

-        Range("rec_id") = cLPU.bdgt.id

-

-        SetupData cLPU

-

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-'    MsgBox Target.address

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case INPUT_CHECK

-

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{BB60E38F-A4AB-4AB4-91D0-40AA798D9F5C}{BE9A54D9-F093-4755-9E17-0B47BB5E2546}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mSheets
->>>>>>
-Attribute VB_Name = "mSheets"

-Option Explicit

-

-Function am_load_now() As Boolean

-    am_load_now = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE")

-End Function

-

-Sub Wks_select(RetSheet As String)

-    Dim sheet As Worksheet

-    For Each sheet In ThisWorkbook.Worksheets

-        If sheet.name = RetSheet Then

-            ThisWorkbook.Worksheets(RetSheet).Select

-            Exit Sub

-        End If

-    Next sheet

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub ret_back(sh As Worksheet)

-    Dim RetSheet As String

-    RetSheet = sh.Range("ret_addr")

-    sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    sh.Range("ret_addr") = ""

-    sh.Range("rec_id") = ""

-    sh.Range("lpu_id") = ""

-    sh.Range("ent_date") = ""

-    sh.Range("lpu_name") = ""

-    sh.Range("lpu_addr") = ""

-    sh.Range("lpu_beds") = ""

-    Wks_select RetSheet

-End Sub

-

-Sub ClearSheetData(r_start As Range)

-    If r_start <> "" Then

-        r_start.Worksheet.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        r_start = ""

-    Else

-        ret_back r_start.Worksheet

-    End If

-End Sub

-

-Sub wks_sel_chng(iset As tInputSet, ByVal Target As Range, sh As Worksheet)

-    Dim DebugMode As Boolean

-    Dim in_range As Range

-    

-    DebugMode = Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-

-    If DebugMode Then

-        sh.Unprotect

-    Else

-        sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    End If

-

-    If iset.vType = INPUT_CHECK Then

-        Set in_range = Target.Worksheet.Range(iset.rChk)

-    Else

-        Set in_range = Target

-    End If

-    

-    Dim str As String

-    str = GetFocusAddress(in_range, sh.Range("h_inputs"))

-

-'    MsgBox Target.Address & "; " & str

-    If str <> Target.address Then

-        sh.Range(str).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-Dlg_lpu_card
->>>>>>
-Attribute VB_Name = "Dlg_lpu_card"

-Attribute VB_Base = "0{2C69E842-8DA9-4240-A0A8-F6B0141DC246}{75AAB28C-ADCF-4D1B-9D5A-AF89E80A810C}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbLPU_List_Change()

-    Dim src As Range

-    Dim idx_src As Integer

-    

-    Set src = Worksheets(VAR_SHEET).Range(Me.cbLPU_List.RowSource)

-    idx_src = Me.cbLPU_List.ListIndex + 1

-    Me.tb_lpu_name.Text = src.Cells(idx_src, 1)

-    Me.tb_lpu_address.Text = src.Cells(idx_src, 2)

-    Me.tbBedsCount.Text = src.Cells(idx_src, 3)

-End Sub

-

-

-Private Sub cbxLPU_List_Enable_Click()

-    

-    If Me.cbxLPU_List_Enable Then

-        

-        Me.tb_lpu_name.Text = ""

-        Me.tb_lpu_name.Enabled = False

-        

-        Me.tb_lpu_address.Text = ""

-        Me.tb_lpu_address.Enabled = False

-        

-        Me.tbBedsCount.Text = ""

-        Me.tbBedsCount.Enabled = False

-        

-        Me.cbLPU_List.Enabled = True

-        cbLPU_List_Change

-    Else

-        Me.tb_lpu_name.Enabled = True

-        Me.tb_lpu_name.Text = ""

-        

-        Me.tb_lpu_address.Enabled = True

-        Me.tb_lpu_address.Text = ""

-        

-        Me.tbBedsCount.Enabled = True

-        Me.tbBedsCount.Text = ""

-        

-        Me.cbLPU_List.Enabled = False

-    End If

-End Sub

-

-<<<<<<
-======================
-UserInfo
->>>>>>
-Attribute VB_Name = "UserInfo"

-Attribute VB_Base = "0{BA873669-5C2D-400A-8A8B-572ACD8CCE4C}{D11400A0-9912-4240-A78C-44C33731216A}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Tag = vbOK

-End Sub

-

-Private Sub cbCity_Change()

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_CITY") = Me.cbCity.ListIndex

-        .Calculate

-    End With

-End Sub

-

-Private Sub cbRegion_Change()

-    Dim LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        NewRangeOffsetCol = cbRegion.Value * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).address

-        NewSumRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).address

-        .Calculate

-        .Range("IDX_CITY") = 0

-        cbCity.RowSource = NewCbxRange

-

-    End With

-    cbCity.ListIndex = 0

-End Sub

-

-<<<<<<
-======================
-mREGMAN
->>>>>>
-Attribute VB_Name = "mREGMAN"

-Option Explicit

-

-Sub hwnew()

-    Dim rs As Range

-    Dim re As Object

-    

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    HWReset

-    ReSet_REGMAN_Record

-    With Worksheets("RM_QTR")

-        .ClearRMName

-        .Range("REP_QTR_INPUT_DATA").ClearContents ' Это не ошибка, названия совпадают

-'        .Range("A1").Select

-    End With

-    Worksheets(TITLE_SHEET).Select

-    With Application

-        .DisplayAlerts = False

-        .ThisWorkbook.Save

-        .Quit

-    End With

-End Sub

-

-Function CheckUser() As Boolean

-    Dim objHW() As Long

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    

-    GetHWInfo objHW()

-    i = GetHWRecords(objHW_DB)

-    

-    If i = 0 Then ' First time

-        StoreHWInfo objHW()

-    End If

-    If CheckHWInfo(objHW()) <> True Then

-        CheckUser = False

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    Else

-        CheckUser = SetupUser

-    End If

-End Function

-

-Function SetupUser() As Boolean

-    Dim cREGMAN As tREGMAN

-    Dim idx As Integer

-    Dim dlg_ui As UserInfo

-    

-    Set dlg_ui = New UserInfo

-    

-    cREGMAN = Get_REGMAN_Record()

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_REGION") = cREGMAN.Region

-        .Range("IDX_CITY") = cREGMAN.City

-    End With

-        

-    With dlg_ui

-        .cbRegion = cREGMAN.Region

-        .cbCity = cREGMAN.City

-        .tbFName = cREGMAN.FirstName

-        .tbLName = cREGMAN.LastName

-    End With

-    

-    Worksheets(REGS_SHEET).Calculate

-    

-    Dim test_Ok As Boolean

-    test_Ok = False

-    

-    On Error GoTo l1

-    

-    Do

-        dlg_ui.Show

-        If dlg_ui.Tag = vbOK Then

-            test_Ok = dlg_ui.tbFName.Value <> "" And dlg_ui.tbLName <> ""

-            If test_Ok Then

-                Exit Do

-            Else

-                MsgBox "Введите имя и фамилию", vbOKOnly, PROGRAM_NAME

-            End If

-        Else

-            Exit Do

-        End If

-    Loop Until False

-l1:

-    If test_Ok Then

-        With cREGMAN

-            .Region = dlg_ui.cbRegion.Value

-            .City = dlg_ui.cbCity.Value

-            .FirstName = dlg_ui.tbFName.Value

-            .LastName = dlg_ui.tbLName.Value

-        End With

-        Set_REGMAN_Record cREGMAN

-    Else

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .ThisWorkbook.Saved = True

-            .Quit

-        End With

-    End If

-    SetupUser = test_Ok

-End Function

-

-Sub GetHWInfo(objHW() As Long)

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    i = 1

-    For Each d In dc

-        If d.drivetype = 2 Then ' 2 - HardDisk

-            ReDim Preserve objHW(i)

-            objHW(i) = d.SerialNumber

-            i = i + 1

-        End If

-    Next

-    SortHW objHW

-End Sub

-

-Sub StoreHWInfo(objHW() As Long)

-    UpdateHWRecords objHW

-End Sub

-

-Sub SortHW(objHW() As Long)

-    Dim r As Range

-    Dim rs As Range

-    Dim re As Object

-    Dim i As Integer

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    For i = 1 To UBound(objHW)

-        r = objHW(i)

-        Set r = r.Offset(1, 0)

-    Next i

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).Sort _

-            Key1:=.Range("HW_Number"), _

-            Order1:=xlDescending, _

-            Header:=xlGuess, _

-            OrderCustom:=1, _

-            MatchCase:=False, _

-            Orientation:=xlTopToBottom

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    i = 1

-    Do While r <> ""

-        objHW(i) = r

-        Set r = r.Offset(1, 0)

-        i = i + 1

-    Loop

-End Sub

-

-Function CheckHWInfo(objHW() As Long)

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    CheckHWInfo = False

-        

-    i = GetHWRecords(objHW_DB)

-    If i > 0 Then

-        SortHW objHW_DB

-    End If

-    If UBound(objHW) = UBound(objHW_DB) Then

-        For i = 1 To UBound(objHW)

-            If objHW(i) <> objHW_DB(i) Then

-                Exit Function

-            End If

-        Next i

-        CheckHWInfo = True

-    End If

-End Function

-

-

-<<<<<<
-======================
-dbBudget
->>>>>>
-Attribute VB_Name = "dbBudget"

-Option Explicit

-

-Public Type tBUDGET

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    bdgt_NMG As Long

-    bdgt_NFG As Long

-    sale_PLAN As Long

-End Type

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function GetAll_BDGT_RecordsByLPU_ID(ByRef allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_BDGT_RecordsByLPU_ID = dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection, allBDGT, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function Get_BDGT_Record(ByVal lpu_id As Long, ByVal ent_date As String) As tBUDGET

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    Get_BDGT_Record = dbGet_BDGT_Record(dbConnection, lpu_id, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objBDGT.ID <> 0 then updatre else insert

-Public Sub Insert_BDGT_Record(objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    If objBDGT.id <> 0 Then

-        dbUpdate_BDGT_Record dbConnection, objBDGT

-    Else

-        dbInsert_BDGT_Record dbConnection, objBDGT

-    End If

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Public Sub Delete_BDGT_Record(ByRef objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    dbDelete_BDGT_Record dbConnection, objBDGT

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_BDGT_Record(dbConnection As Object, ByVal lpu_id As Long, ent_date As String) As tBUDGET

-    

-    Dim sql As String

-    Dim objBDGT As tBUDGET

-    

-    With objBDGT

-        .id = 0

-        .lpu_id = lpu_id

-        .entry_date = ent_date

-        .bdgt_NMG = 0

-        .bdgt_NFG = 0

-        .sale_PLAN = 0

-    End With

-        

-    

-    sql = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        With objBDGT

-            .entry_date = dbRecordset("entry_date")

-            .id = dbRecordset("id")

-            .lpu_id = dbRecordset("lpu_id")

-            .bdgt_NFG = dbRecordset("bdgt_NFG")

-            .bdgt_NMG = dbRecordset("bdgt_NMG")

-            .sale_PLAN = dbRecordset("sale_PLAN")

-        End With

-    End If

-    

-    dbGet_BDGT_Record = objBDGT

-End Function

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection As Object, allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_BDGT_SQL As String

-    Dim getAll_BDGT_SQL As String

-    Dim BDGT_Count As Long

-    BDGT_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_BDGT_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        BDGT_Count = dbRecordset("BDGT_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_BDGT_RecordsbyLPU_ID = BDGT_Count

-    

-    If BDGT_Count > 0 Then

-        'we have records

-        ReDim allBDGT(1 To BDGT_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_BDGT_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpBDGT As tBUDGET

-                 With tmpBDGT

-                    .entry_date = dbRecordset("entry_date")

-                    .id = dbRecordset("id")

-                    .lpu_id = dbRecordset("lpu_id")

-                    .bdgt_NFG = dbRecordset("bdgt_NFG")

-                    .bdgt_NMG = dbRecordset("bdgt_NMG")

-                    .sale_PLAN = dbRecordset("sale_PLAN")

-                 End With

-                 

-                 allBDGT(index) = tmpBDGT

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbInsert_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "lpu_budget", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    dbRecordset("entry_date") = objBDGT.entry_date

-    dbRecordset("lpu_id") = objBDGT.lpu_id

-    dbRecordset("bdgt_NMG") = objBDGT.bdgt_NMG

-    dbRecordset("bdgt_NFG") = objBDGT.bdgt_NFG

-    dbRecordset("sale_PLAN") = objBDGT.sale_PLAN

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objBDGT.id = dbRecordset("id")

-  

-End Sub

-

-Public Sub dbUpdate_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu_budget SET " & _

-    "entry_date='" & objBDGT.entry_date & "'," & _

-    "lpu_id=" & objBDGT.lpu_id & "," & _

-    "bdgt_NMG=" & objBDGT.bdgt_NMG & "," & _

-    "bdgt_NFG=" & objBDGT.bdgt_NFG & "," & _

-    "sale_PLAN=" & objBDGT.sale_PLAN & _

-    " WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-Public Sub dbDelete_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_BDGT_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbDatabase
->>>>>>
-Attribute VB_Name = "dbDatabase"

-Option Explicit

-

-

-Sub dbOpenConnection(dbConnection As Object)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-<<<<<<
-======================
-dbLPU
->>>>>>
-Attribute VB_Name = "dbLPU"

-Option Explicit

-

-Public Type tLPU

-    id As Long

-    rep_id As Long

-    name As String

-    address As String

-    beds As Integer

-End Type

-

-Function Get_LPU_Record(ByVal lpu_id As Long) As tLPU

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_LPU_Record = dbGet_LPU_Record(dbConnection, lpu_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_LPU_byQTR(allLPU() As tLPU, ent_date As String, rep_id As Long) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_LPU_byQTR = dbGetAll_LPU_byQTR(dbConnection, allLPU, ent_date, rep_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_Record(dbConnection As Object, ByVal lpu_id As Long) As tLPU

-    

-    Dim sql As String

-    Dim objLPU As tLPU

-    

-    objLPU.id = lpu_id

-    objLPU.name = ""

-    objLPU.address = ""

-    

-    sql = "SELECT * FROM lpu WHERE id=" & lpu_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objLPU.name = dbRecordset("name")

-        objLPU.address = dbRecordset("address")

-        objLPU.rep_id = dbRecordset("rep_id")

-        objLPU.beds = dbRecordset("beds")

-    End If

-    

-    dbGet_LPU_Record = objLPU

-

-End Function

-

-Function dbGetAll_LPU_byQTR(dbConnection As Object, allLPU() As tLPU, ent_date As String, rep_id As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    Dim Where As String

-    Where = "WHERE lpu_budget.entry_date like '" & ent_date & "'" & " AND lpu.id=lpu_budget.lpu_id AND lpu.rep_id=" & rep_id

-

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu_budget, lpu " & Where

-    

-    getAll_LPU_SQL = "SELECT lpu.id as id, lpu.rep_id as rep_id, lpu.name as name, lpu.address as address, lpu.beds AS beds " & _

-    "FROM lpu, lpu_budget " & Where

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_LPU_byQTR = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-dbREP
->>>>>>
-Attribute VB_Name = "dbREP"

-'Option Explicit

-'

-'Public Type tREP

-'    FirstName As String

-'    LastName As String

-'    Region As Integer

-'    City As Integer

-'End Type

-'

-'Function GetREPRecord() As tREP

-'    Dim dbConnection As Object

-'

-'    dbOpenConnection dbConnection

-'    GetREPRecord = dbGetREPRecord(dbConnection)

-'    dbCloseConnection dbConnection

-'End Function

-'

-'Sub SetREPRecord(cUser As tREP)

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbSetREPRecord dbConnection, cUser

-'    dbCloseConnection dbConnection

-'End Sub

-'

-'Sub ReSetREPRecord()

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbReSetREPRecord dbConnection

-'    dbCloseConnection dbConnection

-'End Sub

-'

-'Public Function dbGetREPRecord(dbConnection As Object) As tREP

-'

-'    Dim SQL As String

-'    Dim objREP As tREP

-'

-'    objREP.FirstName = ""

-'    objREP.LastName = ""

-'    objREP.Region = 0

-'    objREP.City = 0

-'    SQL = "SELECT firstname, lastname, region, city FROM " & _

-'          "rep"

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open SQL, dbConnection

-'    ', 3, 3

-'    If Not dbRecordset.BOF Then

-'

-'        objREP.FirstName = dbRecordset("firstname")

-'        objREP.LastName = dbRecordset("lastname")

-'        objREP.Region = dbRecordset("region")

-'        objREP.City = dbRecordset("city")

-'

-'    End If

-'

-'    dbGetREPRecord = objREP

-'

-'End Function

-'

-'Public Sub dbSetREPRecord(dbConnection As Object, ByRef objREP As tREP)

-'

-'    Dim DeleteSQL As String

-'    Dim InsertSQL As String

-'

-'    DeleteSQL = "DELETE FROM rep"

-'    InsertSQL = "INSERT INTO rep (firstname, lastname, region, city) VALUES (" & _

-'    "'" & objREP.FirstName & "', " & _

-'    "'" & objREP.LastName & "', " & _

-'    objREP.Region & ", " & _

-'    objREP.City & ")"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-'

-'End Sub

-'

-'Public Sub dbReSetREPRecord(dbConnection As Object)

-'

-'    Dim DeleteSQL As String

-'

-'    DeleteSQL = "DELETE FROM rep"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-'

-'End Sub

-'

-

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    CheckWorkBooksArround Wb

-End Sub

-

-

-Sub CheckWorkBooksArround(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If app.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKOnly, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-        Exit Sub

-    End If

-

-End Sub

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub SaveExcelState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-        ActiveWorkbook.DisplayDrawingObjects = xlDisplayShapes

-        

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars(STDBAR_NAME).Visible = False

-End Sub

-

-

-Public Sub RestoreExcelState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars(STDBAR_NAME).Visible = True

-End Sub

-

-

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Public Const STDBAR_NAME = "Worksheet Menu Bar"

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Import"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmImport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Export"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 620

-                        .OnAction = "cmExport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Exit && Restore Excel"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 548

-                        .OnAction = "cmExitRestore"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-       End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(flag As Boolean)

-    If flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars(STDBAR_NAME)

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmImport()

-    Worksheets(RM_QTR_SHEET).Select

-    ImportData

-End Sub

-

-Sub cmExport()

-    dbExport

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    Dim dlg As dlgAbout

-    Set dlg = New dlgAbout

-    

-    dlg.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlg.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlg.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlg.Show

-End Sub

-

-Sub cmMail2Support()

-    Dim err_description As String

-    Dim dlg_msg As dlg_Mail

-    Set dlg_msg = New dlg_Mail

-    With dlg_msg

-        .Show

-        If .Tag = vbOK Then

-            ThisWorkbook.Worksheets(VAR_SHEET).Range("ERR_MESSAGE") _

-                = .tbMessage.Text

-            ThisWorkbook.Save

-            ThisWorkbook.SendMail Recipients:="infra@i-rs.ru", Subject:=PROGRAM_NAME & " ver.:" & PROGRAM_VERSION

-            MsgBox "Сообщение об ошибке отправлено. Перезагрузите программу.", vbOKOnly, PROGRAM_NAME

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-    End With

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-'        helppath = "hh.exe " & .Path & "\Telfast.chm"

-'        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub set_work_mode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetupEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-End Sub

-

-Sub cmSetStandaloneMode()

-    set_work_mode

-    ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    Dim dlg As dlgGetPwd

-    rp = common_pwd

-    

-    Set dlg = New dlgGetPwd

-    dlg.edPwd = ""

-    dlg.Show

-    

-    If dlg.edPwd = rp Then

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmHomePage()

-    ThisWorkbook.Worksheets("RM_QTR").Select

-End Sub

-

-Sub cmExitRestore()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = True

-    Application.Quit

-End Sub

-

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    Dim dlg_prn As dlgPrint

-    

-    Set dlg_prn = New dlgPrint

-    

-    With dlg_prn

-        .cbMainReport = True

-        .cbMainBudget = False

-        .cbSrcData = False

-        .cbAllSheets = False

-    

-        .Show

-    

-        If .Tag = vbCancel Then

-            Exit Sub

-        End If

-    End With

-    

-    Dim PrnIdx As Integer

-    

-    With dlg_prn

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("REP_QTR", "budget", "Final")

-    Case 1111

-        plist = Array("REP_QTR", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("REP_QTR")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Clexane bar"

-Public Const common_pwd As String = "crdjhxtyjr"

-

-

-Sub SetupEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    Wb.Worksheets(TITLE_SHEET).Select

-    With Application

-        .Caption = PROGRAM_NAME & " " & PROGRAM_VERSION

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .SaveExcelState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = False

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Wb.Worksheets(TITLE_SHEET).Select

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    If cWindow.Type = xlWorkbook Then

-                        cWindow.DisplayHeadings = True

-                    End If

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu True

-        End If

-        With mobjAppState

-            .RestoreExcelState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Worksheets(TITLE_SHEET).Select

-'        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Option Explicit

-

-Sub UpdateHWRecords(objHW() As Long)

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    dbUpdateHWRecords dbConnection, objHW

-    dbCloseConnection dbConnection

-End Sub

-

-Function GetHWRecords(objHW() As Long) As Integer

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    GetHWRecords = dbGetHWRecords(dbConnection, objHW)

-    dbCloseConnection dbConnection

-End Function

-

-Sub HWReset()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbInsertHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    

-    Dim dbRecordset As Object

-    Dim i As Long

-    

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "hw", dbConnection, 2, 2

-    

-    For i = 1 To UBound(objHW)

-        dbRecordset.addnew

-        dbRecordset("num") = objHW(i)

-        dbRecordset.Update

-    Next i

-    

-End Sub

-

-Sub dbUpdateHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    dbDeleteHWRecord dbConnection

-    dbInsertHWRecords dbConnection, objHW

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-dbHir
->>>>>>
-Attribute VB_Name = "dbHir"

-Option Explicit

-

-Public Type tHIRURGIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    operations_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_ambulator_clexan_40mg As Integer

-    patients_ambulator_clexan_20mg As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-    patients_stationar_clexan_40mg As Integer

-    patients_stationar_clexan_20mg As Integer

-End Type

-

-' if objHir.ID <> 0 then updatre else insert

-Sub Insert_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objHir.id <> 0 Then

-        dbUpdate_Hir_Record dbConnection, objHir

-    Else

-        dbInsert_Hir_Record dbConnection, objHir

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Hir_RecordsByLPU_ID(ByRef allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Hir_RecordsByLPU_ID = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, allHir, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Hir_Record dbConnection, objHir

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objHir.ID <> 0 then updatre else insert

-

-Sub dbInsert_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_hir", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objHir

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("operations_per_quarter") = .operations_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_ambulator_clexan_20mg") = .patients_ambulator_clexan_20mg

-        dbRecordset("patients_ambulator_clexan_40mg") = .patients_ambulator_clexan_40mg

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-        dbRecordset("patients_stationar_clexan_20mg") = .patients_stationar_clexan_20mg

-        dbRecordset("patients_stationar_clexan_40mg") = .patients_stationar_clexan_40mg

-        

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objHir.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim UpdateSQL As String

-    

-    With objHir

-        UpdateSQL = "UPDATE lpu_hir SET " & _

-            "entry_date='" & objHir.entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "operations_per_quarter=" & .operations_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_ambulator_clexan_20mg=" & .patients_ambulator_clexan_20mg & "," & _

-            "patients_ambulator_clexan_40mg=" & .patients_ambulator_clexan_40mg & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & "," & _

-            "patients_stationar_clexan_20mg=" & .patients_stationar_clexan_20mg & "," & _

-            "patients_stationar_clexan_40mg=" & .patients_stationar_clexan_40mg & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_Hir_RecordsbyLPU_ID(dbConnection As Object, allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Hir_SQL As String

-    Dim getAll_Hir_SQL As String

-    Dim Hir_Count As Long

-    Hir_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Hir_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Hir_Count = dbRecordset("HIR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Hir_RecordsbyLPU_ID = Hir_Count

-    

-    If Hir_Count > 0 Then

-        'we have records

-        ReDim allHir(1 To Hir_Count)

-        Dim index As Integer

-        index = 1

-        dbRecordset.Open getAll_Hir_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpHir As tHIRURGIA

-                 With tmpHir

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .operations_per_quarter = dbRecordset("operations_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_ambulator_clexan_20mg = dbRecordset("patients_ambulator_clexan_20mg")

-                    .patients_ambulator_clexan_40mg = dbRecordset("patients_ambulator_clexan_40mg")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                    .patients_stationar_clexan_20mg = dbRecordset("patients_stationar_clexan_20mg")

-                    .patients_stationar_clexan_40mg = dbRecordset("patients_stationar_clexan_40mg")

-                 End With

-                 

-                 allHir(index) = tmpHir

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE ID=" & objHir.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Hir_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbTer
->>>>>>
-Attribute VB_Name = "dbTer"

-Option Explicit

-

-Public Type tTERAPIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objTer.ID <> 0 then updatre else insert

-Sub Insert_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objTer.id <> 0 Then

-        dbUpdate_Ter_Record dbConnection, objTer

-    Else

-        dbInsert_Ter_Record dbConnection, objTer

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Ter_RecordsByLPU_ID(ByRef allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Ter_RecordsByLPU_ID = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, allTer, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Ter_Record dbConnection, objTer

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objTer.ID <> 0 then updatre else insert

-

-Sub dbInsert_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_ter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objTer

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objTer.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim Update_SQL As String

-    

-    With objTer

-        Update_SQL = "UPDATE lpu_ter SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_Ter_RecordsbyLPU_ID(dbConnection As Object, allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Ter_SQL As String

-    Dim getAll_Ter_SQL As String

-    Dim Ter_Count As Long

-    Ter_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Ter_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Ter_Count = dbRecordset("TER_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Ter_RecordsbyLPU_ID = Ter_Count

-    

-    If Ter_Count > 0 Then

-        'we have records

-        ReDim allTer(1 To Ter_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_Ter_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpTer As tTERAPIA

-                 With tmpTer

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 allTer(index) = tmpTer

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE ID=" & objTer.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Ter_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-mLPU_LIST
->>>>>>
-Attribute VB_Name = "mLPU_LIST"

-Option Explicit

-

-Public Const CINP_AREA As String = "B12"

-Public Const CLPU_NAME As Integer = 0

-Public Const CLPU_NAME1 As Integer = 1

-Public Const CLPU_NAME2 As Integer = 2

-Public Const CLPU_ID As Integer = 3

-Public Const CLPU_BEDS As Integer = 4

-Public Const CLPU_NFG As Integer = 5

-Public Const CLPU_NMG As Integer = 6

-Public Const CLPU_HIR As Integer = 7

-Public Const CLPU_TER As Integer = 8

-Public Const CLPU_CAR As Integer = 9

-Public Const CLPU_FACT As Integer = 10

-Public Const CLPU_PLAN As Integer = 11

-Public Const CLPU_PAT_LPU As Integer = 16

-Public Const CLPU_BDGT As Integer = 17

-Public Const CLPU_PAT_ALL As Integer = 16

-

-

-

-Sub EditLPU(cLPU As tLPU, ent_date As String)

-    NoFunc

-End Sub

-

-Sub Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-

-End Sub

-

-Sub Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btLPU_DEL_IT()

-    Dim cLPU As tLPU

-    Dim ent_date As String

-    Dim delete_all As Integer

-    Dim dlg_del As dlg_LPU_delete

-

-    With Worksheets("LPU_LIST")

-        ent_date = .Range("ent_date")

-        cLPU.id = .getCurrentLPU_ID()

-    End With

-

-    If cLPU.id = 0 Then

-        MsgBox "Укажите удаляемый объект", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    cLPU = Get_LPU_Record(cLPU.id)

-

-    Set dlg_del = New dlg_LPU_delete

-    With dlg_del

-        .chbDeleteQTR.Value = True

-        .chbDeleteAll.Value = False

-        .lComment = ent_date & ": Удаление ЛПУ '" _

-        & cLPU.name & "', расположенного по адресу:" _

-        & cLPU.address & " не разрешено."

-        .Show

-    End With

-End Sub

-

-Sub btLPU_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        

-        Wks_select .Range("ret_addr")

-    End With

-

-End Sub

-

-

-Sub btLPU_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim lpu_id As Long

-

-    i = Worksheets(VAR_SHEET).Range("QTR_ACTION").Value

-    With Worksheets("LPU_LIST")

-        ent_date = .getEnt_date()

-

-

-        lpu_id = .getCurrentLPU_ID

-        If lpu_id = 0 And i <> 6 Then

-            i = 1

-        End If

-        Select Case i

-            Case 1

-                .SelectLPU_NAME lpu_id, ent_date

-                .Range("JUMP") = ""

-            Case 2

-                .SelectLPU_BDGT lpu_id, ent_date

-                .Range("JUMP") = "LPU_BDGT"

-            Case 3

-                .SelectLPU_HIR lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_HIR"

-

-            Case 4

-                .SelectLPU_TER lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_TER"

-

-            Case 5

-                .SelectLPU_C_ACS lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        End Select

-    End With

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-dbQTR
->>>>>>
-Attribute VB_Name = "dbQTR"

-Option Explicit

-

-Public Type tQTR

-    id As Long

-    entry_date As String

-    rep_id As Long

-    sale_PLAN As Long

-    ClxnH20mg As Long

-    ClxnH40mg As Long

-    ClxnT40mg As Long

-    ClxnC_IM As Long

-    ClxnC_ACS As Long

-End Type

-

-Function Get_QTR_Record(ByVal QTR_ID As Long) As tQTR

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_QTR_Record = dbGet_QTR_Record(dbConnection, QTR_ID)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_Record(dbConnection As Object, ByVal QTR_ID As Long) As tQTR

-    

-    Dim sql As String

-    Dim objQTR As tQTR

-    

-    With objQTR

-        .ClxnC_ACS = 0

-        .ClxnC_IM = 0

-        .ClxnH20mg = 0

-        .ClxnH40mg = 0

-        .ClxnT40mg = 0

-        .entry_date = ""

-        .id = QTR_ID

-    End With

-    

-    sql = "SELECT * FROM quarter WHERE id=" & QTR_ID

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objQTR.entry_date = dbRecordset("entry_date")

-        objQTR.rep_id = dbRecordset("rep_id")

-        objQTR.sale_PLAN = dbRecordset("sale_plan")

-        objQTR.ClxnH20mg = dbRecordset("ClxnH20mg")

-        objQTR.ClxnH40mg = dbRecordset("ClxnH40mg")

-        objQTR.ClxnT40mg = dbRecordset("ClxnT40mg")

-        objQTR.ClxnC_IM = dbRecordset("ClxnC_IM")

-        objQTR.ClxnC_ACS = dbRecordset("ClxnC_ACS")

-        objQTR.id = dbRecordset("id")

-    End If

-    

-    dbGet_QTR_Record = objQTR

-

-End Function

-

-

-Function Get_QTR_Record_by_REP(ent_date As String, rep_id As Long) As tQTR

-    Dim dbConnection As Object

-    Dim allQTR() As tQTR

-    Dim i As Long

-

-    dbOpenConnection dbConnection

-

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id)

-    If i <> 0 Then

-        Get_QTR_Record_by_REP = allQTR(1)

-    End If

-

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTR_Records_by_REP(ByRef all_QTR() As tQTR, ent_date As String, rep_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-

-    GetAll_QTR_Records_by_REP = dbGetAll_QTR_Records_By_REP(dbConnection, all_QTR, ent_date, rep_id)

-

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGetAll_QTR_Records_By_REP(dbConnection As Object, all_QTR() As tQTR, ent_date As String, rep_id As Long) As Integer

-

-    Dim getCount_QTR_SQL As String

-    Dim getAll_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter " & _

-    "WHERE entry_date like '" & ent_date & "' AND rep_id=" & rep_id

-    getAll_QTR_SQL = "SELECT * FROM quarter " & _

-    "WHERE entry_date like '" & ent_date & "' AND rep_id=" & rep_id & " ORDER BY entry_date"

-

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-

-    dbRecordset.Close

-

-    dbGetAll_QTR_Records_By_REP = QTR_Count

-

-    If QTR_Count > 0 Then

-        'we have records

-        ReDim all_QTR(1 To QTR_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTR_SQL, dbConnection

-

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTR As tQTR

-                 With tmp_QTR

-                    .entry_date = dbRecordset("entry_date")

-                    .rep_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .ClxnH20mg = dbRecordset("ClxnH20mg")

-                    .ClxnH40mg = dbRecordset("ClxnH40mg")

-                    .ClxnT40mg = dbRecordset("ClxnT40mg")

-                    .ClxnC_IM = dbRecordset("ClxnC_IM")

-                    .ClxnC_ACS = dbRecordset("ClxnC_ACS")

-                    .id = dbRecordset("id")

-                 End With

-

-                 all_QTR(index) = tmp_QTR

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-cdbQTR
->>>>>>
-Attribute VB_Name = "cdbQTR"

-Option Explicit

-

-Public Type tQTR_COMMON

-    qtr As tQTR

-    i_lcd As Long           ' число ЛПУ в СПИСКЕ

-    lcd() As tLPU_COMMON    ' список ЛПУ

-    c_beds As Long          ' сумма коек

-    c_bdgt_NFG As Long      ' общий бюджет на НФГ

-    c_bdgt_NMG As Long      ' общий бюджет на НМГ

-    c_bdgt_LPU As Long      ' общий бюджет на гепарины

-    c_sale_PLAN As Long     ' план продаж репа

-    c_sale_ALL As Long      ' продажи

-    c_sale_HIR As Long      ' в хирургии

-    c_sale_TER  As Long     ' в терапии

-    c_sale_CRD  As Long     ' в кардиологии

-    c_pat_HIR   As Long     ' пациенты

-    c_pat_TER   As Long     '

-    c_pat_CRD   As Long     '

-    c_pat_ALL   As Long     '

-    c_pat_LPU   As Long     ' Всего операций

-End Type

-

-Function GetLastQTR_fromDB() As String

-    Dim dbConnection As Object

-    Dim getCount_QTR_SQL As String

-    Dim getLast_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter"

-    getLast_QTR_SQL = "SELECT MAX(entry_date) as ent_date FROM quarter"

-    

-    dbOpenConnection dbConnection

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    If QTR_Count > 0 Then

-        'we have records

-        dbRecordset.Open getLast_QTR_SQL, dbConnection

-        getLast_QTR_SQL = dbRecordset("ent_date")

-    End If

-    GetLastQTR_fromDB = getLast_QTR_SQL

-    dbCloseConnection dbConnection

-End Function

-

-Function Get_QTR_CommonList_by_REP(ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_QTR_CommonList_by_REP = dbGet_QTR_CommonList_by_REP(dbConnection, qcd, ent_date, rep_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_CommonList_by_REP(dbConnection As Object, ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim allQTR() As tQTR

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id)

-    dbGet_QTR_CommonList_by_REP = i

-    If i > 0 Then

-        ReDim qcd(i)

-        For i = 1 To UBound(allQTR)

-            With qcd(i)

-                .qtr = allQTR(i)

-                .c_beds = 0

-                .c_bdgt_NFG = 0

-                .c_bdgt_NMG = 0

-                .c_bdgt_LPU = 0

-                .c_sale_PLAN = 0

-                .c_pat_HIR = 0

-                .c_pat_TER = 0

-                .c_pat_CRD = 0

-                .c_pat_ALL = 0

-                .c_sale_HIR = 0

-                .c_sale_TER = 0

-                .c_sale_CRD = 0

-                .c_sale_ALL = 0

-                .c_pat_LPU = 0

-                

-                j = dbGet_LPU_CommonQTR(dbConnection, .lcd, .qtr)

-                .i_lcd = j

-                If j > 0 Then

-                    For j = 1 To UBound(.lcd)

-                        .c_beds = .c_beds + .lcd(j).lpu.beds

-                        .c_bdgt_NFG = .c_bdgt_NFG + .lcd(j).bdgt.bdgt_NFG

-                        .c_bdgt_NMG = .c_bdgt_NMG + .lcd(j).bdgt.bdgt_NMG

-                        .c_bdgt_LPU = .c_bdgt_LPU + .lcd(j).bdgt_LPU

-                        .c_sale_PLAN = .c_sale_PLAN + .lcd(j).bdgt.sale_PLAN

-                        .c_pat_HIR = .c_pat_HIR + .lcd(j).pat_HIR

-                        .c_pat_TER = .c_pat_TER + .lcd(j).pat_TER

-                        .c_pat_CRD = .c_pat_CRD + .lcd(j).pat_CRD

-                        .c_pat_ALL = .c_pat_ALL + .lcd(j).pat_ALL

-                        .c_sale_HIR = .c_sale_HIR + .lcd(j).sale_HIR

-                        .c_sale_TER = .c_sale_TER + .lcd(j).sale_TER

-                        .c_sale_CRD = .c_sale_CRD + .lcd(j).sale_CRD

-                        .c_sale_ALL = .c_sale_ALL + .lcd(j).sale_ALL

-                        .c_pat_LPU = .c_pat_LPU + .lcd(j).pat_LPU

-                    Next j

-                    

-                End If

-            End With

-        Next i

-    End If

-End Function

-

-Function GetLastQtr() As String

-    Dim s As String

-    Dim r As Range

-    Set r = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Do While r.Cells(1, 1) <> ""

-        s = r.Cells(1, 1)

-        Set r = r.Cells.Offset(1, 0)

-    Loop

-    GetLastQtr = s

-End Function

-

-Function GetNextQTR(ent_date As String) As String

-    Dim rd As Range

-    Dim idx As Integer

-    Dim b As Variant

-    Dim dlg As dlg_newQTR

-    Set dlg = New dlg_newQTR

-    

-    If ent_date = "" Then

-        Dim ir As Variant

-        idx = 0

-        dlg.Show

-        b = dlg.Tag

-            

-        If IsNumeric(b) Then

-            GetNextQTR = dlg.cbQTR

-        Else

-            GetNextQTR = ""

-        End If

-    Else

-        Set rd = Worksheets(VAR_SHEET).Range("Date_Lst")

-        idx = WorksheetFunction.Match(ent_date, rd, 0)

-        GetNextQTR = WorksheetFunction.index(rd, idx + 1, 1)

-    End If

-End Function

-<<<<<<
-======================
-mRestView
->>>>>>
-Attribute VB_Name = "mRestView"

-Option Explicit

-

-Sub xlRestoreView()

-Attribute xlRestoreView.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute xlRestoreView.VB_ProcData.VB_Invoke_Func = " \n14"

-    With Application

-        .CommandBars("Standard").Visible = True

-        .CommandBars("Formatting").Visible = True

-        .DisplayFormulaBar = True

-        .DisplayStatusBar = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = True

-    End With

-End Sub

-<<<<<<
-======================
-dlg_newQTR
->>>>>>
-Attribute VB_Name = "dlg_newQTR"

-Attribute VB_Base = "0{3EA3C15A-5493-445F-9858-2F241E7D6CEA}{849C1FE1-631A-485D-BE54-A7B73124582C}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mDec2TS
->>>>>>
-Attribute VB_Name = "mDec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-CHRT_LPU_BBL
->>>>>>
-Attribute VB_Name = "CHRT_LPU_BBL"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Unprotect

-    Range("view_key") = True

-    On Error Resume Next

-    ChangeLabels

-    Range("A1").Select

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Unprotect

-    Dim s As String

-    s = Range("ret_addr")

-    Protect UserInterfaceOnly:=True

-    Wks_select (s)

-End Sub

-

-Sub BCLabelChng_Click()

-    Unprotect

-    If Range("view_key") Then

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать названия"

-    Else

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать объемы"

-    End If

-    Range("view_key") = Not Range("view_key")

-    ChangeLabels

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub ChangeLabels()

-    Dim i As Integer

-    Dim offset_text As Integer

-    Dim src As Range

-    Set src = Range("CHRT_BBL_DATA")

-    

-    offset_text = 3

-    If Range("view_key") Then

-        offset_text = 4

-    End If

-    

-    With ChartObjects(1).Chart

-        With .SeriesCollection(1)

-            For i = 1 To .Points.count

-                On Error GoTo ExitLabel

-                .Points(i).DataLabel.Characters.Text = Format(src.Cells(i, offset_text))

-            Next i

-        End With

-    End With

-ExitLabel:

-End Sub

-

-<<<<<<
-======================
-CHRT_PAT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PAT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-<<<<<<
-======================
-CHRT_PAT_LPU
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_nextQTR
->>>>>>
-Attribute VB_Name = "dlg_nextQTR"

-Attribute VB_Base = "0{B85FF7F1-50C0-4433-BC6F-8A0F2C9BDDDA}{EC2D2B9E-9ED2-4005-A1E9-EF0626D3B7E7}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-cdbLPU
->>>>>>
-Attribute VB_Name = "cdbLPU"

-Option Explicit

-

-Public Type tLPU_COMMON

-    lpu As tLPU

-    bdgt As tBUDGET

-    i_hir As Long

-    hir() As tHIRURGIA

-    i_ter As Long

-    ter() As tTERAPIA

-    i_ACS As Long

-    ACS() As tACS

-    bdgt_LPU As Long

-    sale_HIR As Long

-    sale_TER As Long

-    sale_CRD As Long

-    sale_ALL As Long

-    pat_HIR As Long

-    pat_TER As Long

-    pat_CRD As Long

-    pat_ALL As Long     ' Сумма всех пациентов на клексане

-    pat_LPU As Long     ' Число потенциальных пациентов для продаж клексана

-End Type

-

-Function Get_LPU_CommonQTR(ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    Get_LPU_CommonQTR = dbGet_LPU_CommonQTR(dbConnection, lcd, objQTR)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_CommonQTR(dbConnection As Object, ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    i = dbGetAll_LPU_byQTR(dbConnection, allLPU, objQTR.entry_date, objQTR.rep_id)

-    dbGet_LPU_CommonQTR = i

-    If i > 0 Then

-        ReDim lcd(i)

-        For i = 1 To UBound(allLPU)

-            dbGet_LPU_Common dbConnection, lcd(i), allLPU(i), objQTR

-        Next i

-    End If

-End Function

-

-Sub Get_LPU_Common(ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    dbGet_LPU_Common dbConnection, lcd, cLPU, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbGet_LPU_Common(dbConnection As Object, ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-

-    lcd.lpu = cLPU

-    lcd.bdgt = dbGet_BDGT_Record(dbConnection, cLPU.id, objQTR.entry_date)

-    lcd.i_hir = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, lcd.hir, cLPU.id, objQTR.entry_date)

-    lcd.i_ter = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, lcd.ter, cLPU.id, objQTR.entry_date)

-    lcd.i_ACS = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, lcd.ACS, cLPU.id, objQTR.entry_date)

-    With lcd

-        .bdgt_LPU = .bdgt.bdgt_NFG + .bdgt.bdgt_NMG

-        .pat_LPU = 0

-        If .i_hir > 0 Then

-            .pat_HIR = .hir(1).patients_ambulator_clexan + .hir(1).patients_stationar_clexan

-            .sale_HIR = objQTR.ClxnH20mg * (.hir(1).patients_ambulator_clexan_20mg + .hir(1).patients_stationar_clexan_20mg)

-            .sale_HIR = .sale_HIR + objQTR.ClxnH40mg * (.hir(1).patients_ambulator_clexan_40mg + .hir(1).patients_stationar_clexan_40mg)

-            .pat_LPU = .pat_LPU + .hir(1).operations_per_quarter

-        End If

-        If .i_ter > 0 Then

-            .pat_TER = .ter(1).patients_ambulator_clexan + .ter(1).patients_stationar_clexan

-            .sale_TER = .pat_TER * objQTR.ClxnT40mg

-            .pat_LPU = .pat_LPU + .ter(1).patients_per_quarter

-        End If

-        If .i_ACS > 0 Then

-            .pat_CRD = .ACS(1).patients_stationar_clexan

-            .sale_CRD = .pat_CRD * objQTR.ClxnC_ACS

-            .pat_LPU = .pat_LPU + .ACS(1).patients_per_quarter

-        End If

-        .pat_ALL = .pat_HIR + .pat_TER + .pat_CRD

-        .sale_ALL = .sale_HIR + .sale_TER + .sale_CRD

-    End With

-End Sub

-

-<<<<<<
-======================
-CHRT_PIE
->>>>>>
-Attribute VB_Name = "CHRT_PIE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    

-    Unprotect

-    

-    On Error Resume Next

-    

-    Range("P5:Q24").Sort _

-        Key1:=Range("Q5"), _

-        Order1:=xlDescending, _

-        Header:=xlGuess, _

-        OrderCustom:=1, _

-        MatchCase:=False, _

-        Orientation:=xlTopToBottom

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PLN_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PLN_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_BDGT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_BDGT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_LPU_delete
->>>>>>
-Attribute VB_Name = "dlg_LPU_delete"

-Attribute VB_Base = "0{EC96F2D1-337D-47DF-B0F1-A6DF3F8CD5CC}{7EB42A63-CBFC-45B0-AE4D-C3E3D8FE7420}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlg_Mail
->>>>>>
-Attribute VB_Name = "dlg_Mail"

-Attribute VB_Base = "0{7B669454-C2AA-4FDF-8311-7ADEDDEF3FF3}{D07A0A02-4923-46C8-8EE8-62769243087D}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dbREP_id
->>>>>>
-Attribute VB_Name = "dbREP_id"

-Public Type tREPID

-    rep_id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function GetAll_REPID_Records_by_QTR(ByRef all_REPID() As tREPID, ent_date As String) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_REPID_Records_by_QTR = dbGetAll_REPID_Records_by_QTR(dbConnection, all_REPID, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-Function Get_REPID_Record(id As Long) As tREPID

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REPID_Record = dbGet_REPID_Record(dbConnection, id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_REPID_Records(ByRef all_REPID() As tREPID) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_REPID_Records = dbGetAll_REPID_Records(dbConnection, all_REPID)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function dbGet_REPID_Record(dbConnection As Object, id As Long) As tREPID

-    

-    Dim sql As String

-    Dim objREPID As tREPID

-    

-    objREPID.FirstName = ""

-    objREPID.LastName = ""

-    objREPID.Region = 0

-    objREPID.City = 0

-    sql = "SELECT rep_id, firstname, lastname, region, city FROM " & _

-          "rep WHERE rep_id=" & id

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREPID.rep_id = dbRecordset("rep_id")

-        objREPID.FirstName = dbRecordset("firstname")

-        objREPID.LastName = dbRecordset("lastname")

-        objREPID.Region = dbRecordset("region")

-        objREPID.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REPID_Record = objREPID

-        

-End Function

-

-Function dbGetAll_REPID_Records_by_QTR(dbConnection As Object, ByRef all_REPID() As tREPID, ent_date As String) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    Dim Where As String

-    

-    REPID_Count = 0

-    Where = " WHERE lpu_budget.entry_date like '" & ent_date & "' " & _

-        "AND rep.rep_id=lpu.rep_id AND lpu.id=lpu_budget.lpu_id"

-    

-    

-    getAll_REPID_SQL = "SELECT distinct rep.* FROM rep, lpu, lpu_budget" & Where

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM (" & getAll_REPID_SQL & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records_by_QTR = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Function dbGetAll_REPID_Records(dbConnection As Object, ByRef all_REPID() As tREPID) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    REPID_Count = 0

-    

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM rep"

-    getAll_REPID_SQL = "SELECT * FROM rep"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-cdbExport
->>>>>>
-Attribute VB_Name = "cdbExport"

-Option Explicit

-

-Function GetDBSN() As String

-    Dim n As Long

-    Randomize Timer

-    n = Int((100000000 - 1000000 + 1) * Rnd + 1000000)

-    GetDBSN = Dec2ThirtySix(n)

-End Function

-

-Sub dbExport()

-    Dim src_file As String

-    Dim dst_file As String

-    

-    On Error GoTo ErrHandler

-    

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & GetLastQTR_fromDB & "_" & GetDBSN() & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Данные экспортированы в файл:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для передачи", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-Exit Sub

-

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-<<<<<<
-======================
-mRegs
->>>>>>
-Attribute VB_Name = "mRegs"

-Option Explicit

-

-Function GetRegionName(idx As Integer) As String

-    GetRegionName = Worksheets(REGS_SHEET).Range("LST_REGIONS").Cells(idx + 1, 1).Text

-End Function

-

-Function GetCityName(idx_reg As Integer, idx_city As Integer) As String

-    GetCityName = Worksheets(REGS_SHEET).Range("CITY_TABLES").Offset(idx_city + 1, idx_reg * 2).Text

-End Function

-

-Sub testReg()

-    Dim r As Integer

-    Dim c As Integer

-    Dim s As String

-    

-    r = 3

-    c = 3

-    s = GetRegionName(r)

-    s = s & ", " & GetCityName(r, c)

-    MsgBox s

-End Sub

-

-<<<<<<
-======================
-RM_QTR
->>>>>>
-Attribute VB_Name = "RM_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CRGN_QT As Integer = 0

-Const CRGN_PLN As Integer = 2

-Const CRGN_FCT As Integer = 3

-Const CRGN_BDG As Integer = 4

-Const CRGN_LPU As Integer = 5

-Const CRGN_REP As Integer = 6

-Const CRGN_HIR As Integer = 7

-Const CRGN_TER As Integer = 8

-Const CRGN_CRD As Integer = 9

-Const CRGN_CLXN_BDG As Integer = 10

-Const CRGN_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub ClearRMName()

-    Unprotect

-    Range("D4") = ""

-    Range("D5") = ""

-    Range("H4") = ""

-End Sub

-

-Sub update_history()

-    Dim objRGN() As tREGION

-    Dim i As Long

-    Dim r As Range

-    Dim cRMan As tREGMAN

-

-    cRMan = Get_REGMAN_Record

-    

-    Range("D4") = cRMan.LastName

-    Range("D5") = cRMan.FirstName

-

-    Range("H4") = GetRegionName(cRMan.Region)

-    

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetRGN_COMM_DATA(objRGN)

-    

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objRGN)

-            r.Offset(i - 1, CRGN_QT) = objRGN(i).ent_date

-            r.Offset(i - 1, CRGN_FCT) = objRGN(i).total_SALE

-            r.Offset(i - 1, CRGN_PLN) = objRGN(i).sale_PLAN

-            r.Offset(i - 1, CRGN_BDG) = objRGN(i).total_BDGT

-            r.Offset(i - 1, CRGN_LPU) = objRGN(i).total_LPU

-            r.Offset(i - 1, CRGN_REP) = objRGN(i).total_REP

-            r.Offset(i - 1, CRGN_HIR) = objRGN(i).total_HIR

-            r.Offset(i - 1, CRGN_TER) = objRGN(i).total_TER

-            r.Offset(i - 1, CRGN_CRD) = objRGN(i).total_ACS

-            If objRGN(i).total_BDGT <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_BDG) = objRGN(i).total_SALE / objRGN(i).total_BDGT

-            End If

-            If objRGN(i).total_BDGT_NMG <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_NMG) = objRGN(i).total_SALE / objRGN(i).total_BDGT_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRGN_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRM_QtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR_RM

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR_RM

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR_RM

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = RM_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect UserInterfaceOnly:=True

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CRGN_QT + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    If r = "" Then

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = currRange.address

-        With Worksheets("REP_LIST")

-            .Range("ret_addr") = "RM_QTR"

-            .Range("ent_date") = r

-            .Range("VIEW_ONLY") = True

-        End With

-    End If

-    Cancel = True

-    btRM_QTR_Do_IT

-End Sub

-

-<<<<<<
-======================
-dbREG_MAN
->>>>>>
-Attribute VB_Name = "dbREG_MAN"

-Option Explicit

-

-Public Type tREGMAN

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function Get_REGMAN_Record() As tREGMAN

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REGMAN_Record = dbGet_REGMAN_Record(dbConnection)

-    dbCloseConnection dbConnection

-End Function

-

-Sub Set_REGMAN_Record(cREGMAN As tREGMAN)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbSet_REGMAN_Record dbConnection, cREGMAN

-    dbCloseConnection dbConnection

-End Sub

-

-Sub ReSet_REGMAN_Record()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbReSet_REGMAN_Record dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_REGMAN_Record(dbConnection As Object) As tREGMAN

-    

-    Dim sql As String

-    Dim objREGMAN As tREGMAN

-    

-    objREGMAN.FirstName = ""

-    objREGMAN.LastName = ""

-    objREGMAN.Region = 0

-    objREGMAN.City = 0

-    sql = "SELECT firstname, lastname, region, city FROM " & _

-          "reg_man"

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREGMAN.FirstName = dbRecordset("firstname")

-        objREGMAN.LastName = dbRecordset("lastname")

-        objREGMAN.Region = dbRecordset("region")

-        objREGMAN.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REGMAN_Record = objREGMAN

-        

-End Function

-

-Public Sub dbSet_REGMAN_Record(dbConnection As Object, ByRef objREGMAN As tREGMAN)

-  

-    Dim DeleteSQL As String

-    Dim InsertSQL As String

-    

-    DeleteSQL = "DELETE FROM reg_man"

-    InsertSQL = "INSERT INTO reg_man (firstname, lastname, region, city) VALUES (" & _

-    "'" & objREGMAN.FirstName & "', " & _

-    "'" & objREGMAN.LastName & "', " & _

-    objREGMAN.Region & ", " & _

-    objREGMAN.City & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    dbRecordset.Open InsertSQL, dbConnection

-       

-End Sub

-

-Public Sub dbReSet_REGMAN_Record(dbConnection As Object)

-  

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM reg_man"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    

-End Sub

-

-

-<<<<<<
-======================
-dbDatabaseMerge
->>>>>>
-Attribute VB_Name = "dbDatabaseMerge"

-Option Explicit

-

-Public Type tDBFIELD

-    name As String

-End Type

-

-Public Type tDBTABLE

-    name As String

-    field() As tDBFIELD

-End Type

-

-

-Function dbGetConnection(dbAccessFileFullPath As String) As Object

-    Dim dbConnection As Object

-    Dim dbAccessFilePasswd As String

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFileFullPath & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    Set dbGetConnection = dbConnection

-End Function

-

-Sub dbCloseOpenedConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteOpenedSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-Function dbMergeREP(from_dbConnection As Object, to_dbConnection As Object) As Long

-

-    Dim getRecordset As Object

-    Dim getREPData_SQL As String

-    Dim REP_fn As String

-    Dim REP_ln As String

-    Dim REP_region As String

-    Dim REP_city As String

-

-

-    getREPData_SQL = "SELECT * FROM rep"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getREPData_SQL, from_dbConnection

-        

-        If Not getRecordset.BOF Then

-            REP_fn = getRecordset("firstname")

-            REP_ln = getRecordset("lastname")

-            REP_city = getRecordset("city")

-            REP_region = getRecordset("region")

-        Else

-            MsgBox "There is no information about rep! This database cannot be merged!!!"

-            dbMergeREP = -1

-            Exit Function

-        End If

-    

-    Dim insertRecordset As Object

-    Set insertRecordset = CreateObject("ADODB.Recordset")

-        

-    insertRecordset.Open "rep", to_dbConnection, 2, 2

-    insertRecordset.addnew

-        

-    insertRecordset("firstname") = REP_fn

-    insertRecordset("lastname") = REP_ln

-    insertRecordset("region") = REP_region

-    insertRecordset("city") = REP_city

-    insertRecordset.Update

-    insertRecordset.MoveLast

-    'new ID

-    

-    dbMergeREP = insertRecordset("rep_id")

-    

-End Function

-

-Sub dbMergeLPU(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getLPU_SQL As String

-    Dim getRecordset As Object

-    Dim idx As Long

-    idx = 1

-    

-    getLPU_SQL = "SELECT * FROM lpu"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getLPU_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            ReDim Preserve objLPU(1 To idx)

-            objLPU(idx).old_lpu_id = getRecordset("id")

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "lpu", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("name") = getRecordset("name")

-            insRS("address") = getRecordset("address")

-            insRS("beds") = getRecordset("beds")

-            insRS.Update

-            insRS.MoveLast

-            'new ID

-            

-            objLPU(idx).new_lpu_id = insRS("id")

-                        

-            idx = idx + 1

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about LPU! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-

-Sub dbMergeLPURelated(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object)

-

-    ' 6 tables to change

-    Dim tables(1 To 5) As tDBTABLE

-    

-    'lpu budget

-    tables(1).name = "lpu_budget"

-    ReDim tables(1).field(1 To 4)

-    

-    tables(1).field(1).name = "entry_date"

-    tables(1).field(2).name = "bdgt_NMG"

-    tables(1).field(3).name = "bdgt_NFG"

-    tables(1).field(4).name = "sale_PLAN"

-    

-    'lpu hir

-    tables(2).name = "lpu_hir"

-    ReDim tables(2).field(1 To 13)

-    

-    tables(2).field(1).name = "entry_date"

-    tables(2).field(2).name = "operations_per_quarter"

-    tables(2).field(3).name = "risk_percent"

-    tables(2).field(4).name = "patients_with_risk_ON"

-    tables(2).field(5).name = "patients_ambulator"

-    tables(2).field(6).name = "patients_ambulator_nmg"

-    tables(2).field(7).name = "patients_ambulator_clexan"

-    tables(2).field(8).name = "patients_ambulator_clexan_40mg"

-    tables(2).field(9).name = "patients_ambulator_clexan_20mg"

-    tables(2).field(10).name = "patients_stationar_nmg"

-    tables(2).field(11).name = "patients_stationar_clexan"

-    tables(2).field(12).name = "patients_stationar_clexan_40mg"

-    tables(2).field(13).name = "patients_stationar_clexan_20mg"

-    

-    

-    'lpu acs

-    tables(3).name = "lpu_acs"

-    ReDim tables(3).field(1 To 5)

-    

-    tables(3).field(1).name = "entry_date"

-    tables(3).field(2).name = "patients_with_geparins"

-    tables(3).field(3).name = "patients_per_quarter"

-    tables(3).field(4).name = "patients_stationar_nmg"

-    tables(3).field(5).name = "patients_stationar_clexan"

-    

-    'lpu acs

-    tables(4).name = "lpu_im"

-    ReDim tables(4).field(1 To 5)

-    

-    tables(4).field(1).name = "entry_date"

-    tables(4).field(2).name = "patients_with_geparins"

-    tables(4).field(3).name = "patients_per_quarter"

-    tables(4).field(4).name = "patients_stationar_nmg"

-    tables(4).field(5).name = "patients_stationar_clexan"

-    

-    

-    'lpu acs

-    tables(5).name = "lpu_ter"

-    ReDim tables(5).field(1 To 9)

-    

-    tables(5).field(1).name = "entry_date"

-    tables(5).field(2).name = "patients_per_quarter"

-    tables(5).field(3).name = "risk_percent"

-    tables(5).field(4).name = "patients_with_risk_ON"

-    tables(5).field(5).name = "patients_ambulator"

-    tables(5).field(6).name = "patients_ambulator_nmg"

-    tables(5).field(7).name = "patients_ambulator_clexan"

-    tables(5).field(8).name = "patients_stationar_nmg"

-    tables(5).field(9).name = "patients_stationar_clexan"

-    

-    

-    

-    Dim tbl_idx As Integer

-    

-    For tbl_idx = 1 To UBound(tables)

-        

-        Dim getSQL As String

-        Dim getRS As Object

-        

-        

-        

-        Set getRS = CreateObject("ADODB.Recordset")

-        

-        getSQL = "SELECT * FROM " & tables(tbl_idx).name

-        getRS.Open getSQL, from_db

-        

-        If Not getRS.BOF Then

-            Do While Not getRS.EOF

-                Dim insRS As Object

-                Set insRS = CreateObject("ADODB.Recordset")

-                

-                insRS.Open tables(tbl_idx).name, to_db, 2, 2

-                insRS.addnew

-                Dim fld_idx As Integer

-    

-                    For fld_idx = 1 To UBound(tables(tbl_idx).field)

-                        insRS(tables(tbl_idx).field(fld_idx).name) = getRS(tables(tbl_idx).field(fld_idx).name)

-                        insRS("lpu_id") = findNewLPU_IDByOld(objLPU, getRS("lpu_id"))

-                    Next fld_idx

-                    

-                insRS.Update

-                insRS.MoveLast

-                getRS.MoveNext

-            Loop

-        End If

-        

-        

-    Next tbl_idx

-

-End Sub

-

-Function findNewLPU_IDByOld(objLPU() As tLPUCONVERTION, old_id As Long)

-

-Dim i As Integer

-For i = 1 To UBound(objLPU)

-    If objLPU(i).old_lpu_id = old_id Then

-        findNewLPU_IDByOld = objLPU(i).new_lpu_id

-        Exit Function

-    End If

-Next i

-

-findNewLPU_IDByOld = -1

-End Function

-

-

-

-

-

-Sub dbMergeQTR(from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getQTR_SQL As String

-    Dim getRecordset As Object

-    

-    getQTR_SQL = "SELECT * FROM quarter"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getQTR_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "quarter", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("entry_date") = getRecordset("entry_date")

-            insRS("sale_plan") = getRecordset("sale_plan")

-            insRS("ClxnH20mg") = getRecordset("ClxnH20mg")

-            insRS("ClxnH40mg") = getRecordset("ClxnH40mg")

-            insRS("ClxnT40mg") = getRecordset("ClxnT40mg")

-            insRS("ClxnC_IM") = getRecordset("ClxnC_IM")

-            insRS("ClxnC_ACS") = getRecordset("ClxnC_ACS")

-            

-            

-            insRS.Update

-            

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about quarter budget! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-dbMerge
->>>>>>
-Attribute VB_Name = "dbMerge"

-Option Explicit

-

-Public Type tLPUCONVERTION

-    old_lpu_id As Long

-    new_lpu_id As Long

-End Type

-

-Sub Merge_BackUp_All_Data()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim time_stump As String

-    

-    On Error GoTo ErrHandler

-    

-    time_stump = Format(Date, "yy-mm-dd_") & Format(Time, "hh-mm")

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_BACKUPNAME & time_stump & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Старые данные сохранены в файле:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для восстановления данных в случае утери", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-    Exit Sub

-    

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-

-Sub Merge_Clear_All_Data(access_file_full_path As String)

-    

-    Dim db As Object

-    Dim tables_to_clear() As String

-    On Error GoTo ErrHandler

-    

-    ReDim tables_to_clear(1 To 8)

-    tables_to_clear(1) = "rep"

-    tables_to_clear(2) = "lpu"

-    tables_to_clear(3) = "lpu_budget"

-    tables_to_clear(4) = "lpu_hir"

-    tables_to_clear(5) = "lpu_ter"

-    tables_to_clear(6) = "lpu_acs"

-    tables_to_clear(7) = "lpu_im"

-    tables_to_clear(8) = "quarter"

-    

-    Set db = dbGetConnection(access_file_full_path)

-

-    Dim i As Integer

-    

-    For i = 1 To UBound(tables_to_clear)

-        

-        If tables_to_clear(i) <> "" Then

-            Dim Clear_SQL As String

-            Clear_SQL = "DELETE FROM " & tables_to_clear(i)

-            dbExecuteOpenedSQL db, Clear_SQL

-        Else

-            'do nothing or show message

-        End If

-    Next i

-    

-    dbCloseOpenedConnection db

-    Set db = Nothing

-    

-'    Dim Engine As Object

-'    Set Engine = CreateObject("JRO.JetEngine")

-'    Engine.CompactDatabase "Password=password;Data Source=" & access_file_full_path, _

-'    "Password=password;Data Source=c:\tmp\1.mdb"

-    

-Exit Sub

-

-ErrHandler:

-    MsgBox "something wrong: " & err.Description

-    Resume Next

-    

-End Sub

-

-Function MergeREP(from_file As String, to_file As String) As Long

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    Dim new_rep_id As Long

-

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    MergeREP = dbMergeREP(db1, db2)

-    'MsgBox "new rep ID is " & new_rep_id

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Function

-

-Sub MergeQTR(from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeQTR db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-

-Sub MergeLPU(objLPU() As tLPUCONVERTION, from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeLPU objLPU, db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-Sub MergeLPURelated(objLPU() As tLPUCONVERTION, from_file As String, to_file As String)

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    dbMergeLPURelated objLPU, db1, db2

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-

-End Sub

-

-Sub MergeGlobal(rep_files() As String, rm_file As String)

-

-    Dim i As Integer

-    'clear output file content

-    Merge_Clear_All_Data rm_file

-    

-    For i = 1 To UBound(rep_files)

-        

-        Dim rep_file As String

-        'setup input and output files

-        rep_file = rep_files(i)

-        

-        Dim new_rep_id As Long

-        ' insert REP data and get new rep_id

-        new_rep_id = MergeREP(rep_file, rm_file)

-        

-        Dim objLPU() As tLPUCONVERTION

-        'insert all LPU using new generated rep_id

-        'and populate objLPU old->new relation object

-        

-        MergeLPU objLPU, rep_file, rm_file, new_rep_id

-        'insert quarter data using new rep_id

-        MergeQTR rep_file, rm_file, new_rep_id

-        

-        

-        ' and.... insert all another data (5 tables excl version and hw)

-        'using objLPU old->new relation object

-        MergeLPURelated objLPU, rep_file, rm_file

-    

-    

-    Next i

-    

-End Sub

-

-Function GetDBList(MyPath() As String, ByRef dblist() As String) As Integer

-    Dim i As Integer

-    Dim MyName, MyMask

-    MyMask = MyPath(0) & MyPath(1) & PROGRAM_DATAEXT

-    i = 0

-    MyName = Dir(MyMask)      ' Retrieve the first entry.

-    Do While MyName <> ""    ' Start the loop.

-        ' Ignore the current directory and the encompassing directory.

-        If MyName <> "." And MyName <> ".." Then

-            ' Use bitwise comparison to make sure MyName is a directory.

-            i = i + 1

-            ReDim Preserve dblist(i)

-            dblist(i) = MyPath(0) & MyName

-        End If

-        MyName = Dir    ' Get next entry.

-    Loop

-    GetDBList = i

-End Function

-

-<<<<<<
-======================
-dlgImprtDB
->>>>>>
-Attribute VB_Name = "dlgImprtDB"

-Attribute VB_Base = "0{D5892870-2C88-40C8-A817-AC9B1CF37C2C}{9853EBEA-4E48-41F9-89C0-6F753EB6A0C2}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Private Sub btSelAll_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = True

-    Next i

-End Sub

-

-Private Sub btUnselect_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = False

-    Next i

-End Sub

-<<<<<<
-======================
-dbQTR_RM
->>>>>>
-Attribute VB_Name = "dbQTR_RM"

-Option Explicit

-

-Public Type tQTRRM

-    id As Long

-    entry_date As String

-    rm_id As Long

-    sale_PLAN As Long

-End Type

-

-

-Sub Insert_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objQTRRM.id <> 0 Then

-        dbUpdate_QTRRM_Record dbConnection, objQTRRM

-    Else

-        dbInsert_QTRRM_Record dbConnection, objQTRRM

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-Function Get_QTRRM_Record(ent_date As String) As tQTRRM

-    Dim dbConnection As Object

-    Dim allQTRRM() As tQTRRM

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    i = dbGetAll_QTRRM_Records(dbConnection, allQTRRM, ent_date)

-    If i <> 0 Then

-        Get_QTRRM_Record = allQTRRM(1)

-    End If

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTRRM_Records(ByRef all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_QTRRM_Records = dbGetAll_QTRRM_Records(dbConnection, all_QTRRM, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_QTRRM_Record dbConnection, objQTRRM

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objQTRRM.ID <> 0 then updatre else insert

-Sub dbInsert_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "quarter_rm", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objQTRRM

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("sale_plan") = .sale_PLAN

-        dbRecordset("rm_id") = .rm_id

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objQTRRM.id = dbRecordset("id")

-

-End Sub

-

-Sub dbUpdate_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim Update_SQL As String

-    

-    With objQTRRM

-        Update_SQL = "UPDATE quarter_rm SET " & _

-            "entry_date='" & .entry_date & "'" & "," & _

-            "rm_id=" & .rm_id & "," & _

-            "sale_plan=" & .sale_PLAN & "," & _

-            " WHERE id=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if ent_date = % then all_records

-Function dbGetAll_QTRRM_Records(dbConnection As Object, all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    

-    Dim getCount_QTRRM_SQL As String

-    Dim getAll_QTRRM_SQL As String

-    Dim QTRRM_Count As Long

-    QTRRM_Count = 0

-    

-    getCount_QTRRM_SQL = "SELECT COUNT(*) AS QTRRM_TOTAL FROM quarter_rm WHERE entry_date like '" & ent_date & "'"

-    getAll_QTRRM_SQL = "SELECT * FROM quarter_rm WHERE entry_date like '" & ent_date & "' ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTRRM_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTRRM_Count = dbRecordset("QTRRM_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_QTRRM_Records = QTRRM_Count

-    

-    If QTRRM_Count > 0 Then

-        'we have records

-        ReDim all_QTRRM(1 To QTRRM_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTRRM_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTRRM As tQTRRM

-                 With tmp_QTRRM

-                    .entry_date = dbRecordset("entry_date")

-                    .rm_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .id = dbRecordset("id")

-                 End With

-                 

-                 all_QTRRM(index) = tmp_QTRRM

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM quarter_rm " & _

-    "WHERE id=" & objQTRRM.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-    

-    'delete related budget entries

-    MsgBox "remember delete related"

-'    dbDelete_BDGT_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Hir_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Ter_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_ACS_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-       

-End Sub

-

-

-<<<<<<
-======================
-REP_LIST
->>>>>>
-Attribute VB_Name = "REP_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentREP_ID() As Long

-    Dim r As Range

-

-    With Worksheets("REP_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CREP_ID)

-    End With

-

-    getCurrentREP_ID = r

-End Function

-

-Public Sub REP_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Rep_Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Rep_Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Rep_Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Rep_Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectREP_LPU(rep_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim r_id As Long

-    

-    Range("JUMP") = "LPU_LIST"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-        .Range("ent_date") = ent_date

-    End With

-End Sub

-

-Public Sub SelectREP_QTR(rep_id As Long)

-    Dim vo As Boolean

-    Dim r_id As Long

-    

-    Range("JUMP") = "REP_QTR"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("REP_QTR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateREPList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim rep_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CREP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CREP_AREA).row, CREP_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    rep_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CREP_AREA).Column

-    

-    If i < 4 Then

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 1

-    Else

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 2

-    End If

-    

-    If rep_id = 0 Then

-        Range("LAST_FOCUS") = Range(CREP_AREA).address

-    End If

-

-    If rep_id = 0 Then

-        i = CREP_NAME

-        Range("JUMP") = ""

-    Else

-        btREP_LIST_DO_IT

-    End If

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateREPList()

-    Dim rcd() As tREPID_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-

-    ent_date = getEnt_date

-

-    i = Get_REP_CommonList_by_QTR(rcd, ent_date)

-

-    With ThisWorkbook.Worksheets("REP_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(rcd)

-            r.Offset(i - 1, CREP_NAME) = rcd(i).rep.FirstName & " " & rcd(i).rep.LastName

-            r.Offset(i - 1, CREP_ID) = rcd(i).rep.rep_id

-            r.Offset(i - 1, CREP_BEDS) = rcd(i).qtrs(1).c_beds

-

-            r.Offset(i - 1, CREP_NFG) = rcd(i).qtrs(1).c_bdgt_NFG

-            r.Offset(i - 1, CREP_NMG) = rcd(i).qtrs(1).c_bdgt_NMG

-

-            r.Offset(i - 1, CREP_PLAN) = rcd(i).qtrs(1).qtr.sale_PLAN

-

-            r.Offset(i - 1, CREP_HIR) = rcd(i).qtrs(1).c_pat_HIR

-            r.Offset(i - 1, CREP_TER) = rcd(i).qtrs(1).c_pat_TER

-            r.Offset(i - 1, CREP_CAR) = rcd(i).qtrs(1).c_pat_CRD

-            r.Offset(i - 1, CREP_FACT) = rcd(i).qtrs(1).c_sale_ALL

-            r.Offset(i - 1, CREP_PAT_LPU) = rcd(i).qtrs(1).c_pat_LPU

-            r.Offset(i - 1, CREP_BDGT) = rcd(i).qtrs(1).c_bdgt_LPU

-            If rcd(i).qtrs(1).c_bdgt_LPU > 0 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = rcd(i).qtrs(1).c_sale_ALL / rcd(i).qtrs(1).c_bdgt_LPU

-            End If

-            If r.Offset(i - 1, CREP_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-

-

-<<<<<<
-======================
-mREP_LIST
->>>>>>
-Attribute VB_Name = "mREP_LIST"

-Option Explicit

-

-Public Const CREP_AREA As String = "B12"

-Public Const CREP_NAME As Integer = 0

-Public Const CREP_NAME1 As Integer = 1

-Public Const CREP_NAME2 As Integer = 2

-Public Const CREP_ID As Integer = 3

-Public Const CREP_BEDS As Integer = 4

-Public Const CREP_NFG As Integer = 5

-Public Const CREP_NMG As Integer = 6

-Public Const CREP_HIR As Integer = 7

-Public Const CREP_TER As Integer = 8

-Public Const CREP_CAR As Integer = 9

-Public Const CREP_FACT As Integer = 10

-Public Const CREP_PLAN As Integer = 11

-Public Const CREP_PAT_LPU As Integer = 16

-Public Const CREP_BDGT As Integer = 17

-Public Const CREP_PAT_ALL As Integer = 16

-

-

-

-Sub EditREP(cRep As tREPID, ent_date As String)

-    NoFunc

-End Sub

-

-Sub Rep_Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btREP_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = "RM_QTR"

-    End With

-    ThisWorkbook.Worksheets("RM_QTR").Activate

-End Sub

-

-

-Sub btREP_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim rep_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("REP_LST_DETALS")

-    With Worksheets("REP_LIST")

-        rep_id = .getCurrentREP_ID

-        

-        Select Case i

-            Case 1:

-                .SelectREP_QTR rep_id

-            Case 2:

-                ent_date = .getEnt_date()

-                .SelectREP_LPU rep_id, ent_date

-        End Select

-    End With

-    

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-

-

-

-<<<<<<
-======================
-cdbREP
->>>>>>
-Attribute VB_Name = "cdbREP"

-Option Explicit

-

-Public Type tREPID_COMMON

-    rep As tREPID

-    i_qtrs As Integer

-    qtrs() As tQTR_COMMON

-End Type

-

-Function Get_REP_CommonList_by_QTR(ByRef rcd() As tREPID_COMMON, ent_date As String) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_REP_CommonList_by_QTR = dbGet_REP_CommonList_by_QTR(dbConnection, rcd, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_REP_CommonList_by_QTR(dbConnection As Object, ByRef rcd() As tREPID_COMMON, ent_date As String) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim k As Long

-    Dim allREPID() As tREPID

-    

-    i = dbGetAll_REPID_Records_by_QTR(dbConnection, allREPID, ent_date)

-    dbGet_REP_CommonList_by_QTR = i

-    If i > 0 Then

-        ReDim rcd(i)

-        For i = 1 To UBound(allREPID)

-            rcd(i).rep = allREPID(i)

-            rcd(i).i_qtrs = Get_QTR_CommonList_by_REP(rcd(i).qtrs, ent_date, allREPID(i).rep_id)

-        Next i

-    End If

-End Function

-

-

-

-<<<<<<
-======================
-CHRT_PAT_LPU_A
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU_A"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-cdbRegion
->>>>>>
-Attribute VB_Name = "cdbRegion"

-Option Explicit

-

-Type tREGION

-    ent_date As String

-    total_SALE As Long ' общий объем продаж

-    total_BDGT As Long ' бюджет всех ЛПУ

-    total_BDGT_NMG As Long ' бюджет всех ЛПУ на НМГ

-    total_LPU As Long ' число ЛПУ

-    total_REP   As Long ' число репов

-    total_BEDS As Long ' общее число коек

-    total_HIR As Long '  общее число пациентов на клексане в хирургии

-    total_TER As Long '  общее число пациентов на клексане в терапии

-    total_ACS As Long '  общее число пациентов на клексане в кардиологии

-    sale_PLAN As Long '  план продаж Авентиса

-End Type

-

-Function GetRGN_COMM_DATA(ByRef reg_data() As tREGION) As Integer

-    Dim q_date() As String

-    Dim q_count As Integer, i As Integer

-    

-    q_count = getAllQTRNames(q_date)

-    If q_count > 0 Then

-        ReDim reg_data(q_count)

-        For i = 1 To q_count

-            Dim current_rep_count As Integer

-            current_rep_count = getREGION_by_QTR(q_date(i), reg_data(i))

-        Next i

-    End If

-    

-    GetRGN_COMM_DATA = q_count

-End Function

-

-Function getAllQTRNames(ByRef qtr_lst() As String) As Integer

-    

-    Dim sql As String

-    Dim i As Integer

-    Dim db As Object, rs As Object

-    

-    

-    sql = "SELECT DISTINCT entry_date FROM lpu_budget"

-    i = 0

-    

-    dbOpenConnection db

-    Set rs = CreateObject("ADODB.Recordset")

-    

-    rs.Open sql, db

-        

-        If Not rs.BOF Then

-            Do While Not rs.EOF

-                i = i + 1

-                ReDim Preserve qtr_lst(i)

-                qtr_lst(i) = rs("entry_date")

-                rs.MoveNext

-            Loop

-        Else

-            getAllQTRNames = 0

-            Exit Function

-        End If

-    getAllQTRNames = i

-    dbCloseConnection db

-End Function

-

-Function getREGION_by_QTR(ent_date As String, treg As tREGION) As Integer

-    Dim rep_count As Integer

-    rep_count = 0

-    

-    Dim reps() As tREPID_COMMON

-    rep_count = Get_REP_CommonList_by_QTR(reps, ent_date)

-    

-    treg.ent_date = ent_date

-    treg.total_BDGT = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.total_BDGT_NMG = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.sale_PLAN = 0 ' quarter.sale_plan

-    treg.total_SALE = 0 'summ of

-    ' hir = (amb40+st40)*pr40 + (amb20+st20)*pr20

-    'ter (amb_clx+stat_clx)*price

-    ' acs xxx

-    'price per rep

-    treg.total_HIR = 0 'patiens clxn

-    treg.total_TER = 0 'patiens clxn

-    treg.total_ACS = 0 'patiens clxn

-    treg.total_LPU = 0 'lpu

-    treg.total_BEDS = 0 'lpu.beds

-    treg.total_REP = 0 '

-    

-    If rep_count > 0 Then

-        Dim i As Integer

-        

-        For i = 1 To UBound(reps)

-            ' current rep is reps(i)

-            With reps(i)

-                treg.total_BDGT = treg.total_BDGT + .qtrs(1).c_bdgt_NFG + .qtrs(1).c_bdgt_NMG

-                treg.total_BDGT_NMG = treg.total_BDGT_NMG + .qtrs(1).c_bdgt_NMG

-                treg.sale_PLAN = treg.sale_PLAN + .qtrs(1).c_sale_PLAN

-                treg.total_SALE = treg.total_SALE + .qtrs(1).c_sale_ALL

-                treg.total_HIR = treg.total_HIR + .qtrs(1).c_pat_HIR

-                treg.total_TER = treg.total_TER + .qtrs(1).c_pat_TER

-                treg.total_ACS = treg.total_ACS + .qtrs(1).c_pat_CRD

-                treg.total_LPU = treg.total_LPU + .qtrs(1).i_lcd

-                treg.total_BEDS = treg.total_BEDS + .qtrs(1).c_beds

-                treg.total_REP = treg.total_REP + 1

-            End With

-            

-        Next i

-        

-    End If

-    

-    getREGION_by_QTR = treg.total_REP

-End Function

-

-<<<<<<
-======================
-mRM_QTR
->>>>>>
-Attribute VB_Name = "mRM_QTR"

-Option Explicit

-

-Sub btRM_QTR_Do_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    

-    idx = Worksheets(VAR_SHEET).Range("RM_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            ImportData

-        Case 2

-            Worksheets("REP_LIST").Select

-        Case 3

-            cmExport

-    End Select

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-End Sub

-

-Sub ImportData()

-    Dim i As Integer

-    Dim def_dir As String

-    Dim flist() As String

-    

-    def_dir = GetWBPath(ThisWorkbook.FullName)

-    If GetImportDirectory(def_dir, flist) Then

-        Dim ImpMask() As String

-        ImpMask = Split(flist(1), Chr(95), Compare:=vbBinaryCompare)

-        flist(1) = ImpMask(0) & "*"

-        Dim db_list() As String

-        i = GetDBList(flist(), db_list)

-        If i > 0 Then

-            Merge_BackUp_All_Data

-            MergeGlobal db_list, GetWBPath(ThisWorkbook.FullName) & "clexane-rm.mdb"

-        End If

-    End If

-    Worksheets(RM_QTR_SHEET).update_history

-End Sub

-<<<<<<
-======================
-mImport
->>>>>>
-Attribute VB_Name = "mImport"

-    Option Explicit

-

-Const OFN_ALLOWMULTISELECT As Long = 512

-Const OFN_EXPLORER As Long = 524288

-Const OFN_HIDEREADONLY As Long = 4

-Const OFN_NONETWORKBUTTON As Long = 131072

-Const OFN_READONLY As Long = 1

-       

-Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _

-    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

-

-Private Type OPENFILENAME

-    lStructSize As Long

-    hWndOwner As Long

-    hInstance As Long

-    lpstrFilter As String

-    lpstrCustomFilter As String

-    nMaxCustFilter As Long

-    nFilterIndex As Long

-    lpstrFile As String

-    nMaxFile As Long

-    lpstrFileTitle As String

-    nMaxFileTitle As Long

-    lpstrInitialDir As String

-    lpstrTitle As String

-    flags As Long

-    nFileOffset As Integer

-    nFileExtension As Integer

-    lpstrDefExt As String

-    lCustData As Long

-    lpfnHook As Long

-    lpTemplateName As String

-End Type

-

-Function GetImportDirectory(DB_dir As String, flist() As String) As Boolean

-    Dim OpenFile As OPENFILENAME

-    Dim lReturn As Long

-    Dim sFilter As String

-    

-    OpenFile.lStructSize = Len(OpenFile)

-    '         OpenFile.hwndOwner = Form1.hWnd

-    '         OpenFile.hInstance = App.hInstance

-    sFilter = "Clexane Data Files" & Chr(0) & "mr*.mdb" & Chr(0)

-    OpenFile.lpstrFilter = sFilter

-    OpenFile.nFilterIndex = 1

-    OpenFile.lpstrFile = String(257, 0)

-    OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1

-    OpenFile.lpstrFileTitle = OpenFile.lpstrFile

-    OpenFile.nMaxFileTitle = OpenFile.nMaxFile

-    OpenFile.lpstrInitialDir = DB_dir

-    OpenFile.lpstrTitle = "Импорт данных"

-    OpenFile.flags = OFN_HIDEREADONLY + OFN_EXPLORER

-    lReturn = GetOpenFileName(OpenFile)

-    If lReturn = 0 Then

-        GetImportDirectory = False

-    Else

-        GetImportDirectory = True

-        flist = Split(OpenFile.lpstrFile, Chr(0), Compare:=vbBinaryCompare)

-        Dim i As Integer

-        i = 0

-        Do While flist(i) <> ""

-            i = i + 1

-        Loop

-        If i = 1 Then

-            flist(1) = flist(0)

-            flist(0) = GetWBPath(flist(1))

-            flist(1) = GetWBName(flist(1))

-        Else

-            flist(0) = flist(0) & "\"

-        End If

-    End If

-End Function

-<<<<<<
-Project Name : 'ClexanePM'
-Quirk - duff tag length======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-

-    Application.EnableEvents = True

-    Set MyAppEvents.app = Application

-    

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    

-    MyAppEvents.CheckWorkBooksArround ThisWorkbook

-    

-    cmSetStandaloneMode

-    

-    Application.ScreenUpdating = True

-'    CheckUser

-

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).Select

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).update_history

-    Application.Calculate

-

-End Sub

-

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    

-    Dim RestMode As Boolean

-    RestMode = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE")

-    

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-'        If RestMode Then

-            ThisWorkbook.Saved = True

-'        Else

-'            ThisWorkbook.Save

-'        End If

-    End If

-    If RestMode Then

-        xlRestoreView

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    End If

-    Application.Caption = Empty

-    Application.CommandBars(STDBAR_NAME).Reset

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-    Dim MaxX, MaxY As Integer

-    With ThisWorkbook.Worksheets(TITLE_SHEET)

-        MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-        MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-    End With

-

-    With ThisWorkbook.Application

-        .ScreenUpdating = False

-        .WindowState = xlNormal

-        .Height = MaxY

-        .Width = MaxX

-    End With

-End Sub

-

-

-

-

-

-<<<<<<
-======================
-REP_QTR
->>>>>>
-Attribute VB_Name = "REP_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CQTR_QT As Integer = 0

-Const CQTR_ID As Integer = 1

-Const CQTR_PLN As Integer = 2

-Const CQTR_FCT As Integer = 3

-Const CQTR_BDG As Integer = 4

-Const CQTR_CNT As Integer = 5

-Const CQTR_BEDS As Integer = 6

-Const CQTR_HIR As Integer = 7

-Const CQTR_TER As Integer = 8

-Const CQTR_CRD As Integer = 9

-Const CQTR_CLXN_BDG As Integer = 10

-Const CQTR_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Const LOCAL_ENT_DATE As String = "QTR_SEL"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("REP_QTR")

-        s = .Range("D5") & " " & .Range("D4") & ", " & .Range("H5") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub update_history()

-    Dim objQTR() As tQTR

-    Dim i As Long

-    Dim r As Range

-    Dim cRep As tREPID

-    Dim rm_id As Long

-

-    rm_id = Range("RM_ID")

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    Range("D4") = cRep.LastName

-    Range("D5") = cRep.FirstName

-

-    Range("H4") = GetRegionName(cRep.Region)

-    Range("H5") = GetCityName(cRep.Region, cRep.City)

-

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetAll_QTR_Records_by_REP(objQTR, "%", cRep.rep_id, rm_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CQTR_QT) = objQTR(i).entry_date

-        Next i

-    End If

-    Dim qcd() As tQTR_COMMON

-    i = Get_QTR_CommonList_by_REP(qcd, "%", cRep.rep_id, rm_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(qcd)

-            r.Offset(i - 1, CQTR_QT) = qcd(i).qtr.entry_date

-            r.Offset(i - 1, CQTR_ID) = qcd(i).qtr.id

-            r.Offset(i - 1, CQTR_PLN) = qcd(i).qtr.sale_PLAN

-            r.Offset(i - 1, CQTR_FCT) = qcd(i).c_sale_ALL

-            r.Offset(i - 1, CQTR_BDG) = qcd(i).c_bdgt_LPU

-            r.Offset(i - 1, CQTR_CNT) = qcd(i).i_lcd

-            r.Offset(i - 1, CQTR_BEDS) = qcd(i).c_beds

-            r.Offset(i - 1, CQTR_HIR) = qcd(i).c_pat_HIR

-            r.Offset(i - 1, CQTR_TER) = qcd(i).c_pat_TER

-            r.Offset(i - 1, CQTR_CRD) = qcd(i).c_pat_CRD

-            If qcd(i).c_bdgt_LPU <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_BDG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_LPU

-            End If

-            If qcd(i).c_bdgt_NMG <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_NMG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CQTR_CRD + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-

-Sub Draw_PLN_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_FCT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PLN_QTR").Range("title") = MakeChartTitle

-End Sub

-

-Sub Draw_BDGT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_CLXN_NMG + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_BDGT_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Public Sub cbxRepQtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CQTR_ID + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    i = currRange.Column - Range(CINP_AREA).Column

-

-    QTR_ID = r

-

-    If QTR_ID = 0 Then

-        Worksheets(VAR_SHEET).Range("USER_ACTION") = 1

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        If i > CQTR_FCT Then

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-            Range("LAST_FOCUS") = currRange.address

-        Else

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 3

-            Range("LAST_FOCUS") = currRange.address

-        End If

-    End If

-    Cancel = True

-    btHomeDo_IT

-End Sub

-

-<<<<<<
-======================
-mRep_QTR
->>>>>>
-Attribute VB_Name = "mRep_QTR"

-Option Explicit

-

-Sub NoFunc()

-    MsgBox "Функция не доступна", vbOKOnly, PROGRAM_NAME

-End Sub

-

-Sub DO_Price_qtr(ent_date As String)

-    Dim qtr As tQTR

-    Dim res As Integer

-    Dim cRep As tREPID

-    Dim rm_id As Long

-

-    rm_id = Worksheets(REP_QTR_SHEET).Range("RM_ID")

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    qtr = Get_QTR_Record_by_REP(ent_date, cRep.rep_id, cRep.rm_id)

-

-    If qtr.id = 0 Then

-        qtr.entry_date = ent_date

-

-        With Worksheets(VAR_SHEET)

-            qtr.ClxnH20mg = .Range("ClxnH20mg")

-            qtr.ClxnH40mg = .Range("ClxnH40mg")

-            qtr.ClxnT40mg = .Range("ClxnT40mg")

-            qtr.ClxnC_ACS = .Range("ClxnC_ACS")

-            qtr.ClxnC_IM = .Range("ClxnC_IM")

-        End With

-    End If

-

-    Dim dlg_nq As dlg_nextQTR

-    Set dlg_nq = New dlg_nextQTR

-

-    With dlg_nq

-        .tb_qtr_name = qtr.entry_date

-        .tb_bdgt_avts = qtr.sale_PLAN

-        .tb_qtr_name = qtr.entry_date

-        .tb_ClxnH20mg = qtr.ClxnH20mg

-        .tb_ClxnH40mg = qtr.ClxnH40mg

-        .tb_ClxnT40mg = qtr.ClxnT40mg

-        .tb_ClxnC_ACS = qtr.ClxnC_ACS

-        .tb_ClxnC_IM = qtr.ClxnC_IM

-    End With

-

-    dlg_nq.Show

-End Sub

-

-Sub DO_Edit_qtr(ent_date As String)

-    If ent_date = "" Then

-        NoFunc

-    Else

-        Dim rep_id As Long

-        rep_id = Worksheets(REP_QTR_SHEET).Range("REP_ID")

-        With ThisWorkbook.Worksheets("LPU_LIST")

-            .Range("VIEW_ONLY") = True

-            .setEnt_date (ent_date)

-            .Range("REP_ID") = rep_id

-            .Select

-        End With

-    End If

-End Sub

-

-Sub DO_Delete_qtr(ent_date As String)

-    If ent_date <> "" Then

-        MsgBox "Удалить данные за период [" & ent_date & "] нельзя ", vbOKOnly, PROGRAM_NAME

-    End If

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-

-Sub btHomeDo_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    idx = Worksheets(VAR_SHEET).Range("USER_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).getEnt_date()

-    Select Case idx

-        Case 1

-            NoFunc

-            ' Обновляем экран

-        Case 2

-            DO_Edit_qtr ent_date

-        Case 3

-            DO_Price_qtr ent_date

-        Case 4

-            NoFunc

-    End Select

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-Sub Delete_qtr()

-'    Dim ent_date As String

-'    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-'    DO_Delete_qtr ent_date

-End Sub

-

-Sub btREP_QTR_RET_IT()

-    Dim s As String

-    With Worksheets("REP_QTR")

-        .Range("LAST_FOCUS") = ""

-        s = .Range("ret_addr")

-        .Range("ret_addr") = ""

-    End With

-    If s <> "" Then

-        ThisWorkbook.Worksheets(s).Select

-    Else

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public ppReport As New cPPReport

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane[PM]"

-Public Const PROGRAM_VERSION As String = "Clexane[PM] ver 1.1"

-Public Const PROGRAM_FILENAME As String = "clexane-pm"

-Public Const PROGRAM_BACKUPNAME As String = "pm-backup-"

-Public Const PROGRAM_EXPORTNAME As String = "pm-ex-"

-Public Const PROGRAM_IMPORTNAME As String = "rm-ex*"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-Public Const CHART_DEF_TITLE As String = "* * *"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20031207

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "O41"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-Public Const RM_QTR_SHEET As String = "RM_QTR"

-Public Const PRJ_QTR_SHEET As String = "PRJ_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-Function time_correct(end_date As Long, ByVal theDate As Date) As Boolean

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-    If end_date = NO_ESTIMATION_DATE Then

-        time_correct = True

-        Exit Function

-    End If

-    

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    

-    time_correct = CurDate <= end_date

-    

-End Function

-

-Sub EnableRun(end_date As Long)

-    If Not time_correct(end_date, Now) Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-Sub t()

-    EnableRun ESTIMATION_DATE

-End Sub

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Sub OpenPPT()

-    ppReport.ReportView

-End Sub

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-

-End Sub

-

-Function Double2Str(ByVal d As Double, ByVal precision As Integer, Optional Delim As String = ".") As String

-    Dim s As String

-    If Not precision > 0 Then

-        s = Round(d)

-    Else

-        Dim i As Integer

-        i = Fix(d)

-        s = i & Delim

-        d = Abs(d - i)

-        Do

-            precision = precision - 1

-            d = d * 10

-            If precision > 0 Then

-                i = Fix(d)

-            Else

-                i = Round(d)

-            End If

-            If i < 1 Then

-                s = s & "0"

-            Else

-                s = s & i

-                d = d - i

-            End If

-        Loop While precision > 0

-    End If

-    Double2Str = s

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetWBName(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBName = Right(FullName, s_len - pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.Name = VAR_SHEET Or sh.Name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-<<<<<<
-======================
-Var
->>>>>>
-Attribute VB_Name = "Var"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-title
->>>>>>
-Attribute VB_Name = "title"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LPU_LIST
->>>>>>
-Attribute VB_Name = "LPU_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Const LOCAL_ENT_DATE As String = "C10"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Function getCurrentLPU_ID() As Long

-    Dim r As Range

-

-    With Worksheets("LPU_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CLPU_ID)

-    End With

-

-    getCurrentLPU_ID = r

-End Function

-

-Public Sub LPU_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectLPU_NAME(lpu_id As Long, ent_date As String)

-    SelectLPU_BDGT lpu_id, ent_date

-End Sub

-

-Sub SelectLPU_BDGT(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    If lpu_id = 0 Then

-        SelectLPU_NAME lpu_id, ent_date

-    Else

-        With ThisWorkbook.Worksheets("LPU_BDGT")

-            .Range("VIEW_ONLY") = vo

-            .Range("ret_addr") = "LPU_LIST"

-            .setEnt_date (ent_date)

-            .Range("lpu_id") = lpu_id

-            .Range("REP_ID") = rep_id

-            .Range("RM_ID") = rm_id

-        End With

-    End If

-End Sub

-

-Sub SelectLPU_HIR(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_HIR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .setEnt_date (ent_date)

-        .Range("lpu_id") = lpu_id

-        .Range("REP_ID") = rep_id

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Sub SelectLPU_TER(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_TER")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .setEnt_date (ent_date)

-        .Range("lpu_id") = lpu_id

-        .Range("REP_ID") = rep_id

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Sub SelectLPU_C_ACS(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_C_ACS")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .setEnt_date (ent_date)

-        .Range("RM_ID") = rm_id

-        .Range("REP_ID") = rep_id

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateLPUList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim lpu_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CINP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CINP_AREA).row, CLPU_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    lpu_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CINP_AREA).Column

-

-    If lpu_id = 0 Then

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    End If

-

-    If lpu_id = 0 Then

-        i = CLPU_NAME

-        Range("JUMP") = ""

-    End If

-    Select Case i

-        Case CLPU_NAME, CLPU_NAME1, CLPU_NAME2, CLPU_BEDS

-            SelectLPU_NAME lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-

-        Case CLPU_NMG, CLPU_NFG, CLPU_PLAN, CLPU_FACT

-            SelectLPU_BDGT lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-

-        Case CLPU_HIR

-            SelectLPU_HIR lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_HIR"

-

-        Case CLPU_TER

-            SelectLPU_TER lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_TER"

-

-        Case CLPU_CAR

-            SelectLPU_C_ACS lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        Case Else

-            Range("JUMP") = ""

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateLPUList()

-    Dim lcd() As tLPU_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-    Dim objQTR As tQTR

-    Dim cRep As tREPID

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    ent_date = getEnt_date

-

-'     ent_date = "%" ' % - all records

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id, cRep.rm_id)

-    i = Get_LPU_CommonQTR(lcd, objQTR)

-

-'     стираем ФИО

-    Range("C3:C4").ClearContents

-

-    Range("C3") = cRep.LastName

-    Range("C4") = cRep.FirstName

-    Range("G3") = GetRegionName(cRep.Region)

-    Range("G4") = GetCityName(cRep.Region, cRep.City)

-    Range("G5") = objQTR.sale_PLAN

-

-

-

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(lcd)

-            r.Offset(i - 1, CLPU_NAME) = lcd(i).lpu.Name

-            r.Offset(i - 1, CLPU_ID) = lcd(i).lpu.id

-            r.Offset(i - 1, CLPU_BEDS) = lcd(i).lpu.beds

-

-

-            r.Offset(i - 1, CLPU_NFG) = lcd(i).bdgt.bdgt_NFG

-            r.Offset(i - 1, CLPU_NMG) = lcd(i).bdgt.bdgt_NMG

-            r.Offset(i - 1, CLPU_PLAN) = lcd(i).bdgt.sale_PLAN

-

-            r.Offset(i - 1, CLPU_HIR) = lcd(i).pat_HIR

-            r.Offset(i - 1, CLPU_TER) = lcd(i).pat_TER

-            r.Offset(i - 1, CLPU_CAR) = lcd(i).pat_CRD

-            r.Offset(i - 1, CLPU_FACT) = lcd(i).sale_ALL

-            r.Offset(i - 1, CLPU_PAT_LPU) = lcd(i).pat_LPU

-            r.Offset(i - 1, CLPU_BDGT) = lcd(i).bdgt_LPU

-            If lcd(i).bdgt_LPU > 0 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = lcd(i).sale_ALL / lcd(i).bdgt_LPU

-            End If

-            If r.Offset(i - 1, CLPU_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{32FB0F3D-6884-41DC-99DB-E2C55B2257C4}{DED79A66-DA60-4CCC-9003-082480235D55}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-dbACS
->>>>>>
-Attribute VB_Name = "dbACS"

-Option Explicit

-

-Public Type tACS

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    patients_with_geparins As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objACS.ID <> 0 then updatre else insert

-Sub Insert_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objACS.id <> 0 Then

-        dbUpdate_ACS_Record dbConnection, objACS

-    Else

-        dbInsert_ACS_Record dbConnection, objACS

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_ACS_RecordsByLPU_ID(ByRef all_ACS_() As tACS, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_ACS_RecordsByLPU_ID = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, all_ACS_, lpu_id, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_ACS_Record dbConnection, objACS

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub dbInsert_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_acs", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objACS

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("patients_with_geparins") = .patients_with_geparins

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objACS.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim Update_SQL As String

-    

-    With objACS

-        Update_SQL = "UPDATE lpu_acs SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "patients_with_geparins=" & .patients_with_geparins & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_ACS_RecordsbyLPU_ID(dbConnection As Object, all_ACS() As tACS, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_ACS_SQL As String

-    Dim getAll_ACS_SQL As String

-    Dim ACS_Count As Long

-    ACS_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    Else

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_ACS_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        ACS_Count = dbRecordset("ACS_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_ACS_RecordsbyLPU_ID = ACS_Count

-    

-    If ACS_Count > 0 Then

-        'we have records

-        ReDim all_ACS(1 To ACS_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_ACS_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_ACS As tACS

-                 With tmp_ACS

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .patients_with_geparins = dbRecordset("patients_with_geparins")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 all_ACS(index) = tmp_ACS

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE ID=" & objACS.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_ACS_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_HIR
->>>>>>
-Attribute VB_Name = "LPU_CLSN_HIR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const LOCAL_ENT_DATE As String = "S38"

-

-Sub PrintCopy()

-    Range("A1:M26").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-

-        Dim objHir As tHIRURGIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objHir

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .operations_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L9")

-                .patients_ambulator_clexan_20mg = Range("L10")

-                .patients_ambulator_clexan_40mg = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L19")

-                .patients_stationar_clexan_20mg = Range("L20")

-                .patients_stationar_clexan_40mg = Range("L21")

-            End With

-            Insert_Hir_Record objHir

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objHir.id = Range("rec_id")

-                    If objHir.id <> 0 Then

-                        Delete_Hir_Record objHir

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-End Sub

-

-Sub SetupData(objHir As tHIRURGIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    With objHir

-        Range("rec_id") = .id

-        Range("F6") = .operations_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L9") = .patients_ambulator_clexan

-        Range("L10") = .patients_ambulator_clexan_20mg

-        Range("I21") = .patients_stationar_nmg

-        Range("L19") = .patients_stationar_clexan

-        Range("L20") = .patients_stationar_clexan_20mg

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id, cRep.rm_id)

-

-        formula = "=" & qtr.ClxnH20mg & "*($L$10+$L$20)+" & qtr.ClxnH40mg & "*($L$11+$L$21)"

-        Range("F11").formula = formula

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id, Range("RM_ID"))

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.Name

-        Range("lpu_addr") = lpu.address

-

-        Dim objHir() As tHIRURGIA

-        Dim i As Integer

-        i = GetAll_Hir_RecordsByLPU_ID(objHir, id, Range("ent_date"), Range("RM_ID"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.3

-        Else

-            SetupData objHir(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-mSapes
->>>>>>
-Attribute VB_Name = "mSapes"

-Option Explicit

-

-Const SHAPE_COLOR As Integer = 1

-Const SHAPE_NAME As Integer = 2

-

-

-Sub ShapeView(r_sh_finite_state As Range)

-    Dim chk As Range

-    Dim s As String

-    Dim c, idx As Integer

-    For Each chk In r_sh_finite_state

-        idx = 0

-        If chk = "+" Then

-            c = chk.Offset(0, idx + SHAPE_COLOR)

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While c <> 0

-                ShapeFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s)), c

-                idx = idx + 2

-                c = chk.Offset(0, idx + SHAPE_COLOR)

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        Else

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While s <> ""

-                ShapeUnFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s))

-                idx = idx + 2

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        End If

-    Next chk

-End Sub

-

-Sub ShapeFill(sh As ShapeRange, ByVal color As Integer)

-    sh.Fill.Visible = msoTrue

-    sh.Fill.Solid

-    sh.Fill.ForeColor.SchemeColor = color

-    sh.Fill.Transparency = 0#

-End Sub

-

-Sub ShapeUnFill(sh As ShapeRange)

-    sh.Fill.Visible = msoFalse

-    sh.Fill.Transparency = 0#

-End Sub

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Public Const INPUT_NO = 0

-Public Const INPUT_NUMBER = 1

-Public Const INPUT_PERCENT = 2

-Public Const INPUT_STRING = 3

-Public Const INPUT_CHECK = 4

-

-Public Const INP_IDX_TYPE = 1

-Public Const INP_IDX_NEXT = 2

-Public Const INP_IDX_MIN = 3

-Public Const INP_IDX_MAX = 4

-Public Const INP_IDX_DEP = 5

-Public Const INP_IDX_ALT = 7

-

-

-Public Type tInputSet

-    vType As Integer

-    vMin As Long

-    vMax As Long

-    rChk As String

-End Type

-

-Function is_input_cell(ByVal Target As Range, inputs As Range) As tInputSet

-    Dim t As Range

-    Dim iset As tInputSet

-    Dim test As Range

-    iset.vType = INPUT_NO

-    iset.vMin = 0

-    iset.vMax = 0

-    iset.rChk = ""

-    is_input_cell = iset

-

-' Закоментировать следующую сточку для работы

-'  Exit Function

-

-    Set test = Target.Cells(1, 1)

-    For Each t In inputs

-        If Range(t).Column = test.Column And Range(t).row = test.row Then

-            iset.vType = t.Offset(0, INP_IDX_TYPE).Value

-            Select Case iset.vType

-                Case INPUT_CHECK

-                    iset.rChk = t.Offset(0, INP_IDX_ALT)

-                Case INPUT_NUMBER, INPUT_PERCENT

-                    iset.vMin = t.Offset(0, INP_IDX_MIN).Value

-                    iset.vMax = t.Offset(0, INP_IDX_MAX).Value

-            End Select

-            is_input_cell = iset

-            Exit Function

-        End If

-    Next t

-End Function

-

-Function GetFocusAddress(ByVal r As Range, f_next As Range) As String

-    Dim chk, t As Range

-    

-    For Each chk In f_next

-        For Each t In r

-            If t.address = chk Then

-                GetFocusAddress = chk

-                Exit Function

-            End If

-            If Range(chk).Column = t.Column - 1 And Range(chk).row = t.row _

-            Or Range(chk).Column = t.Column And Range(chk).row = t.row - 1 _

-            Then

-                If Range(chk) <> "" Then

-                    If Range(chk) = 0 Then

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_ALT)).address

-                    Else

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_NEXT)).address

-                    End If

-                Else

-                    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-                End If

-                Exit Function

-            End If

-        Next t

-    Next chk

-    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-End Function

-

-Sub SetDependet(r As Range, inputs As Range)

-    Dim chk As Range

-    Dim s, serr As String

-    Dim idx As Integer

-    Dim iset As tInputSet

-    Dim err_found As Boolean

-    

-    If r.count > 1 Then

-        Exit Sub

-    End If

-    

-    err_found = False

-    For Each chk In inputs

-        idx = INP_IDX_DEP

-        

-        

-        iset.vType = chk.Offset(0, INP_IDX_TYPE).Value

-        Select Case iset.vType

-            Case INPUT_NUMBER, INPUT_PERCENT

-                iset.vMin = chk.Offset(0, INP_IDX_MIN).Value

-                iset.vMax = chk.Offset(0, INP_IDX_MAX).Value

-                

-                If Range(chk) > iset.vMax Then

-                    err_found = True

-                    Range(chk) = iset.vMax

-                    serr = "Выход за дозволенный диапазон [" & iset.vMin & ".." & iset.vMax & "]! Данные скорректированы."

-                End If

-                

-                If Range(chk) = "" Then

-                    s = chk.Offset(0, idx)

-                    Do While s <> ""

-                        Range(s) = ""

-                        idx = idx + 1

-                        s = chk.Offset(0, idx)

-                    Loop

-                End If

-        End Select

-    Next chk

-    If err_found Then

-        MsgBox serr, vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Function CheckInputData(inputs As Range) As Boolean

-    Dim r As Range

-    

-    CheckInputData = True

-    For Each r In inputs

-        If Range(r) = "" Then

-            CheckInputData = False

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100.", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Sub Check_Int_Number(Target As Range, Def_Val As Long)

-    Dim err As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    err = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                err = True

-            End If

-        End If

-    Next r

-    If err Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_TER
->>>>>>
-Attribute VB_Name = "LPU_CLSN_TER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const LOCAL_ENT_DATE As String = "S38"

-

-Sub PrintCopy()

-    Range("A1:M26").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim objTer As tTERAPIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objTer

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .patients_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L20")

-            End With

-            Insert_Ter_Record objTer

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objTer.id = Range("rec_id")

-                    If objTer.id <> 0 Then

-                        Delete_Ter_Record objTer

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-

-End Sub

-

-Sub SetupData(objTer As tTERAPIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    With objTer

-        Range("rec_id") = .id

-        Range("F6") = .patients_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L11") = .patients_ambulator_clexan

-        Range("I21") = .patients_stationar_nmg

-        Range("L20") = .patients_stationar_clexan

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id, cRep.rm_id)

-        formula = "=" & qtr.ClxnT40mg & "*($L$12+$L$20)"

-        Range("F11").formula = formula

-

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id, Range("RM_ID"))

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.Name

-        Range("lpu_addr") = lpu.address

-

-        Dim objTer() As tTERAPIA

-        Dim i As Integer

-        i = GetAll_Ter_RecordsByLPU_ID(objTer, id, Range("ent_date"), Range("RM_ID"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.25

-        Else

-            SetupData objTer(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{0DC9E035-CE0A-49FF-85A2-A4EC5FF8FE96}{D54DDC8A-1EE2-4BB3-8B94-343B521AF098}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-LPU_BDGT
->>>>>>
-Attribute VB_Name = "LPU_BDGT"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const LOCAL_ENT_DATE As String = "S15"

-

-Sub PrintCopy()

-    Range("B1:K21").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Sub SetDefFocus()

-    Range(Range("DEF_FOCUS")).Select

-End Sub

-

-Public Sub ClearData()

-    ClearSheetData

-End Sub

-

-Sub ClearSheetData()

-    If Range("F10") = 0 And Range("F13") = 0 Then

-        Range("F11:F18") = ""

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("F11:F13") = ""

-    End If

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim bdgt As tBUDGET

-        Dim sum As Long

-        Dim test As Boolean

-        With bdgt

-            .lpu_id = Range("lpu_id")

-            .id = Range("rec_id")

-            .entry_date = Range("ent_date")

-            .bdgt_NMG = Round(Range("F11").Value, 0)

-            .bdgt_NFG = Round(Range("F12").Value, 0)

-            .sale_PLAN = Round(Range("F13").Value, 0)

-

-            sum = .bdgt_NFG + .bdgt_NMG - .sale_PLAN

-            test = .bdgt_NFG <> 0 Or .bdgt_NMG <> 0 Or .sale_PLAN <> 0

-        End With

-        If test Then

-            If sum < 0 Then

-                MsgBox _

-                    "Ваш план превышает выделенный на гепарины бюджет. Сохранить данные?", _

-                    vbOKOnly, PROGRAM_NAME

-            End If

-            If test Then

-                Insert_BDGT_Record bdgt

-            End If

-        Else

-            If bdgt.id <> 0 Then

-                If vbYes = MsgBox("Удалить данные из базы!", vbYesNo, PROGRAM_NAME) Then

-                    Delete_BDGT_Record bdgt

-                End If

-                ret_back Range("DEF_FOCUS").Worksheet

-                Exit Sub

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-    End If

-

-   ClearData

-   ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(cLPU As tLPU_COMMON)

-    Dim t_sum As Long

-    t_sum = 0

-' Setup budget data

-    Range("F11") = cLPU.bdgt.bdgt_NMG

-    Range("F12") = cLPU.bdgt.bdgt_NFG

-    Range("F13") = cLPU.bdgt.sale_PLAN

-

-    With cLPU

-        Range("F14") = .pat_ALL

-        Range("F15") = .pat_HIR

-        Range("F16") = .pat_TER

-        Range("F17") = .pat_CRD

-        Range("F18") = .sale_ALL

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    ws_activate

-End Sub

-

-

-Sub ws_activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Dim cLPU As tLPU_COMMON

-    Dim objQTR As tQTR

-    Dim objLPU As tLPU

-    Dim ent_date As String

-    Dim id As Long

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"), Range("RM_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    id = Range("lpu_id").Value

-    ent_date = Range("ent_date")

-    

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id, cRep.rm_id)

-

-    objLPU = Get_LPU_Record(id, Range("RM_ID"))

-    Get_LPU_Common cLPU, objLPU, objQTR

-

-    If cLPU.lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = cLPU.lpu.beds

-        Range("lpu_name") = cLPU.lpu.Name

-        Range("lpu_addr") = cLPU.lpu.address

-        Range("rec_id") = cLPU.bdgt.id

-

-        SetupData cLPU

-

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-'    MsgBox Target.address

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case INPUT_CHECK

-

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{BFB4547C-96A7-4739-AA0A-CEF1E35E2BDC}{C3D618A3-9410-4BC7-9D93-3B049D361132}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mSheets
->>>>>>
-Attribute VB_Name = "mSheets"

-Option Explicit

-

-Function am_load_now() As Boolean

-    am_load_now = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE")

-End Function

-

-Sub Wks_select(RetSheet As String)

-    Dim sheet As Worksheet

-    For Each sheet In ThisWorkbook.Worksheets

-        If sheet.Name = RetSheet Then

-            ThisWorkbook.Worksheets(RetSheet).Select

-            Exit Sub

-        End If

-    Next sheet

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub ret_back(sh As Worksheet)

-    Dim RetSheet As String

-    RetSheet = sh.Range("ret_addr")

-    sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    sh.Range("rec_id") = ""

-    sh.Range("lpu_id") = ""

-    sh.Range("ent_date") = ""

-    sh.Range("lpu_name") = ""

-    sh.Range("lpu_addr") = ""

-    sh.Range("lpu_beds") = ""

-    Wks_select RetSheet

-    sh.Range("ret_addr") = ""

-End Sub

-

-Sub ClearSheetData(r_start As Range)

-    If r_start <> "" Then

-        r_start.Worksheet.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        r_start = ""

-    Else

-        ret_back r_start.Worksheet

-    End If

-End Sub

-

-Sub wks_sel_chng(iset As tInputSet, ByVal Target As Range, sh As Worksheet)

-    Dim DebugMode As Boolean

-    Dim in_range As Range

-    

-    DebugMode = Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-

-    If DebugMode Then

-        sh.Unprotect

-    Else

-        sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    End If

-

-    If iset.vType = INPUT_CHECK Then

-        Set in_range = Target.Worksheet.Range(iset.rChk)

-    Else

-        Set in_range = Target

-    End If

-    

-    Dim str As String

-    str = GetFocusAddress(in_range, sh.Range("h_inputs"))

-

-'    MsgBox Target.Address & "; " & str

-    If str <> Target.address Then

-        sh.Range(str).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-Dlg_lpu_card
->>>>>>
-Attribute VB_Name = "Dlg_lpu_card"

-Attribute VB_Base = "0{9AAD262F-A6C4-4912-9C58-D7A2071181B8}{9470F4EB-DA9F-4584-9159-D09319548D21}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbLPU_List_Change()

-    Dim src As Range

-    Dim idx_src As Integer

-    

-    Set src = Worksheets(VAR_SHEET).Range(Me.cbLPU_List.RowSource)

-    idx_src = Me.cbLPU_List.ListIndex + 1

-    Me.tb_lpu_name.Text = src.Cells(idx_src, 1)

-    Me.tb_lpu_address.Text = src.Cells(idx_src, 2)

-    Me.tbBedsCount.Text = src.Cells(idx_src, 3)

-End Sub

-

-

-Private Sub cbxLPU_List_Enable_Click()

-    

-    If Me.cbxLPU_List_Enable Then

-        

-        Me.tb_lpu_name.Text = ""

-        Me.tb_lpu_name.Enabled = False

-        

-        Me.tb_lpu_address.Text = ""

-        Me.tb_lpu_address.Enabled = False

-        

-        Me.tbBedsCount.Text = ""

-        Me.tbBedsCount.Enabled = False

-        

-        Me.cbLPU_List.Enabled = True

-        cbLPU_List_Change

-    Else

-        Me.tb_lpu_name.Enabled = True

-        Me.tb_lpu_name.Text = ""

-        

-        Me.tb_lpu_address.Enabled = True

-        Me.tb_lpu_address.Text = ""

-        

-        Me.tbBedsCount.Enabled = True

-        Me.tbBedsCount.Text = ""

-        

-        Me.cbLPU_List.Enabled = False

-    End If

-End Sub

-

-<<<<<<
-======================
-UserInfo
->>>>>>
-Attribute VB_Name = "UserInfo"

-Attribute VB_Base = "0{A8FBEE9C-DE59-49DE-971D-07BC9C0E9BD2}{C712732B-D8E4-4C2D-8E78-AC90968E0CD7}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Tag = vbOK

-End Sub

-

-Private Sub cbCity_Change()

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_CITY") = Me.cbCity.ListIndex

-        .Calculate

-    End With

-End Sub

-

-Private Sub cbRegion_Change()

-    Dim LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        NewRangeOffsetCol = cbRegion.Value * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .Name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).address

-        NewSumRange = .Name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).address

-        .Calculate

-        .Range("IDX_CITY") = 0

-        cbCity.RowSource = NewCbxRange

-

-    End With

-    cbCity.ListIndex = 0

-End Sub

-

-<<<<<<
-======================
-mREGMAN
->>>>>>
-Attribute VB_Name = "mREGMAN"

-Option Explicit

-

-Sub hw_reset()

-    Dim rs As Range

-    Dim re As Object

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    HWReset

-    With Application

-        .DisplayAlerts = False

-        .Quit

-    End With

-End Sub

-

-Sub CheckUser()

-    If Range("HW_Number") = "" Then

-        StoreHWInfo

-    End If

-    If CheckHWInfo <> True Then

-        MsgBox "2"

-        cmAbout

-'        With Application

-'            .DisplayAlerts = False

-'            .Quit

-'        End With

-    Else

-        SetupUser

-    End If

-End Sub

-

-

-Sub SetupUser()

-'    Dim cREGMAN As tREGMAN

-'    Dim idx As Integer

-'    Dim dlg_ui As UserInfo

-'

-'    Set dlg_ui = New UserInfo

-'

-'    cREGMAN = Get_REGMAN_Record()

-'

-'    With ThisWorkbook.Worksheets(REGS_SHEET)

-'        .Range("IDX_REGION") = cREGMAN.Region

-'        .Range("IDX_CITY") = cREGMAN.City

-'    End With

-'

-'    With dlg_ui

-'        .cbRegion = cREGMAN.Region

-'        .cbCity = cREGMAN.City

-'        .tbFName = cREGMAN.FirstName

-'        .tbLName = cREGMAN.LastName

-'    End With

-'

-'    dlg_ui.Show

-'    Worksheets(REGS_SHEET).Calculate

-'

-'    If dlg_ui.Tag = vbOK Then

-'        With cREGMAN

-'            .Region = dlg_ui.cbRegion.Value

-'            .City = dlg_ui.cbCity.Value

-'            .FirstName = dlg_ui.tbFName.Value

-'            .LastName = dlg_ui.tbLName.Value

-'        End With

-'        Set_REGMAN_Record cREGMAN

-'    Else

-'        cmAbout

-'        With Application

-'            .DisplayAlerts = False

-'            .Quit

-'        End With

-'    End If

-End Sub

-

-Sub StoreHWInfo()

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim objHW() As Long

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    Set r = Range("HW_Number")

-    i = 1

-    For Each d In dc

-        If d.drivetype = 2 Then

-            r = d.SerialNumber

-            Set r = r.Offset(1, 0)

-            ReDim Preserve objHW(i)

-            objHW(i) = d.SerialNumber

-            i = i + 1

-        End If

-    Next

-    

-    UpdateHWRecords objHW

-End Sub

-

-Function CheckHWInfo()

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim objHW() As Long

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    

-    CheckHWInfo = False

-    

-    i = GetHWRecords(objHW)

-    If i = 0 And Range("HW_Number") <> 0 Then

-        Exit Function

-    End If

-    For Each d In dc

-        If d.drivetype = 2 Then

-            Set r = Range("HW_Number")

-            Do While r <> ""

-                If r = d.SerialNumber Then

-                    For i = 1 To UBound(objHW)

-                        If d.SerialNumber = objHW(i) Then

-                            CheckHWInfo = True

-                            Exit Function

-                        End If

-                    Next i

-                End If

-                Set r = r.Offset(1, 0)

-            Loop

-        End If

-    Next

-End Function

-<<<<<<
-======================
-dbBudget
->>>>>>
-Attribute VB_Name = "dbBudget"

-Option Explicit

-

-Public Type tBUDGET

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    rm_id As Long

-    bdgt_NMG As Long

-    bdgt_NFG As Long

-    sale_PLAN As Long

-End Type

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function GetAll_BDGT_RecordsByLPU_ID(ByRef allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_BDGT_RecordsByLPU_ID = dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection, allBDGT, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function Get_BDGT_Record(ByVal lpu_id As Long, ByVal ent_date As String, rm_id As Long) As tBUDGET

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    Get_BDGT_Record = dbGet_BDGT_Record(dbConnection, lpu_id, ent_date, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-' if objBDGT.ID <> 0 then updatre else insert

-Public Sub Insert_BDGT_Record(objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    If objBDGT.id <> 0 Then

-        dbUpdate_BDGT_Record dbConnection, objBDGT

-    Else

-        dbInsert_BDGT_Record dbConnection, objBDGT

-    End If

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Public Sub Delete_BDGT_Record(ByRef objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    dbDelete_BDGT_Record dbConnection, objBDGT

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_BDGT_Record(dbConnection As Object, ByVal lpu_id As Long, ent_date As String, rm_id As Long) As tBUDGET

-    

-    Dim sql As String

-    Dim objBDGT As tBUDGET

-    

-    With objBDGT

-        .id = 0

-        .lpu_id = lpu_id

-        .rm_id = rm_id

-        .entry_date = ent_date

-        .bdgt_NMG = 0

-        .bdgt_NFG = 0

-        .sale_PLAN = 0

-    End With

-        

-    

-    sql = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        With objBDGT

-            .entry_date = dbRecordset("entry_date")

-            .id = dbRecordset("id")

-            .lpu_id = dbRecordset("lpu_id")

-            .bdgt_NFG = dbRecordset("bdgt_NFG")

-            .bdgt_NMG = dbRecordset("bdgt_NMG")

-            .sale_PLAN = dbRecordset("sale_PLAN")

-        End With

-    End If

-    

-    dbGet_BDGT_Record = objBDGT

-End Function

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection As Object, allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_BDGT_SQL As String

-    Dim getAll_BDGT_SQL As String

-    Dim BDGT_Count As Long

-    BDGT_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_BDGT_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        BDGT_Count = dbRecordset("BDGT_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_BDGT_RecordsbyLPU_ID = BDGT_Count

-    

-    If BDGT_Count > 0 Then

-        'we have records

-        ReDim allBDGT(1 To BDGT_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_BDGT_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpBDGT As tBUDGET

-                 With tmpBDGT

-                    .entry_date = dbRecordset("entry_date")

-                    .id = dbRecordset("id")

-                    .lpu_id = dbRecordset("lpu_id")

-                    .bdgt_NFG = dbRecordset("bdgt_NFG")

-                    .bdgt_NMG = dbRecordset("bdgt_NMG")

-                    .sale_PLAN = dbRecordset("sale_PLAN")

-                 End With

-                 

-                 allBDGT(index) = tmpBDGT

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbInsert_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "lpu_budget", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    dbRecordset("entry_date") = objBDGT.entry_date

-    dbRecordset("lpu_id") = objBDGT.lpu_id

-    dbRecordset("bdgt_NMG") = objBDGT.bdgt_NMG

-    dbRecordset("bdgt_NFG") = objBDGT.bdgt_NFG

-    dbRecordset("sale_PLAN") = objBDGT.sale_PLAN

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objBDGT.id = dbRecordset("id")

-  

-End Sub

-

-Public Sub dbUpdate_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu_budget SET " & _

-    "entry_date='" & objBDGT.entry_date & "'," & _

-    "lpu_id=" & objBDGT.lpu_id & "," & _

-    "bdgt_NMG=" & objBDGT.bdgt_NMG & "," & _

-    "bdgt_NFG=" & objBDGT.bdgt_NFG & "," & _

-    "sale_PLAN=" & objBDGT.sale_PLAN & _

-    " WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-Public Sub dbDelete_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_BDGT_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbDatabase
->>>>>>
-Attribute VB_Name = "dbDatabase"

-Option Explicit

-

-

-Sub dbOpenConnection(dbConnection As Object)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-<<<<<<
-======================
-dbLPU
->>>>>>
-Attribute VB_Name = "dbLPU"

-Option Explicit

-

-Public Type tLPU

-    id As Long

-    rep_id As Long

-    rm_id As Long

-    Name As String

-    address As String

-    beds As Integer

-End Type

-

-Function Get_LPU_Record(ByVal lpu_id As Long, rm_id As Long) As tLPU

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_LPU_Record = dbGet_LPU_Record(dbConnection, lpu_id, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_LPU_byQTR(allLPU() As tLPU, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_LPU_byQTR = dbGetAll_LPU_byQTR(dbConnection, allLPU, ent_date, rep_id, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_Record(dbConnection As Object, ByVal lpu_id As Long, rm_id As Long) As tLPU

-    

-    Dim sql As String

-    Dim objLPU As tLPU

-    

-    objLPU.id = lpu_id

-    objLPU.Name = ""

-    objLPU.address = ""

-    

-    sql = "SELECT * FROM lpu WHERE id=" & lpu_id & " AND rm_id=" & rm_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objLPU.Name = dbRecordset("name")

-        objLPU.address = dbRecordset("address")

-        objLPU.rep_id = dbRecordset("rep_id")

-        objLPU.rm_id = dbRecordset("rm_id")

-        objLPU.beds = dbRecordset("beds")

-    End If

-    

-    dbGet_LPU_Record = objLPU

-

-End Function

-

-Function dbGetAll_LPU_byQTR(dbConnection As Object, allLPU() As tLPU, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    Dim Where As String

-    Where = "WHERE lpu_budget.entry_date like '" & ent_date & "'" & " AND lpu.id=lpu_budget.lpu_id " & _

-    "AND lpu.rep_id=" & rep_id & " AND lpu.rm_id=lpu_budget.rm_id AND lpu.rm_id=" & rm_id

-

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu_budget, lpu " & Where

-    

-    getAll_LPU_SQL = "SELECT lpu.id as id, lpu.rep_id as rep_id, lpu.name as name, lpu.address as address, lpu.beds AS beds, lpu.rm_id AS rm_id " & _

-    "FROM lpu, lpu_budget " & Where

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_LPU_byQTR = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .Name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-dbREP
->>>>>>
-Attribute VB_Name = "dbREP"

-'Option Explicit

-'

-'Public Type tREP

-'    FirstName As String

-'    LastName As String

-'    Region As Integer

-'    City As Integer

-'End Type

-'

-'Function GetREPRecord() As tREP

-'    Dim dbConnection As Object

-'

-'    dbOpenConnection dbConnection

-'    GetREPRecord = dbGetREPRecord(dbConnection)

-'    dbCloseConnection dbConnection

-'End Function

-'

-'Sub SetREPRecord(cUser As tREP)

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbSetREPRecord dbConnection, cUser

-'    dbCloseConnection dbConnection

-'End Sub

-'

-'Public Function dbGetREPRecord(dbConnection As Object) As tREP

-'

-'    Dim SQL As String

-'    Dim objREP As tREP

-'

-'    objREP.FirstName = ""

-'    objREP.LastName = ""

-'    objREP.Region = 0

-'    objREP.City = 0

-'    SQL = "SELECT firstname, lastname, region, city FROM " & _

-'          "rep"

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open SQL, dbConnection

-'    ', 3, 3

-'    If Not dbRecordset.BOF Then

-'

-'        objREP.FirstName = dbRecordset("firstname")

-'        objREP.LastName = dbRecordset("lastname")

-'        objREP.Region = dbRecordset("region")

-'        objREP.City = dbRecordset("city")

-'

-'    End If

-'

-'    dbGetREPRecord = objREP

-'

-'End Function

-'

-'Public Sub dbSetREPRecord(dbConnection As Object, ByRef objREP As tREP)

-'

-'    Dim DeleteSQL As String

-'    Dim InsertSQL As String

-'

-'    DeleteSQL = "DELETE FROM rep"

-'    InsertSQL = "INSERT INTO rep (firstname, lastname, region, city) VALUES (" & _

-'    "'" & objREP.FirstName & "', " & _

-'    "'" & objREP.LastName & "', " & _

-'    objREP.Region & ", " & _

-'    objREP.City & ")"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-'

-'End Sub

-'

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    CheckWorkBooksArround Wb

-End Sub

-

-

-Sub CheckWorkBooksArround(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If app.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEL сейчас будут закрыты!", vbOKOnly, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub GetState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-        ActiveWorkbook.DisplayDrawingObjects = xlDisplayShapes

-        

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.Name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars(STDBAR_NAME).Visible = False

-End Sub

-

-

-Public Sub RestoreState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars(STDBAR_NAME).Visible = True

-End Sub

-

-

-

-<<<<<<
-======================
-cdbRM
->>>>>>
-Attribute VB_Name = "cdbRM"

-Option Explicit

-

-Public Type tRMID_COMMON

-    rm As tREGMAN

-    rgcd_count As Integer

-    rgcd() As tREGION

-End Type

-

-Function Get_RM_CommonList_by_QTR(ByRef rmcd() As tRMID_COMMON, ent_date As String) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_RM_CommonList_by_QTR = dbGet_RM_CommonList_by_QTR(dbConnection, rmcd(), ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_RM_CommonList_by_QTR(dbConnection As Object, ByRef rmcd() As tRMID_COMMON, ent_date As String) As Integer

-    ' Получить список RM-ов

-    Dim count As Integer

-    count = db_get_All_RM_by_QTR(dbConnection, rmcd(), ent_date)

-    

-    Dim i As Integer

-    For i = 1 To count

-        rmcd(i).rgcd_count = 1

-        ReDim rmcd(i).rgcd(1 To 1)

-        getREGION_by_QTR ent_date, rmcd(i).rgcd(1), rmcd(i).rm.rm_id

-    Next i

-    dbGet_RM_CommonList_by_QTR = count

-End Function

-

-Function db_get_All_RM_by_QTR(dbConnection As Object, rmcd() As tRMID_COMMON, ent_date As String) As Integer

-    

-    Dim count_sql As String

-    Dim get_sql As String

-    Dim rs As Object

-    Dim RM_Count As Integer

-        

-    count_sql = "SELECT COUNT(*) AS RM_TOTAL FROM reg_man"

-    get_sql = "SELECT * FROM reg_man"

-    Set rs = CreateObject("ADODB.Recordset")

-    rs.Open count_sql, dbConnection

-    

-    If Not rs.BOF Then

-        RM_Count = rs("RM_TOTAL")

-    End If

-    

-    rs.Close

-    

-     db_get_All_RM_by_QTR = RM_Count

-    

-    If RM_Count > 0 Then

-        'we have records

-        ReDim rmcd(1 To RM_Count)

-        Dim index As Long

-        index = 1

-        rs.Open get_sql, dbConnection

-        

-        If Not rs.BOF Then

-             Do While Not rs.EOF

-                 Dim tmp_rmcd As tRMID_COMMON

-                 With tmp_rmcd

-                    .rgcd_count = 0

-                    .rm.City = rs("city")

-                    .rm.FirstName = rs("firstname")

-                    .rm.LastName = rs("lastname")

-                    .rm.rm_id = rs("mgr_id")

-                    .rm.Region = rs("region")

-                 End With

-                 

-                 rmcd(index) = tmp_rmcd

-                 index = index + 1

-                 rs.MoveNext

-             Loop

-        End If

-    End If

-    

-End Function

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Public Const STDBAR_NAME = "Worksheet Menu Bar"

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Import data"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmDataImport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-             With .Add(msoControlPopup)

-                .Caption = "&Report"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&New Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 18

-                        .OnAction = "cmNewReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Open Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmOpenReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Close && Save"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseReport"

-                    End With

-                End With

-            End With

-           With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Exit && Restore Excel"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 548

-                        .OnAction = "cmExitRestore"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-        End With

-    End With

-End Sub

-

-Sub CreateExtCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom extendet commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Import data"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmDataImport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-             With .Add(msoControlPopup)

-                .Caption = "&Report"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&New Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 18

-                        .OnAction = "cmNewReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Open Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmOpenReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Close && Save"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseReport"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Add New Slide"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 280

-                .OnAction = "cmAddSlide"

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(flag As Boolean)

-    If flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars(STDBAR_NAME)

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmExport()

-    dbExport

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    Dim dlg As dlgAbout

-    Set dlg = New dlgAbout

-    

-    dlg.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlg.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlg.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlg.Show

-End Sub

-

-Sub cmMail2Support()

-    Dim err_description As String

-    Dim dlg_msg As dlg_Mail

-    Set dlg_msg = New dlg_Mail

-    With dlg_msg

-        .Show

-        If .Tag = vbOK Then

-            ThisWorkbook.Worksheets(VAR_SHEET).Range("ERR_MESSAGE") _

-                = .tbMessage.Text

-            ThisWorkbook.Save

-            ThisWorkbook.SendMail Recipients:="infra@i-rs.ru", Subject:=PROGRAM_NAME & " ver.:" & PROGRAM_VERSION

-            MsgBox "Сообщение об ошибке отправлено. Перезагрузите программу.", vbOKOnly, PROGRAM_NAME

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-    End With

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-'        helppath = "hh.exe " & .Path & "\Telfast.chm"

-'        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub set_work_mode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-End Sub

-

-Sub cmSetStandaloneMode()

-    set_work_mode

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    Dim dlg As dlgGetPwd

-    rp = common_pwd

-    

-    Set dlg = New dlgGetPwd

-    dlg.edPwd = ""

-    dlg.Show

-    

-    If dlg.edPwd = rp Then

-        Application.ScreenUpdating = False

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-        xlRestoreView

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-        Application.ScreenUpdating = True

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmNewReport()

-    ppReport.CreateReport

-    MsgBox "Новый отчет создан", vbInformation + vbOKOnly, PROGRAM_NAME

-    CreateExtCommandBar theApp:=ThisWorkbook.Application

-End Sub

-

-Sub cmOpenReport()

-    Dim fileToOpen

-    Dim s As String

-    fileToOpen = Application _

-        .GetOpenFileName("Report Files (*.ppt), *.ppt", title:="Report OPen", MultiSelect:=False)

-    If fileToOpen <> False Then

-        s = fileToOpen

-        ppReport.OpenReport s

-        CreateExtCommandBar theApp:=ThisWorkbook.Application

-    End If

-End Sub

-

-Sub cmCloseReport()

-    On Error Resume Next

-    ppReport.SaveReport

-    CreateCommandBar theApp:=ThisWorkbook.Application

-End Sub

-

-Sub cmAddSlide()

-    ThisWorkbook.ActiveSheet.PrintCopy

-    ppReport.InsertSlide

-End Sub

-

-Sub cmHomePage()

-    ThisWorkbook.Worksheets("PRJ_QTR").Select

-End Sub

-

-Sub cmExitRestore()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = True

-    Application.Quit

-End Sub

-

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    Dim dlg_prn As dlgPrint

-    

-    Set dlg_prn = New dlgPrint

-    

-    With dlg_prn

-        .cbMainReport = True

-        .cbMainBudget = False

-        .cbSrcData = False

-        .cbAllSheets = False

-    

-        .Show

-    

-        If .Tag = vbCancel Then

-            Exit Sub

-        End If

-    End With

-    

-    Dim PrnIdx As Integer

-    

-    With dlg_prn

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("REP_QTR", "budget", "Final")

-    Case 1111

-        plist = Array("REP_QTR", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("REP_QTR")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Clexane bar"

-Public Const common_pwd As String = "crdjhxtyjr"

-

-

-Sub SetEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    With Application

-        .Caption = PROGRAM_NAME

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .GetState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = False

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Unprotect

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    If cWindow.Type = xlWorkbook Then

-                        cWindow.DisplayHeadings = True

-                    End If

-                Next

-            End If

-        Next

-        If DesignMode Then

-            SetupDesignMenu True

-        End If

-        With mobjAppState

-            .RestoreState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Option Explicit

-

-Sub UpdateHWRecords(objHW() As Long)

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    dbUpdateHWRecords dbConnection, objHW

-    dbCloseConnection dbConnection

-End Sub

-

-Function GetHWRecords(objHW() As Long) As Integer

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    GetHWRecords = dbGetHWRecords(dbConnection, objHW)

-    dbCloseConnection dbConnection

-End Function

-

-Sub HWReset()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbInsertHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    

-    Dim dbRecordset As Object

-    Dim i As Long

-    

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "hw", dbConnection, 2, 2

-    

-    For i = 1 To UBound(objHW)

-        dbRecordset.addnew

-        dbRecordset("num") = objHW(i)

-        dbRecordset.Update

-    Next i

-    

-End Sub

-

-Sub dbUpdateHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    dbDeleteHWRecord dbConnection

-    dbInsertHWRecords dbConnection, objHW

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-dbHir
->>>>>>
-Attribute VB_Name = "dbHir"

-Option Explicit

-

-Public Type tHIRURGIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    operations_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_ambulator_clexan_40mg As Integer

-    patients_ambulator_clexan_20mg As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-    patients_stationar_clexan_40mg As Integer

-    patients_stationar_clexan_20mg As Integer

-End Type

-

-' if objHir.ID <> 0 then updatre else insert

-Sub Insert_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objHir.id <> 0 Then

-        dbUpdate_Hir_Record dbConnection, objHir

-    Else

-        dbInsert_Hir_Record dbConnection, objHir

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Hir_RecordsByLPU_ID(ByRef allHir() As tHIRURGIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Hir_RecordsByLPU_ID = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, allHir, lpu_id, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Hir_Record dbConnection, objHir

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objHir.ID <> 0 then updatre else insert

-

-Sub dbInsert_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_hir", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objHir

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("operations_per_quarter") = .operations_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_ambulator_clexan_20mg") = .patients_ambulator_clexan_20mg

-        dbRecordset("patients_ambulator_clexan_40mg") = .patients_ambulator_clexan_40mg

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-        dbRecordset("patients_stationar_clexan_20mg") = .patients_stationar_clexan_20mg

-        dbRecordset("patients_stationar_clexan_40mg") = .patients_stationar_clexan_40mg

-        

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objHir.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim UpdateSQL As String

-    

-    With objHir

-        UpdateSQL = "UPDATE lpu_hir SET " & _

-            "entry_date='" & objHir.entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "operations_per_quarter=" & .operations_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_ambulator_clexan_20mg=" & .patients_ambulator_clexan_20mg & "," & _

-            "patients_ambulator_clexan_40mg=" & .patients_ambulator_clexan_40mg & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & "," & _

-            "patients_stationar_clexan_20mg=" & .patients_stationar_clexan_20mg & "," & _

-            "patients_stationar_clexan_40mg=" & .patients_stationar_clexan_40mg & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_Hir_RecordsbyLPU_ID(dbConnection As Object, allHir() As tHIRURGIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_Hir_SQL As String

-    Dim getAll_Hir_SQL As String

-    Dim Hir_Count As Long

-    Hir_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    Else

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Hir_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Hir_Count = dbRecordset("HIR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Hir_RecordsbyLPU_ID = Hir_Count

-    

-    If Hir_Count > 0 Then

-        'we have records

-        ReDim allHir(1 To Hir_Count)

-        Dim index As Integer

-        index = 1

-        dbRecordset.Open getAll_Hir_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpHir As tHIRURGIA

-                 With tmpHir

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .operations_per_quarter = dbRecordset("operations_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_ambulator_clexan_20mg = dbRecordset("patients_ambulator_clexan_20mg")

-                    .patients_ambulator_clexan_40mg = dbRecordset("patients_ambulator_clexan_40mg")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                    .patients_stationar_clexan_20mg = dbRecordset("patients_stationar_clexan_20mg")

-                    .patients_stationar_clexan_40mg = dbRecordset("patients_stationar_clexan_40mg")

-                 End With

-                 

-                 allHir(index) = tmpHir

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE ID=" & objHir.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Hir_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbTer
->>>>>>
-Attribute VB_Name = "dbTer"

-Option Explicit

-

-Public Type tTERAPIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objTer.ID <> 0 then updatre else insert

-Sub Insert_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objTer.id <> 0 Then

-        dbUpdate_Ter_Record dbConnection, objTer

-    Else

-        dbInsert_Ter_Record dbConnection, objTer

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Ter_RecordsByLPU_ID(ByRef allTer() As tTERAPIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Ter_RecordsByLPU_ID = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, allTer, lpu_id, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Ter_Record dbConnection, objTer

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objTer.ID <> 0 then updatre else insert

-

-Sub dbInsert_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_ter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objTer

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objTer.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim Update_SQL As String

-    

-    With objTer

-        Update_SQL = "UPDATE lpu_ter SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_Ter_RecordsbyLPU_ID(dbConnection As Object, allTer() As tTERAPIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_Ter_SQL As String

-    Dim getAll_Ter_SQL As String

-    Dim Ter_Count As Long

-    Ter_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    Else

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Ter_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Ter_Count = dbRecordset("TER_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Ter_RecordsbyLPU_ID = Ter_Count

-    

-    If Ter_Count > 0 Then

-        'we have records

-        ReDim allTer(1 To Ter_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_Ter_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpTer As tTERAPIA

-                 With tmpTer

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 allTer(index) = tmpTer

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE ID=" & objTer.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Ter_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-mLPU_LIST
->>>>>>
-Attribute VB_Name = "mLPU_LIST"

-Option Explicit

-

-Public Const CINP_AREA As String = "B12"

-Public Const CLPU_NAME As Integer = 0

-Public Const CLPU_NAME1 As Integer = 1

-Public Const CLPU_NAME2 As Integer = 2

-Public Const CLPU_ID As Integer = 3

-Public Const CLPU_BEDS As Integer = 4

-Public Const CLPU_NFG As Integer = 5

-Public Const CLPU_NMG As Integer = 6

-Public Const CLPU_HIR As Integer = 7

-Public Const CLPU_TER As Integer = 8

-Public Const CLPU_CAR As Integer = 9

-Public Const CLPU_FACT As Integer = 10

-Public Const CLPU_PLAN As Integer = 11

-Public Const CLPU_PAT_LPU As Integer = 16

-Public Const CLPU_BDGT As Integer = 17

-Public Const CLPU_PAT_ALL As Integer = 16

-

-Sub EditLPU(cLPU As tLPU, ent_date As String)

-    NoFunc

-End Sub

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("LPU_LIST")

-        s = .Range("C4") & " " & .Range("C3") & ", " & .Range("G4") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_LPU_BBL").Range("title") = MakeChartTitle

-End Sub

-

-Sub Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PIE").Range("title") = MakeChartTitle

-End Sub

-

-Sub Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU_A").Range("title") = MakeChartTitle

-End Sub

-

-Sub btLPU_DEL_IT()

-'    Dim cLPU As tLPU

-'    Dim ent_date As String

-'    Dim delete_all As Integer

-'    Dim dlg_del As dlg_LPU_delete

-'

-'    With Worksheets("LPU_LIST")

-'        ent_date = .Range("ent_date")

-'        cLPU.id = .getCurrentLPU_ID()

-'    End With

-'

-'    If cLPU.id = 0 Then

-'        MsgBox "Укажите удаляемый объект", vbOKOnly, PROGRAM_NAME

-'        Exit Sub

-'    End If

-'    cLPU = Get_LPU_Record(cLPU.id)

-'

-'    Set dlg_del = New dlg_LPU_delete

-'    With dlg_del

-'        .chbDeleteQTR.Value = True

-'        .chbDeleteAll.Value = False

-'        .lComment = ent_date & ": Удаление ЛПУ '" _

-'        & cLPU.Name & "', расположенного по адресу:" _

-'        & cLPU.address & " не разрешено."

-'        .Show

-'    End With

-End Sub

-

-Sub btLPU_RET_IT()

-    With Worksheets("LPU_LIST")

-        .setEnt_date ("")

-        .Range("LAST_FOCUS") = ""

-        

-        Wks_select .Range("ret_addr")

-    End With

-

-End Sub

-

-

-Sub btLPU_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim lpu_id As Long

-

-    i = Worksheets(VAR_SHEET).Range("QTR_ACTION").Value

-    With Worksheets("LPU_LIST")

-        ent_date = .getEnt_date()

-

-

-        lpu_id = .getCurrentLPU_ID

-        If lpu_id = 0 And i <> 6 Then

-            i = 1

-        End If

-        Select Case i

-            Case 1

-                .SelectLPU_NAME lpu_id, ent_date

-                .Range("JUMP") = "LPU_BDGT"

-            Case 2

-                .SelectLPU_BDGT lpu_id, ent_date

-                .Range("JUMP") = "LPU_BDGT"

-            Case 3

-                .SelectLPU_HIR lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_HIR"

-

-            Case 4

-                .SelectLPU_TER lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_TER"

-

-            Case 5

-                .SelectLPU_C_ACS lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        End Select

-    End With

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-dbQTR
->>>>>>
-Attribute VB_Name = "dbQTR"

-Option Explicit

-

-Public Type tQTR

-    id As Long

-    entry_date As String

-    rep_id As Long

-    rm_id As Long

-    sale_PLAN As Long

-    ClxnH20mg As Long

-    ClxnH40mg As Long

-    ClxnT40mg As Long

-    ClxnC_IM As Long

-    ClxnC_ACS As Long

-End Type

-

-Function Get_QTR_Record(ByVal QTR_ID As Long, rm_id As Long) As tQTR

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_QTR_Record = dbGet_QTR_Record(dbConnection, QTR_ID, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_Record(dbConnection As Object, ByVal QTR_ID As Long, rm_id As Long) As tQTR

-    

-    Dim sql As String

-    Dim objQTR As tQTR

-    

-    With objQTR

-        .ClxnC_ACS = 0

-        .ClxnC_IM = 0

-        .ClxnH20mg = 0

-        .ClxnH40mg = 0

-        .ClxnT40mg = 0

-        .entry_date = ""

-        .id = QTR_ID

-        .rm_id = rm_id

-    End With

-    

-    sql = "SELECT * FROM quarter WHERE id=" & QTR_ID & " AND rm_id=" & rm_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objQTR.entry_date = dbRecordset("entry_date")

-        objQTR.rep_id = dbRecordset("rep_id")

-        objQTR.rm_id = dbRecordset("rm_id")

-        objQTR.sale_PLAN = dbRecordset("sale_plan")

-        objQTR.ClxnH20mg = dbRecordset("ClxnH20mg")

-        objQTR.ClxnH40mg = dbRecordset("ClxnH40mg")

-        objQTR.ClxnT40mg = dbRecordset("ClxnT40mg")

-        objQTR.ClxnC_IM = dbRecordset("ClxnC_IM")

-        objQTR.ClxnC_ACS = dbRecordset("ClxnC_ACS")

-        objQTR.id = dbRecordset("id")

-    End If

-    

-    dbGet_QTR_Record = objQTR

-

-End Function

-

-

-Function Get_QTR_Record_by_REP(ent_date As String, rep_id As Long, rm_id As Long) As tQTR

-    Dim dbConnection As Object

-    Dim allQTR() As tQTR

-    Dim i As Long

-

-    dbOpenConnection dbConnection

-

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id, rm_id)

-    If i <> 0 Then

-        Get_QTR_Record_by_REP = allQTR(1)

-    End If

-

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTR_Records_by_REP(ByRef all_QTR() As tQTR, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-

-    GetAll_QTR_Records_by_REP = dbGetAll_QTR_Records_By_REP(dbConnection, all_QTR, ent_date, rep_id, rm_id)

-

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGetAll_QTR_Records_By_REP(dbConnection As Object, all_QTR() As tQTR, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-

-    Dim getCount_QTR_SQL As String

-    Dim getAll_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    Dim rep_sql As String

-    Dim rm_sql As String

-    

-    rep_sql = ""

-    rm_sql = ""

-    

-    If rep_id <> 0 Then

-        rep_sql = " AND rep_id=" & rep_id

-    End If

-    

-    If rm_id <> 0 Then

-        rm_sql = " AND rm_id=" & rm_id

-    End If

-    

-    

-        getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter " & _

-        "WHERE entry_date like '" & ent_date & "' " & rep_sql & rm_sql

-        getAll_QTR_SQL = "SELECT * FROM quarter " & _

-        "WHERE entry_date like '" & ent_date & "' " & rep_sql & rm_sql & " ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-

-    dbRecordset.Close

-

-    dbGetAll_QTR_Records_By_REP = QTR_Count

-

-    If QTR_Count > 0 Then

-        'we have records

-        ReDim all_QTR(1 To QTR_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTR_SQL, dbConnection

-

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTR As tQTR

-                 With tmp_QTR

-                    .entry_date = dbRecordset("entry_date")

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .ClxnH20mg = dbRecordset("ClxnH20mg")

-                    .ClxnH40mg = dbRecordset("ClxnH40mg")

-                    .ClxnT40mg = dbRecordset("ClxnT40mg")

-                    .ClxnC_IM = dbRecordset("ClxnC_IM")

-                    .ClxnC_ACS = dbRecordset("ClxnC_ACS")

-                    .id = dbRecordset("id")

-                 End With

-

-                 all_QTR(index) = tmp_QTR

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-cdbQTR
->>>>>>
-Attribute VB_Name = "cdbQTR"

-Option Explicit

-

-Public Type tQTR_COMMON

-    qtr As tQTR

-    i_lcd As Long           ' число ЛПУ в СПИСКЕ

-    lcd() As tLPU_COMMON    ' список ЛПУ

-    c_beds As Long          ' сумма коек

-    c_bdgt_NFG As Long      ' общий бюджет на НФГ

-    c_bdgt_NMG As Long      ' общий бюджет на НМГ

-    c_bdgt_LPU As Long      ' общий бюджет на гепарины

-    c_sale_PLAN As Long     ' план продаж репа

-    c_sale_ALL As Long      ' продажи

-    c_sale_HIR As Long      ' в хирургии

-    c_sale_TER  As Long     ' в терапии

-    c_sale_CRD  As Long     ' в кардиологии

-    c_pat_HIR   As Long     ' пациенты

-    c_pat_TER   As Long     '

-    c_pat_CRD   As Long     '

-    c_pat_ALL   As Long     '

-    c_pat_LPU   As Long     ' Всего операций

-End Type

-

-Function Get_QTR_CommonList_by_REP(ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long, rm_id As Long) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_QTR_CommonList_by_REP = dbGet_QTR_CommonList_by_REP(dbConnection, qcd, ent_date, rep_id, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_CommonList_by_REP(dbConnection As Object, ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long, rm_id As Long) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim allQTR() As tQTR

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id, rm_id)

-    dbGet_QTR_CommonList_by_REP = i

-    If i > 0 Then

-        ReDim qcd(i)

-        For i = 1 To UBound(allQTR)

-            With qcd(i)

-                .qtr = allQTR(i)

-                .c_beds = 0

-                .c_bdgt_NFG = 0

-                .c_bdgt_NMG = 0

-                .c_bdgt_LPU = 0

-                .c_sale_PLAN = 0

-                .c_pat_HIR = 0

-                .c_pat_TER = 0

-                .c_pat_CRD = 0

-                .c_pat_ALL = 0

-                .c_sale_HIR = 0

-                .c_sale_TER = 0

-                .c_sale_CRD = 0

-                .c_sale_ALL = 0

-                .c_pat_LPU = 0

-                

-                j = dbGet_LPU_CommonQTR(dbConnection, .lcd, .qtr)

-                .i_lcd = j

-                If j > 0 Then

-                    For j = 1 To UBound(.lcd)

-                        .c_beds = .c_beds + .lcd(j).lpu.beds

-                        .c_bdgt_NFG = .c_bdgt_NFG + .lcd(j).bdgt.bdgt_NFG

-                        .c_bdgt_NMG = .c_bdgt_NMG + .lcd(j).bdgt.bdgt_NMG

-                        .c_bdgt_LPU = .c_bdgt_LPU + .lcd(j).bdgt_LPU

-                        .c_sale_PLAN = .c_sale_PLAN + .lcd(j).bdgt.sale_PLAN

-                        .c_pat_HIR = .c_pat_HIR + .lcd(j).pat_HIR

-                        .c_pat_TER = .c_pat_TER + .lcd(j).pat_TER

-                        .c_pat_CRD = .c_pat_CRD + .lcd(j).pat_CRD

-                        .c_pat_ALL = .c_pat_ALL + .lcd(j).pat_ALL

-                        .c_sale_HIR = .c_sale_HIR + .lcd(j).sale_HIR

-                        .c_sale_TER = .c_sale_TER + .lcd(j).sale_TER

-                        .c_sale_CRD = .c_sale_CRD + .lcd(j).sale_CRD

-                        .c_sale_ALL = .c_sale_ALL + .lcd(j).sale_ALL

-                        .c_pat_LPU = .c_pat_LPU + .lcd(j).pat_LPU

-                    Next j

-                    

-                End If

-            End With

-        Next i

-    End If

-End Function

-

-Function GetLastQtr() As String

-    Dim s As String

-    Dim r As Range

-    Set r = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Do While r.Cells(1, 1) <> ""

-        s = r.Cells(1, 1)

-        Set r = r.Cells.Offset(1, 0)

-    Loop

-    GetLastQtr = s

-End Function

-

-Function GetNextQTR(ent_date As String) As String

-    Dim rd As Range

-    Dim idx As Integer

-    Dim b As Variant

-    Dim dlg As dlg_newQTR

-    Set dlg = New dlg_newQTR

-    

-    If ent_date = "" Then

-        Dim ir As Variant

-        idx = 0

-        dlg.Show

-        b = dlg.Tag

-            

-        If IsNumeric(b) Then

-            GetNextQTR = dlg.cbQTR

-        Else

-            GetNextQTR = ""

-        End If

-    Else

-        Set rd = Worksheets(VAR_SHEET).Range("Date_Lst")

-        idx = WorksheetFunction.Match(ent_date, rd, 0)

-        GetNextQTR = WorksheetFunction.index(rd, idx + 1, 1)

-    End If

-End Function

-<<<<<<
-======================
-mRestView
->>>>>>
-Attribute VB_Name = "mRestView"

-Option Explicit

-

-Sub xlRestoreView()

-Attribute xlRestoreView.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute xlRestoreView.VB_ProcData.VB_Invoke_Func = " \n14"

-    With Application

-        .CommandBars("Standard").Visible = True

-        .CommandBars("Formatting").Visible = True

-        .DisplayFormulaBar = True

-        .DisplayStatusBar = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = True

-    End With

-End Sub

-<<<<<<
-======================
-dlg_newQTR
->>>>>>
-Attribute VB_Name = "dlg_newQTR"

-Attribute VB_Base = "0{92648543-CB84-4B6B-BEB3-539AE7EF9D84}{7E20E3E3-027A-483B-A14D-AA9EA5398ACC}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mDec2TS
->>>>>>
-Attribute VB_Name = "mDec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-CHRT_LPU_BBL
->>>>>>
-Attribute VB_Name = "CHRT_LPU_BBL"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    Unprotect

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Потенциал рынка: " & Range("title")

-    Range("view_key") = False

-    ChangeLabels

-    Range("A1").Select

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Unprotect

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub BCLabelChng_Click()

-    Unprotect

-    If Range("view_key") Then

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать названия"

-    Else

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать объемы"

-    End If

-    Range("view_key") = Not Range("view_key")

-    ChangeLabels

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub ChangeLabels()

-    Dim i As Integer

-    Dim offset_text As Integer

-    Dim src As Range

-    Set src = Range("CHRT_BBL_DATA")

-    

-    offset_text = 3

-    If Range("view_key") Then

-        offset_text = 4

-    End If

-    

-    With ChartObjects(1).Chart

-        With .SeriesCollection(1)

-            For i = 1 To .Points.count

-                On Error GoTo ExitLabel

-                .Points(i).DataLabel.Characters.Text = Format(src.Cells(i, offset_text))

-            Next i

-        End With

-    End With

-ExitLabel:

-End Sub

-<<<<<<
-======================
-CHRT_PAT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PAT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Пациенты на Клексане(чел.): " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-<<<<<<
-======================
-CHRT_PAT_LPU
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Пациенты на Клексане(%): " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_nextQTR
->>>>>>
-Attribute VB_Name = "dlg_nextQTR"

-Attribute VB_Base = "0{067FED69-B41E-427D-AF59-5798B8E2E73A}{4C13CAB1-FDCC-4708-89EB-E92EDC125712}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-cdbLPU
->>>>>>
-Attribute VB_Name = "cdbLPU"

-Option Explicit

-

-Public Type tLPU_COMMON

-    lpu As tLPU

-    bdgt As tBUDGET

-    i_hir As Long

-    hir() As tHIRURGIA

-    i_ter As Long

-    ter() As tTERAPIA

-    i_ACS As Long

-    ACS() As tACS

-    bdgt_LPU As Long

-    sale_HIR As Long

-    sale_TER As Long

-    sale_CRD As Long

-    sale_ALL As Long

-    pat_HIR As Long

-    pat_TER As Long

-    pat_CRD As Long

-    pat_ALL As Long     ' Сумма всех пациентов на клексане

-    pat_LPU As Long     ' Число потенциальных пациентов для продаж клексана

-End Type

-

-Function Get_LPU_CommonQTR(ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    Get_LPU_CommonQTR = dbGet_LPU_CommonQTR(dbConnection, lcd, objQTR)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_CommonQTR(dbConnection As Object, ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    i = dbGetAll_LPU_byQTR(dbConnection, allLPU, objQTR.entry_date, objQTR.rep_id, objQTR.rm_id)

-    dbGet_LPU_CommonQTR = i

-    If i > 0 Then

-        ReDim lcd(i)

-        For i = 1 To UBound(allLPU)

-            dbGet_LPU_Common dbConnection, lcd(i), allLPU(i), objQTR

-        Next i

-    End If

-End Function

-

-Sub Get_LPU_Common(ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    dbGet_LPU_Common dbConnection, lcd, cLPU, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbGet_LPU_Common(dbConnection As Object, ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-

-    lcd.lpu = cLPU

-    lcd.bdgt = dbGet_BDGT_Record(dbConnection, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    lcd.i_hir = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, lcd.hir, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    lcd.i_ter = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, lcd.ter, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    lcd.i_ACS = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, lcd.ACS, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    With lcd

-        .bdgt_LPU = .bdgt.bdgt_NFG + .bdgt.bdgt_NMG

-        .pat_LPU = 0

-        If .i_hir > 0 Then

-            .pat_HIR = .hir(1).patients_ambulator_clexan + .hir(1).patients_stationar_clexan

-            .sale_HIR = objQTR.ClxnH20mg * (.hir(1).patients_ambulator_clexan_20mg + .hir(1).patients_stationar_clexan_20mg)

-            .sale_HIR = .sale_HIR + objQTR.ClxnH40mg * (.hir(1).patients_ambulator_clexan_40mg + .hir(1).patients_stationar_clexan_40mg)

-            .pat_LPU = .pat_LPU + .hir(1).operations_per_quarter

-        End If

-        If .i_ter > 0 Then

-            .pat_TER = .ter(1).patients_ambulator_clexan + .ter(1).patients_stationar_clexan

-            .sale_TER = .pat_TER * objQTR.ClxnT40mg

-            .pat_LPU = .pat_LPU + .ter(1).patients_per_quarter

-        End If

-        If .i_ACS > 0 Then

-            .pat_CRD = .ACS(1).patients_stationar_clexan

-            .sale_CRD = .pat_CRD * objQTR.ClxnC_ACS

-            .pat_LPU = .pat_LPU + .ACS(1).patients_per_quarter

-        End If

-        .pat_ALL = .pat_HIR + .pat_TER + .pat_CRD

-        .sale_ALL = .sale_HIR + .sale_TER + .sale_CRD

-    End With

-End Sub

-

-<<<<<<
-======================
-CHRT_PIE
->>>>>>
-Attribute VB_Name = "CHRT_PIE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Unprotect

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Доля продаж: " & Range("title")

-    

-    On Error Resume Next

-    Range("P5:Q24").Sort _

-        Key1:=Range("Q5"), _

-        Order1:=xlDescending, _

-        Header:=xlGuess, _

-        OrderCustom:=1, _

-        MatchCase:=False, _

-        Orientation:=xlTopToBottom

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PLN_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PLN_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Динамика продаж: " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_BDGT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_BDGT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Бюджеты ЛПУ: " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-dlg_LPU_delete
->>>>>>
-Attribute VB_Name = "dlg_LPU_delete"

-Attribute VB_Base = "0{9C81F4D2-4ECF-46F5-999B-9801D572A12F}{B382508B-7F3D-4747-8407-0F75F6F265F5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlg_Mail
->>>>>>
-Attribute VB_Name = "dlg_Mail"

-Attribute VB_Base = "0{EA8CE4CE-AC2E-45BC-BAF8-1429E6242097}{575F0762-04F4-4F86-B98A-8E87E3424B0D}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dbREP_id
->>>>>>
-Attribute VB_Name = "dbREP_id"

-Public Type tREPID

-    rep_id As Long

-    rm_id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function GetAll_REPID_Records_by_QTR(ByRef all_REPID() As tREPID, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_REPID_Records_by_QTR = dbGetAll_REPID_Records_by_QTR(dbConnection, all_REPID, ent_date, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function Get_REPID_Record(rep_id As Long, rm_id As Long) As tREPID

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REPID_Record = dbGet_REPID_Record(dbConnection, rep_id, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_REPID_Records(ByRef all_REPID() As tREPID) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_REPID_Records = dbGetAll_REPID_Records(dbConnection, all_REPID)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function dbGet_REPID_Record(dbConnection As Object, rep_id As Long, rm_id As Long) As tREPID

-    

-    Dim sql As String

-    Dim objREPID As tREPID

-    

-    objREPID.FirstName = ""

-    objREPID.LastName = ""

-    objREPID.Region = 0

-    objREPID.City = 0

-    sql = "SELECT * FROM " & _

-          "rep WHERE rep_id=" & rep_id & " AND rm_id=" & rm_id

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREPID.rep_id = dbRecordset("rep_id")

-        objREPID.rm_id = dbRecordset("rm_id")

-        objREPID.FirstName = dbRecordset("firstname")

-        objREPID.LastName = dbRecordset("lastname")

-        objREPID.Region = dbRecordset("region")

-        objREPID.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REPID_Record = objREPID

-        

-End Function

-

-Function dbGetAll_REPID_Records_by_QTR(dbConnection As Object, ByRef all_REPID() As tREPID, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    Dim Where As String

-    

-    REPID_Count = 0

-    

-    Where = " WHERE lpu_budget.entry_date like '" & ent_date & "' " & _

-        "AND rep.rep_id=lpu.rep_id AND lpu.id=lpu_budget.lpu_id"

-    If rm_id <> 0 Then

-        Where = Where & " AND rep.rm_id=" & rm_id

-    End If

-    

-    getAll_REPID_SQL = "SELECT distinct rep.* FROM rep, lpu, lpu_budget" & Where

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM (" & getAll_REPID_SQL & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records_by_QTR = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Function dbGetAll_REPID_Records(dbConnection As Object, ByRef all_REPID() As tREPID) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    REPID_Count = 0

-    

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM rep"

-    getAll_REPID_SQL = "SELECT * FROM rep"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-cdbExport
->>>>>>
-Attribute VB_Name = "cdbExport"

-Option Explicit

-

-Function GetDBSN() As String

-    Dim n As Long

-    Randomize Timer

-    n = Int((100000000 - 1000000 + 1) * Rnd + 1000000)

-    GetDBSN = Dec2ThirtySix(n)

-End Function

-

-Sub dbExport()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim old_file As String

-    

-    On Error GoTo ErrHandler

-    

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    old_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & "*.*"

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & GetDBSN() & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.DeleteFile old_file, True

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Данные экспортированы в файл:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для передачи", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-Exit Sub

-

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-<<<<<<
-======================
-mRegs
->>>>>>
-Attribute VB_Name = "mRegs"

-Option Explicit

-

-Function GetRegionName(idx As Integer) As String

-    GetRegionName = Worksheets(REGS_SHEET).Range("LST_REGIONS").Cells(idx + 1, 1).Text

-End Function

-

-Function GetCityName(idx_reg As Integer, idx_city As Integer) As String

-    GetCityName = Worksheets(REGS_SHEET).Range("CITY_TABLES").Offset(idx_city + 1, idx_reg * 2).Text

-End Function

-

-Sub testReg()

-    Dim r As Integer

-    Dim c As Integer

-    Dim s As String

-    

-    r = 3

-    c = 3

-    s = GetRegionName(r)

-    s = s & ", " & GetCityName(r, c)

-    MsgBox s

-End Sub

-

-<<<<<<
-======================
-RM_QTR
->>>>>>
-Attribute VB_Name = "RM_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CRGN_QT As Integer = 0

-Const CRGN_PLN As Integer = 2

-Const CRGN_FCT As Integer = 3

-Const CRGN_BDG As Integer = 4

-Const CRGN_LPU As Integer = 5

-Const CRGN_REP As Integer = 6

-Const CRGN_HIR As Integer = 7

-Const CRGN_TER As Integer = 8

-Const CRGN_CRD As Integer = 9

-Const CRGN_CLXN_BDG As Integer = 10

-Const CRGN_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Const LOCAL_ENT_DATE As String = "B11"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("RM_QTR")

-        s = .Range("D5") & " " & .Range("D4") & ", " & .Range("H4") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub update_history()

-    Dim objRGN() As tREGION

-    Dim i As Long

-    Dim r As Range

-    Dim cRMan As tREGMAN

-

-    cRMan = Get_REGMAN_Record(Range("RM_ID"))

-    

-    Range("D4") = cRMan.LastName

-    Range("D5") = cRMan.FirstName

-

-    Range("H4") = GetRegionName(cRMan.Region)

-    

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetRGN_COMM_DATA(objRGN, Range("RM_ID"))

-    

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objRGN)

-            r.Offset(i - 1, CRGN_QT) = objRGN(i).ent_date

-            r.Offset(i - 1, CRGN_FCT) = objRGN(i).total_SALE

-            r.Offset(i - 1, CRGN_PLN) = objRGN(i).sale_PLAN

-            r.Offset(i - 1, CRGN_BDG) = objRGN(i).total_BDGT

-            r.Offset(i - 1, CRGN_LPU) = objRGN(i).total_LPU

-            r.Offset(i - 1, CRGN_REP) = objRGN(i).total_REP

-            r.Offset(i - 1, CRGN_HIR) = objRGN(i).total_HIR

-            r.Offset(i - 1, CRGN_TER) = objRGN(i).total_TER

-            r.Offset(i - 1, CRGN_CRD) = objRGN(i).total_ACS

-            If objRGN(i).total_BDGT <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_BDG) = objRGN(i).total_SALE / objRGN(i).total_BDGT

-            End If

-            If objRGN(i).total_BDGT_NMG <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_NMG) = objRGN(i).total_SALE / objRGN(i).total_BDGT_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRGN_CRD + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-

-Sub Draw_PLN_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_FCT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PLN_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Draw_BDGT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_CLXN_NMG + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_BDGT_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Public Sub cbxRM_QtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR_RM

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR_RM

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR_RM

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = RM_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CRGN_QT + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    If r = "" Then

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = currRange.address

-    End If

-    Cancel = True

-    btRM_QTR_Do_IT

-End Sub

-

-<<<<<<
-======================
-dbREG_MAN
->>>>>>
-Attribute VB_Name = "dbREG_MAN"

-Option Explicit

-

-Public Type tREGMAN

-    rm_id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function Get_REGMAN_Record(rm_id As Long) As tREGMAN

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REGMAN_Record = dbGet_REGMAN_Record(dbConnection, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Sub Set_REGMAN_Record(cREGMAN As tREGMAN)

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbSet_REGMAN_Record dbConnection, cREGMAN

-'    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_REGMAN_Record(dbConnection As Object, rm_id As Long) As tREGMAN

-    

-    Dim sql As String

-    Dim objREGMAN As tREGMAN

-    

-    objREGMAN.FirstName = ""

-    objREGMAN.LastName = ""

-    objREGMAN.Region = 0

-    objREGMAN.City = 0

-    objREGMAN.rm_id = rm_id

-    sql = "SELECT * FROM " & _

-          "reg_man WHERE mgr_id=" & rm_id

-          

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREGMAN.FirstName = dbRecordset("firstname")

-        objREGMAN.LastName = dbRecordset("lastname")

-        objREGMAN.Region = dbRecordset("region")

-        objREGMAN.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REGMAN_Record = objREGMAN

-        

-End Function

-

-Public Sub dbSet_REGMAN_Record(dbConnection As Object, ByRef objREGMAN As tREGMAN)

-  

-'    Dim DeleteSQL As String

-'    Dim InsertSQL As String

-'

-'    DeleteSQL = "DELETE FROM reg_man"

-'    InsertSQL = "INSERT INTO reg_man (firstname, lastname, region, city) VALUES (" & _

-'    "'" & objREGMAN.FirstName & "', " & _

-'    "'" & objREGMAN.LastName & "', " & _

-'    objREGMAN.Region & ", " & _

-'    objREGMAN.City & ")"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-       

-End Sub

-

-

-

-<<<<<<
-======================
-dbDatabaseMerge
->>>>>>
-Attribute VB_Name = "dbDatabaseMerge"

-Option Explicit

-

-Public Type tDBFIELD

-    Name As String

-End Type

-

-Public Type tDBTABLE

-    Name As String

-    field() As tDBFIELD

-End Type

-

-

-Function dbGetConnection(dbAccessFileFullPath As String) As Object

-    Dim dbConnection As Object

-    Dim dbAccessFilePasswd As String

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFileFullPath & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    Set dbGetConnection = dbConnection

-End Function

-

-Sub dbCloseOpenedConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteOpenedSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-Function dbMergeREP(from_dbConnection As Object, to_dbConnection As Object) As Long

-

-    Dim getRecordset As Object

-    Dim getREPData_SQL As String

-    Dim REP_fn As String

-    Dim REP_ln As String

-    Dim REP_region As String

-    Dim REP_city As String

-

-

-    getREPData_SQL = "SELECT * FROM rep"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getREPData_SQL, from_dbConnection

-        

-        If Not getRecordset.BOF Then

-            REP_fn = getRecordset("firstname")

-            REP_ln = getRecordset("lastname")

-            REP_city = getRecordset("city")

-            REP_region = getRecordset("region")

-        Else

-            MsgBox "There is no information about rep! This database cannot be merged!!!"

-            dbMergeREP = -1

-            Exit Function

-        End If

-    

-    Dim insertRecordset As Object

-    Set insertRecordset = CreateObject("ADODB.Recordset")

-        

-    insertRecordset.Open "rep", to_dbConnection, 2, 2

-    insertRecordset.addnew

-        

-    insertRecordset("firstname") = REP_fn

-    insertRecordset("lastname") = REP_ln

-    insertRecordset("region") = REP_region

-    insertRecordset("city") = REP_city

-    insertRecordset.Update

-    insertRecordset.MoveLast

-    'new ID

-    

-    dbMergeREP = insertRecordset("rep_id")

-    

-End Function

-

-Sub dbMergeLPU(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getLPU_SQL As String

-    Dim getRecordset As Object

-    Dim idx As Long

-    idx = 1

-    

-    getLPU_SQL = "SELECT * FROM lpu"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getLPU_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            ReDim Preserve objLPU(1 To idx)

-            objLPU(idx).old_lpu_id = getRecordset("id")

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "lpu", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("name") = getRecordset("name")

-            insRS("address") = getRecordset("address")

-            insRS("beds") = getRecordset("beds")

-            insRS.Update

-            insRS.MoveLast

-            'new ID

-            

-            objLPU(idx).new_lpu_id = insRS("id")

-                        

-            idx = idx + 1

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about LPU! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-

-Sub dbMergeLPURelated(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object)

-

-    ' 6 tables to change

-    Dim tables(1 To 5) As tDBTABLE

-    

-    'lpu budget

-    tables(1).Name = "lpu_budget"

-    ReDim tables(1).field(1 To 4)

-    

-    tables(1).field(1).Name = "entry_date"

-    tables(1).field(2).Name = "bdgt_NMG"

-    tables(1).field(3).Name = "bdgt_NFG"

-    tables(1).field(4).Name = "sale_PLAN"

-    

-    'lpu hir

-    tables(2).Name = "lpu_hir"

-    ReDim tables(2).field(1 To 13)

-    

-    tables(2).field(1).Name = "entry_date"

-    tables(2).field(2).Name = "operations_per_quarter"

-    tables(2).field(3).Name = "risk_percent"

-    tables(2).field(4).Name = "patients_with_risk_ON"

-    tables(2).field(5).Name = "patients_ambulator"

-    tables(2).field(6).Name = "patients_ambulator_nmg"

-    tables(2).field(7).Name = "patients_ambulator_clexan"

-    tables(2).field(8).Name = "patients_ambulator_clexan_40mg"

-    tables(2).field(9).Name = "patients_ambulator_clexan_20mg"

-    tables(2).field(10).Name = "patients_stationar_nmg"

-    tables(2).field(11).Name = "patients_stationar_clexan"

-    tables(2).field(12).Name = "patients_stationar_clexan_40mg"

-    tables(2).field(13).Name = "patients_stationar_clexan_20mg"

-    

-    

-    'lpu acs

-    tables(3).Name = "lpu_acs"

-    ReDim tables(3).field(1 To 5)

-    

-    tables(3).field(1).Name = "entry_date"

-    tables(3).field(2).Name = "patients_with_geparins"

-    tables(3).field(3).Name = "patients_per_quarter"

-    tables(3).field(4).Name = "patients_stationar_nmg"

-    tables(3).field(5).Name = "patients_stationar_clexan"

-    

-    'lpu acs

-    tables(4).Name = "lpu_im"

-    ReDim tables(4).field(1 To 5)

-    

-    tables(4).field(1).Name = "entry_date"

-    tables(4).field(2).Name = "patients_with_geparins"

-    tables(4).field(3).Name = "patients_per_quarter"

-    tables(4).field(4).Name = "patients_stationar_nmg"

-    tables(4).field(5).Name = "patients_stationar_clexan"

-    

-    

-    'lpu acs

-    tables(5).Name = "lpu_ter"

-    ReDim tables(5).field(1 To 9)

-    

-    tables(5).field(1).Name = "entry_date"

-    tables(5).field(2).Name = "patients_per_quarter"

-    tables(5).field(3).Name = "risk_percent"

-    tables(5).field(4).Name = "patients_with_risk_ON"

-    tables(5).field(5).Name = "patients_ambulator"

-    tables(5).field(6).Name = "patients_ambulator_nmg"

-    tables(5).field(7).Name = "patients_ambulator_clexan"

-    tables(5).field(8).Name = "patients_stationar_nmg"

-    tables(5).field(9).Name = "patients_stationar_clexan"

-    

-    

-    

-    Dim tbl_idx As Integer

-    

-    For tbl_idx = 1 To UBound(tables)

-        

-        Dim getSQL As String

-        Dim getRS As Object

-        

-        

-        

-        Set getRS = CreateObject("ADODB.Recordset")

-        

-        getSQL = "SELECT * FROM " & tables(tbl_idx).Name

-        getRS.Open getSQL, from_db

-        

-        If Not getRS.BOF Then

-            Do While Not getRS.EOF

-                Dim insRS As Object

-                Set insRS = CreateObject("ADODB.Recordset")

-                

-                insRS.Open tables(tbl_idx).Name, to_db, 2, 2

-                insRS.addnew

-                Dim fld_idx As Integer

-    

-                    For fld_idx = 1 To UBound(tables(tbl_idx).field)

-                        insRS(tables(tbl_idx).field(fld_idx).Name) = getRS(tables(tbl_idx).field(fld_idx).Name)

-                        insRS("lpu_id") = findNewLPU_IDByOld(objLPU, getRS("lpu_id"))

-                    Next fld_idx

-                    

-                insRS.Update

-                insRS.MoveLast

-                getRS.MoveNext

-            Loop

-        End If

-        

-        

-    Next tbl_idx

-

-End Sub

-

-Function findNewLPU_IDByOld(objLPU() As tLPUCONVERTION, old_id As Long)

-

-Dim i As Integer

-For i = 1 To UBound(objLPU)

-    If objLPU(i).old_lpu_id = old_id Then

-        findNewLPU_IDByOld = objLPU(i).new_lpu_id

-        Exit Function

-    End If

-Next i

-

-findNewLPU_IDByOld = -1

-End Function

-

-

-

-

-

-Sub dbMergeQTR(from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getQTR_SQL As String

-    Dim getRecordset As Object

-    

-    getQTR_SQL = "SELECT * FROM quarter"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getQTR_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "quarter", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("entry_date") = getRecordset("entry_date")

-            insRS("sale_plan") = getRecordset("sale_plan")

-            insRS("ClxnH20mg") = getRecordset("ClxnH20mg")

-            insRS("ClxnH40mg") = getRecordset("ClxnH40mg")

-            insRS("ClxnT40mg") = getRecordset("ClxnT40mg")

-            insRS("ClxnC_IM") = getRecordset("ClxnC_IM")

-            insRS("ClxnC_ACS") = getRecordset("ClxnC_ACS")

-            

-            

-            insRS.Update

-            

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about quarter budget! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-dbMerge
->>>>>>
-Attribute VB_Name = "dbMerge"

-Option Explicit

-

-Public Type tLPUCONVERTION

-    old_lpu_id As Long

-    new_lpu_id As Long

-End Type

-

-Sub Merge_BackUp_All_Data()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim time_stump As String

-    

-    On Error GoTo ErrHandler

-    

-    time_stump = Format(Date, "yy-mm-dd_") & Format(Time, "hh-mm")

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_BACKUPNAME & time_stump & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Старые данные сохранены в файле:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для восстанеовления данных в случае утери", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-    Exit Sub

-    

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-

-Sub Merge_Clear_All_Data(access_file_full_path As String)

-    

-    Dim db As Object

-    Dim tables_to_clear() As String

-    On Error GoTo ErrHandler

-    

-    ReDim tables_to_clear(1 To 10)

-    tables_to_clear(1) = "rep"

-    tables_to_clear(2) = "lpu"

-    tables_to_clear(3) = "lpu_budget"

-    tables_to_clear(4) = "lpu_hir"

-    tables_to_clear(5) = "lpu_ter"

-    tables_to_clear(6) = "lpu_acs"

-    tables_to_clear(7) = "lpu_im"

-    tables_to_clear(8) = "quarter"

-    tables_to_clear(9) = "quarter_rm"

-    tables_to_clear(10) = "reg_man"

-    

-    Set db = dbGetConnection(access_file_full_path)

-

-    Dim i As Integer

-    

-    For i = 1 To UBound(tables_to_clear)

-        

-        If tables_to_clear(i) <> "" Then

-            Dim Clear_SQL As String

-            Clear_SQL = "DELETE FROM " & tables_to_clear(i)

-            dbExecuteOpenedSQL db, Clear_SQL

-        Else

-            'do nothing or show message

-        End If

-    Next i

-    

-    dbCloseOpenedConnection db

-    Set db = Nothing

-    

-Exit Sub

-

-ErrHandler:

-    MsgBox "something wrong: " & err.Description

-    Resume Next

-    

-End Sub

-

-Function MergeREP(from_file As String, to_file As String) As Long

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    Dim new_rep_id As Long

-

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    MergeREP = dbMergeREP(db1, db2)

-    'MsgBox "new rep ID is " & new_rep_id

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Function

-

-Sub MergeQTR(from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeQTR db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-

-Sub MergeLPU(objLPU() As tLPUCONVERTION, from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeLPU objLPU, db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-Sub MergeLPURelated(objLPU() As tLPUCONVERTION, from_file As String, to_file As String)

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    dbMergeLPURelated objLPU, db1, db2

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-

-End Sub

-

-Sub MergeGlobal(rep_files() As String, rm_file As String)

-

-    Dim i As Integer

-    'clear output file content

-    Merge_Clear_All_Data rm_file

-    

-    For i = 1 To UBound(rep_files)

-        

-        Dim rep_file As String

-        'setup input and output files

-        rep_file = rep_files(i)

-        

-        Dim new_rep_id As Long

-        ' insert REP data and get new rep_id

-        new_rep_id = MergeREP(rep_file, rm_file)

-        

-        Dim objLPU() As tLPUCONVERTION

-        'insert all LPU using new generated rep_id

-        'and populate objLPU old->new relation object

-        

-        MergeLPU objLPU, rep_file, rm_file, new_rep_id

-        'insert quarter data using new rep_id

-        MergeQTR rep_file, rm_file, new_rep_id

-        

-        

-        ' and.... insert all another data (5 tables excl version and hw)

-        'using objLPU old->new relation object

-        MergeLPURelated objLPU, rep_file, rm_file

-    

-    

-    Next i

-    

-End Sub

-

-Function GetDBList(MyPath() As String, ByRef dblist() As String) As Integer

-    Dim i As Integer

-    Dim MyName, MyMask

-    MyMask = MyPath(0) & MyPath(1) & PROGRAM_DATAEXT

-    i = 0

-    MyName = Dir(MyMask)      ' Retrieve the first entry.

-    Do While MyName <> ""    ' Start the loop.

-        ' Ignore the current directory and the encompassing directory.

-        If MyName <> "." And MyName <> ".." Then

-            ' Use bitwise comparison to make sure MyName is a directory.

-            i = i + 1

-            ReDim Preserve dblist(i)

-            dblist(i) = MyPath(0) & MyName

-        End If

-        MyName = Dir    ' Get next entry.

-    Loop

-    GetDBList = i

-End Function

-

-<<<<<<
-======================
-cdbPRJ
->>>>>>
-Attribute VB_Name = "cdbPRJ"

-Option Explicit

-

-Type tPROJECT

-    total_SALE  As Long ' общий объем продаж

-    total_BDGT  As Long ' бюджет всех ЛПУ

-    total_BDGT_NMG As Long ' бюджет всех ЛПУ на НМГ

-    total_LPU   As Long ' число ЛПУ

-    total_REP   As Long ' число репов

-    total_RM    As Long ' число репов

-    total_BEDS  As Long ' общее число коек

-    total_HIR   As Long '  общее число пациентов на клексане в хирургии

-    total_TER   As Long '  общее число пациентов на клексане в терапии

-    total_ACS   As Long '  общее число пациентов на клексане в кардиологии

-    sale_PLAN   As Long '  план продаж Авентиса

-    objRGN() As tREGION

-End Type

-

-Function GetPRJ_COMM_DATA(ByRef prj_data As tPROJECT) As Integer

-    Dim i As Integer

-    i = GetRGN_COMM_DATA(prj_data.objRGN, 0)

-    GetPRJ_COMM_DATA = i

-    If i > 0 Then

-        With prj_data

-            .sale_PLAN = 0

-            .total_ACS = 0

-            .total_BDGT = 0

-            .total_BDGT_NMG = 0

-            .total_BEDS = 0

-            .total_HIR = 0

-            .total_LPU = 0

-            .total_REP = 0

-            .total_RM = 0

-            .total_SALE = 0

-            .total_TER = 0

-            For i = 1 To UBound(prj_data.objRGN)

-                

-            Next i

-        End With

-    End If

-

-End Function

-

-<<<<<<
-======================
-dbQTR_RM
->>>>>>
-Attribute VB_Name = "dbQTR_RM"

-Option Explicit

-

-Public Type tQTRRM

-    id As Long

-    entry_date As String

-    rm_id As Long

-    sale_PLAN As Long

-End Type

-

-

-Sub Insert_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objQTRRM.id <> 0 Then

-        dbUpdate_QTRRM_Record dbConnection, objQTRRM

-    Else

-        dbInsert_QTRRM_Record dbConnection, objQTRRM

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-Function Get_QTRRM_Record(ent_date As String) As tQTRRM

-    Dim dbConnection As Object

-    Dim allQTRRM() As tQTRRM

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    i = dbGetAll_QTRRM_Records(dbConnection, allQTRRM, ent_date)

-    If i <> 0 Then

-        Get_QTRRM_Record = allQTRRM(1)

-    End If

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTRRM_Records(ByRef all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_QTRRM_Records = dbGetAll_QTRRM_Records(dbConnection, all_QTRRM, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_QTRRM_Record dbConnection, objQTRRM

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objQTRRM.ID <> 0 then updatre else insert

-Sub dbInsert_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "quarter_rm", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objQTRRM

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("sale_plan") = .sale_PLAN

-        dbRecordset("rm_id") = .rm_id

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objQTRRM.id = dbRecordset("id")

-

-End Sub

-

-Sub dbUpdate_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim Update_SQL As String

-    

-    With objQTRRM

-        Update_SQL = "UPDATE quarter_rm SET " & _

-            "entry_date='" & .entry_date & "'" & "," & _

-            "rm_id=" & .rm_id & "," & _

-            "sale_plan=" & .sale_PLAN & "," & _

-            " WHERE id=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if ent_date = % then all_records

-Function dbGetAll_QTRRM_Records(dbConnection As Object, all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    

-    Dim getCount_QTRRM_SQL As String

-    Dim getAll_QTRRM_SQL As String

-    Dim QTRRM_Count As Long

-    QTRRM_Count = 0

-    

-    getCount_QTRRM_SQL = "SELECT COUNT(*) AS QTRRM_TOTAL FROM quarter_rm WHERE entry_date like '" & ent_date & "'"

-    getAll_QTRRM_SQL = "SELECT * FROM quarter_rm WHERE entry_date like '" & ent_date & "' ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTRRM_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTRRM_Count = dbRecordset("QTRRM_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_QTRRM_Records = QTRRM_Count

-    

-    If QTRRM_Count > 0 Then

-        'we have records

-        ReDim all_QTRRM(1 To QTRRM_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTRRM_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTRRM As tQTRRM

-                 With tmp_QTRRM

-                    .entry_date = dbRecordset("entry_date")

-                    .rm_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .id = dbRecordset("id")

-                 End With

-                 

-                 all_QTRRM(index) = tmp_QTRRM

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM quarter_rm " & _

-    "WHERE id=" & objQTRRM.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-    

-    'delete related budget entries

-    MsgBox "remember delete related"

-'    dbDelete_BDGT_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Hir_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Ter_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_ACS_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-       

-End Sub

-

-

-<<<<<<
-======================
-REP_LIST
->>>>>>
-Attribute VB_Name = "REP_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Const LOCAL_ENT_DATE As String = "C10"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-

-Public Function getCurrentREP_ID() As Long

-    Dim r As Range

-

-    With Worksheets("REP_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CREP_ID)

-    End With

-

-    getCurrentREP_ID = r

-End Function

-

-Public Sub REP_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Rep_Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Rep_Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Rep_Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Rep_Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectREP_LPU(rep_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    Range("JUMP") = "LPU_LIST"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-        .Range("RM_ID") = rm_id

-        .setEnt_date (getEnt_date())

-    End With

-End Sub

-

-Public Sub SelectREP_QTR(rep_id As Long)

-    Dim vo As Boolean

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    Range("JUMP") = "REP_QTR"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("REP_QTR")

-        .Range("VIEW_ONLY") = vo

-        .Range("RM_ID") = rm_id

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateREPList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim rep_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CREP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CREP_AREA).row, CREP_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    rep_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CREP_AREA).Column

-    

-    If i < 4 Then

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 1

-    Else

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 2

-    End If

-    

-    If rep_id = 0 Then

-        Range("LAST_FOCUS") = Range(CREP_AREA).address

-    End If

-

-    If rep_id = 0 Then

-        i = CREP_NAME

-        Range("JUMP") = ""

-    Else

-        btREP_LIST_DO_IT

-    End If

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateREPList()

-    Dim rcd() As tREPID_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-

-    ent_date = getEnt_date

-

-    Dim rm_struc As tREGMAN

-    

-    i = Range("RM_ID")

-    rm_struc = Get_REGMAN_Record(i)

-    

-    Range("C4") = rm_struc.LastName

-    Range("C5") = rm_struc.FirstName

-

-    Range("G5") = GetRegionName(rm_struc.Region)

-    

-    i = Get_REP_CommonList_by_QTR(rcd, ent_date, Range("RM_ID"))

-

-    

-    With ThisWorkbook.Worksheets("REP_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(rcd)

-            r.Offset(i - 1, CREP_NAME) = rcd(i).rep.FirstName & " " & rcd(i).rep.LastName

-            r.Offset(i - 1, CREP_ID) = rcd(i).rep.rep_id

-            r.Offset(i - 1, CREP_BEDS) = rcd(i).qtrs(1).c_beds

-

-            r.Offset(i - 1, CREP_NFG) = rcd(i).qtrs(1).c_bdgt_NFG

-            r.Offset(i - 1, CREP_NMG) = rcd(i).qtrs(1).c_bdgt_NMG

-

-            r.Offset(i - 1, CREP_PLAN) = rcd(i).qtrs(1).qtr.sale_PLAN

-

-            r.Offset(i - 1, CREP_HIR) = rcd(i).qtrs(1).c_pat_HIR

-            r.Offset(i - 1, CREP_TER) = rcd(i).qtrs(1).c_pat_TER

-            r.Offset(i - 1, CREP_CAR) = rcd(i).qtrs(1).c_pat_CRD

-            r.Offset(i - 1, CREP_FACT) = rcd(i).qtrs(1).c_sale_ALL

-            r.Offset(i - 1, CREP_PAT_LPU) = rcd(i).qtrs(1).c_pat_LPU

-            r.Offset(i - 1, CREP_BDGT) = rcd(i).qtrs(1).c_bdgt_LPU

-            If rcd(i).qtrs(1).c_bdgt_LPU > 0 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = rcd(i).qtrs(1).c_sale_ALL / rcd(i).qtrs(1).c_bdgt_LPU

-            End If

-            If r.Offset(i - 1, CREP_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-

-

-<<<<<<
-======================
-mREP_LIST
->>>>>>
-Attribute VB_Name = "mREP_LIST"

-Option Explicit

-

-Public Const CREP_AREA As String = "B12"

-Public Const CREP_NAME As Integer = 0

-Public Const CREP_NAME1 As Integer = 1

-Public Const CREP_NAME2 As Integer = 2

-Public Const CREP_ID As Integer = 3

-Public Const CREP_BEDS As Integer = 4

-Public Const CREP_NFG As Integer = 5

-Public Const CREP_NMG As Integer = 6

-Public Const CREP_HIR As Integer = 7

-Public Const CREP_TER As Integer = 8

-Public Const CREP_CAR As Integer = 9

-Public Const CREP_FACT As Integer = 10

-Public Const CREP_PLAN As Integer = 11

-Public Const CREP_PAT_LPU As Integer = 16

-Public Const CREP_BDGT As Integer = 17

-

-

-Const LOCAL_ENT_DATE As String = "C10"

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Sub EditREP(cRep As tREPID, ent_date As String)

-    NoFunc

-End Sub

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("REP_LIST")

-        s = .Range("C5") & " " & .Range("C4") & ", " & .Range("G5") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub Rep_Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_LPU_BBL").Range("title") = MakeChartTitle

-End Sub

-

-Sub Rep_Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CREP_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CREP_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CREP_FACT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PIE").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rep_Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CREP_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CREP_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CREP_HIR + 1)

-            psum = psum + src.Cells(i, CREP_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CREP_TER + 1)

-            psum = psum + src.Cells(i, CREP_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CREP_CAR + 1)

-            psum = psum + src.Cells(i, CREP_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CREP_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rep_Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CREP_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CREP_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CREP_HIR + 1)

-            psum = psum + src.Cells(i, CREP_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CREP_TER + 1)

-            psum = psum + src.Cells(i, CREP_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CREP_CAR + 1)

-            psum = psum + src.Cells(i, CREP_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CREP_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU_A").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub btREP_RET_IT()

-    With Worksheets("REP_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = "RM_QTR"

-    End With

-    Dim str As String

-    str = Range("ret_addr")

-    ThisWorkbook.Worksheets(str).Activate

-End Sub

-

-

-Sub btREP_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim rep_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("REP_LST_DETALS")

-    With Worksheets("REP_LIST")

-        rep_id = .getCurrentREP_ID

-        

-        Select Case i

-            Case 1:

-                .SelectREP_QTR rep_id

-            Case 2:

-                ent_date = .getEnt_date()

-                .SelectREP_LPU rep_id, ent_date

-        End Select

-    End With

-    

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-

-

-

-<<<<<<
-======================
-cdbREP
->>>>>>
-Attribute VB_Name = "cdbREP"

-Option Explicit

-

-Public Type tREPID_COMMON

-    rep As tREPID

-    i_qtrs As Integer

-    qtrs() As tQTR_COMMON

-End Type

-

-Function Get_REP_CommonList_by_QTR(ByRef rcd() As tREPID_COMMON, ent_date As String, rm_id As Long) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_REP_CommonList_by_QTR = dbGet_REP_CommonList_by_QTR(dbConnection, rcd, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_REP_CommonList_by_QTR(dbConnection As Object, ByRef rcd() As tREPID_COMMON, ent_date As String, rm_id As Long) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim k As Long

-    Dim allREPID() As tREPID

-    

-    i = dbGetAll_REPID_Records_by_QTR(dbConnection, allREPID, ent_date, rm_id)

-    dbGet_REP_CommonList_by_QTR = i

-    If i > 0 Then

-        ReDim rcd(i)

-        For i = 1 To UBound(allREPID)

-            rcd(i).rep = allREPID(i)

-            rcd(i).i_qtrs = Get_QTR_CommonList_by_REP(rcd(i).qtrs, ent_date, allREPID(i).rep_id, allREPID(i).rm_id)

-        Next i

-    End If

-End Function

-

-

-

-<<<<<<
-======================
-CHRT_PAT_LPU_A
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU_A"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Пациенты на Клексане(чел.): " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-cdbRegion
->>>>>>
-Attribute VB_Name = "cdbRegion"

-Option Explicit

-

-Type tREGION

-    ent_date As String

-    rm_id As Long

-    total_SALE As Long ' общий объем продаж

-    total_BDGT As Long ' бюджет всех ЛПУ

-    total_BDGT_NMG As Long ' бюджет всех ЛПУ на НМГ

-    total_LPU As Long ' число ЛПУ

-    total_REP   As Long ' число репов

-    total_BEDS As Long ' общее число коек

-    total_HIR As Long '  общее число пациентов на клексане в хирургии

-    total_TER As Long '  общее число пациентов на клексане в терапии

-    total_ACS As Long '  общее число пациентов на клексане в кардиологии

-    sale_PLAN As Long '  план продаж Авентиса

-End Type

-

-Function GetRGN_COMM_DATA(ByRef reg_data() As tREGION, rm_id As Long) As Integer

-    Dim q_date() As String

-    Dim q_count As Integer, i As Integer

-    

-    q_count = getAllQTRNames(q_date, rm_id)

-    If q_count > 0 Then

-        ReDim reg_data(q_count)

-        For i = 1 To q_count

-            Dim current_REP_count As Integer

-            reg_data(i).rm_id = rm_id

-            reg_data(i).ent_date = q_date(i)

-            current_REP_count = getREGION_by_QTR(q_date(i), reg_data(i), rm_id)

-        Next i

-    End If

-    

-    GetRGN_COMM_DATA = q_count

-End Function

-

-' if rm_id = 0 then gets all records

-Function getAllQTRNames(ByRef qtr_lst() As String, rm_id As Long) As Integer

-    

-    Dim sql As String

-    Dim i As Integer

-    Dim db As Object, rs As Object

-    

-    sql = "SELECT DISTINCT entry_date FROM lpu_budget"

-    

-    If rm_id <> 0 Then

-        sql = sql & " WHERE rm_id=" & rm_id

-    End If

-    

-    i = 0

-    

-    dbOpenConnection db

-    Set rs = CreateObject("ADODB.Recordset")

-    

-    rs.Open sql, db

-        

-        If Not rs.BOF Then

-            Do While Not rs.EOF

-                i = i + 1

-                ReDim Preserve qtr_lst(i)

-                qtr_lst(i) = rs("entry_date")

-                rs.MoveNext

-            Loop

-        Else

-            getAllQTRNames = 0

-            Exit Function

-        End If

-    getAllQTRNames = i

-    dbCloseConnection db

-End Function

-

-Function getREGION_by_QTR(ent_date As String, treg As tREGION, rm_id As Long) As Integer

-    Dim rep_count As Integer

-    rep_count = 0

-    

-    Dim reps() As tQTR_COMMON

-    rep_count = Get_QTR_CommonList_by_REP(reps, ent_date, 0, rm_id)

-    

-    treg.ent_date = ent_date

-    treg.total_BDGT = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.total_BDGT_NMG = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.sale_PLAN = 0 ' quarter.sale_plan

-    treg.total_SALE = 0 'summ of

-    ' hir = (amb40+st40)*pr40 + (amb20+st20)*pr20

-    'ter (amb_clx+stat_clx)*price

-    ' acs xxx

-    'price per rep

-    treg.total_HIR = 0 'patiens clxn

-    treg.total_TER = 0 'patiens clxn

-    treg.total_ACS = 0 'patiens clxn

-    treg.total_LPU = 0 'lpu

-    treg.total_BEDS = 0 'lpu.beds

-    treg.total_REP = 0 '

-    

-    If rep_count > 0 Then

-        Dim i As Integer

-        

-        For i = 1 To UBound(reps)

-            ' current rep is reps(i)

-            With reps(i)

-                treg.total_BDGT = treg.total_BDGT + .c_bdgt_NFG + .c_bdgt_NMG

-                treg.total_BDGT_NMG = treg.total_BDGT_NMG + .c_bdgt_NMG

-                treg.sale_PLAN = treg.sale_PLAN + .qtr.sale_PLAN

-                treg.total_SALE = treg.total_SALE + .c_sale_ALL

-                treg.total_HIR = treg.total_HIR + .c_pat_HIR

-                treg.total_TER = treg.total_TER + .c_pat_TER

-                treg.total_ACS = treg.total_ACS + .c_pat_CRD

-                treg.total_LPU = treg.total_LPU + .i_lcd

-                treg.total_BEDS = treg.total_BEDS + .c_beds

-                treg.total_REP = treg.total_REP + 1

-            End With

-            

-        Next i

-        

-    End If

-    

-    getREGION_by_QTR = treg.total_REP

-End Function

-

-<<<<<<
-======================
-mRM_QTR
->>>>>>
-Attribute VB_Name = "mRM_QTR"

-Option Explicit

-

-Sub btRM_QTR_Do_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    Dim i As Integer

-    Dim def_dir As String

-    Dim flist() As String

-    

-    idx = Worksheets(VAR_SHEET).Range("RM_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-'            def_dir = GetWBPath(ThisWorkbook.FullName)

-'            If GetImportDirectory(def_dir, flist) Then

-'                Dim db_list() As String

-'                i = GetDBList(flist, db_list)

-'                If i > 0 Then

-'                    ImportFromRegionalManagers db_list, GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-'                End If

-'            End If

-'            Worksheets(RM_QTR_SHEET).update_history

-        Case 2

-            Worksheets("REP_LIST").Range("ret_addr") = "RM_QTR"

-            Worksheets("REP_LIST").setEnt_date (Worksheets(RM_QTR_SHEET).getEnt_date())

-            Worksheets("REP_LIST").Range("RM_ID") = Worksheets(RM_QTR_SHEET).Range("RM_ID")

-            Worksheets("REP_LIST").Range("VIEW_ONLY") = True

-

-            Worksheets("REP_LIST").Select

-        Case 3

-            MsgBox "Функция не доступна", vbOKOnly, PROGRAM_NAME

-    End Select

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-End Sub

-

-Sub btRM_QTR_RET_IT()

-    Dim str As String

-    str = Range("ret_addr")

-    ThisWorkbook.Worksheets(str).Activate

-End Sub

-

-<<<<<<
-======================
-mImport
->>>>>>
-Attribute VB_Name = "mImport"

-    Option Explicit

-

-Const OFN_ALLOWMULTISELECT As Long = 512

-Const OFN_EXPLORER As Long = 524288

-Const OFN_HIDEREADONLY As Long = 4

-Const OFN_NONETWORKBUTTON As Long = 131072

-Const OFN_READONLY As Long = 1

-       

-Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _

-    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

-

-Private Type OPENFILENAME

-    lStructSize As Long

-    hWndOwner As Long

-    hInstance As Long

-    lpstrFilter As String

-    lpstrCustomFilter As String

-    nMaxCustFilter As Long

-    nFilterIndex As Long

-    lpstrFile As String

-    nMaxFile As Long

-    lpstrFileTitle As String

-    nMaxFileTitle As Long

-    lpstrInitialDir As String

-    lpstrTitle As String

-    flags As Long

-    nFileOffset As Integer

-    nFileExtension As Integer

-    lpstrDefExt As String

-    lCustData As Long

-    lpfnHook As Long

-    lpTemplateName As String

-End Type

-

-Function GetImportDirectory(DB_dir As String, flist() As String) As Boolean

-    Dim OpenFile As OPENFILENAME

-    Dim lReturn As Long

-    Dim sFilter As String

-    

-    OpenFile.lStructSize = Len(OpenFile)

-    '         OpenFile.hwndOwner = Form1.hWnd

-    '         OpenFile.hInstance = App.hInstance

-    sFilter = "Clexane Data Files" & Chr(0) & PROGRAM_IMPORTNAME & PROGRAM_DATAEXT & Chr(0)

-    OpenFile.lpstrFilter = sFilter

-    OpenFile.nFilterIndex = 1

-    OpenFile.lpstrFile = String(257, 0)

-    OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1

-    OpenFile.lpstrFileTitle = OpenFile.lpstrFile

-    OpenFile.nMaxFileTitle = OpenFile.nMaxFile

-    OpenFile.lpstrInitialDir = DB_dir

-    OpenFile.lpstrTitle = "Импорт данных"

-    OpenFile.flags = OFN_HIDEREADONLY + OFN_EXPLORER

-    lReturn = GetOpenFileName(OpenFile)

-    If lReturn = 0 Then

-        GetImportDirectory = False

-    Else

-        GetImportDirectory = True

- 

-        flist = Split(OpenFile.lpstrFile, Chr(0), Compare:=vbBinaryCompare)

-        Dim i As Integer

-        i = 0

-        Do While flist(i) <> ""

-            i = i + 1

-        Loop

-        If i = 1 Then

-            flist(1) = flist(0)

-            flist(0) = GetWBPath(flist(1))

-            flist(1) = GetWBName(flist(1))

-        Else

-            flist(0) = flist(0) & "\"

-        End If

-    End If

-End Function

-<<<<<<
-======================
-cPPReport
->>>>>>
-Attribute VB_Name = "cPPReport"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Const PPR_NON As Integer = 0

-Const PPR_NEW As Integer = 1

-Const PPR_OLD As Integer = 2

-

-Dim ReportApp As PowerPoint.Application

-Dim ReportDoc As PowerPoint.Presentation

-Dim ReportState As Integer

-Dim PowerPointPath As String

-

-Private Sub Class_Initialize()

-    Set ReportApp = CreateObject("PowerPoint.Application")

-    PowerPointPath = ReportApp.Path & "\PowerPNT.EXE"

-    ReportState = PPR_NON

-End Sub

-

-Sub OpenReport(FileName As String)

-    If ReportState <> PPR_NON Then

-        SaveReport

-    End If

-    Set ReportDoc = GetObject(FileName)

-    ReportState = PPR_OLD

-End Sub

-

-Sub CreateReport()

-    If ReportState <> PPR_NON Then

-        SaveReport

-    End If

-    Set ReportDoc = ReportApp.Presentations.Add

-    ReportState = PPR_NEW

-End Sub

-

-Sub SaveReport()

-    Select Case ReportState

-        Case PPR_NEW

-            ReportDoc.SaveAs GetWBPath(ThisWorkbook.FullName) + PROGRAM_FILENAME

-        Case PPR_OLD

-            ReportDoc.Save

-    End Select

-    ReportState = PPR_NON

-End Sub

-

-Sub ReportView()

-    Dim CmdName As String

-    CmdName = GetWBPath(ThisWorkbook.FullName) + PROGRAM_FILENAME + ".PPT"

-    CmdName = PowerPointPath & " " & CmdName

-    Shell CmdName, 1

-End Sub

-

-Sub InsertSlide()

-    Dim ReportPage As PowerPoint.Slide

-    Set ReportPage = ReportDoc.Slides.Add(ReportDoc.Slides.count + 1, ppLayoutBlank)

-    

-    ReportPage.Shapes.Paste

-    ReportPage.Shapes.AddLabel(msoTextOrientationHorizontal, 20, 20, 640, 40) _

-      .TextFrame.TextRange.Text = "Slide #" & Format(ReportDoc.Slides.count)

-End Sub

-

-

-Private Sub Class_Terminate()

-    SaveReport

-    ReportApp.Quit

-End Sub

-<<<<<<
-======================
-dlgImprtDB
->>>>>>
-Attribute VB_Name = "dlgImprtDB"

-Attribute VB_Base = "0{36355920-F7A4-44A8-96EF-5D79CF26137D}{F852BDF2-AB3E-468E-89DF-EC5DC0C7C88B}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Private Sub btSelAll_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = True

-    Next i

-End Sub

-

-Private Sub btUnselect_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = False

-    Next i

-End Sub

-<<<<<<
-======================
-rmImport
->>>>>>
-Attribute VB_Name = "rmImport"

-Option Explicit

-

-Public Type dbDESCRIPTION

-    Name As String

-    Fields() As String

-End Type

-

-Sub ImportFromRegionalManagers(rm_files() As String, fm_file As String)

-    Dim db(9) As dbDESCRIPTION

-    

-    '''''data

-    db(1).Name = "rep"

-    

-    db(2).Name = "lpu"

-    db(3).Name = "lpu_acs"

-    db(4).Name = "lpu_budget"

-    db(5).Name = "lpu_hir"

-    db(6).Name = "lpu_im"

-    db(7).Name = "lpu_ter"

-    db(8).Name = "quarter"

-    db(9).Name = "quarter_rm"

-    

-    ReDim db(1).Fields(5)

-    With db(1)

-        .Fields(1) = "rep_id"

-        .Fields(2) = "firstname"

-        .Fields(3) = "lastname"

-        .Fields(4) = "region"

-        .Fields(5) = "city"

-    End With

-    

-    ReDim db(2).Fields(5)

-    With db(2)

-        .Fields(1) = "id"

-        .Fields(2) = "rep_id"

-        .Fields(3) = "name"

-        .Fields(4) = "address"

-        .Fields(5) = "beds"

-    End With

-    

-    ReDim db(3).Fields(7)

-    With db(3)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "patients_with_geparins"

-        .Fields(5) = "patients_per_quarter"

-        .Fields(6) = "patients_stationar_nmg"

-        .Fields(7) = "patients_stationar_clexan"

-    End With

-    

-    ReDim db(4).Fields(6)

-    With db(4)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "bdgt_NMG"

-        .Fields(5) = "bdgt_NFG"

-        .Fields(6) = "sale_PLAN"

-    End With

-    

-    ReDim db(5).Fields(15)

-    With db(5)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "operations_per_quarter"

-        .Fields(5) = "risk_percent"

-        .Fields(6) = "patients_with_risk_ON"

-        .Fields(7) = "patients_ambulator"

-        .Fields(8) = "patients_ambulator_nmg"

-        .Fields(9) = "patients_ambulator_clexan"

-        .Fields(10) = "patients_ambulator_clexan_40mg"

-        .Fields(11) = "patients_ambulator_clexan_20mg"

-        .Fields(12) = "patients_stationar_nmg"

-        .Fields(13) = "patients_stationar_clexan"

-        .Fields(14) = "patients_stationar_clexan_40mg"

-        .Fields(15) = "patients_stationar_clexan_20mg"

-    End With

-    

-    

-    ReDim db(6).Fields(7)

-    With db(6)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "patients_with_geparins"

-        .Fields(5) = "patients_per_quarter"

-        .Fields(6) = "patients_stationar_nmg"

-        .Fields(7) = "patients_stationar_clexan"

-    End With

-    

-    ReDim db(7).Fields(11)

-    With db(7)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "patients_per_quarter"

-        .Fields(5) = "risk_percent"

-        .Fields(6) = "patients_with_risk_ON"

-        .Fields(7) = "patients_ambulator"

-        .Fields(8) = "patients_ambulator_nmg"

-        .Fields(9) = "patients_ambulator_clexan"

-        .Fields(10) = "patients_stationar_nmg"

-        .Fields(11) = "patients_stationar_clexan"

-    End With

-    

-    ReDim db(8).Fields(9)

-    With db(8)

-        .Fields(1) = "ID"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "rep_id"

-        .Fields(4) = "sale_plan"

-        .Fields(5) = "ClxnH20mg"

-        .Fields(6) = "ClxnH40mg"

-        .Fields(7) = "ClxnT40mg"

-        .Fields(8) = "ClxnC_IM"

-        .Fields(9) = "ClxnC_ACS"

-    End With

-    

-    ReDim db(9).Fields(3)

-    With db(9)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "sale_plan"

-    End With

-    

-    Dim rm_idx As Integer

-    Dim to_db As Object

-    'back uo

-    Merge_BackUp_All_Data

-    

-    'clean up

-    Merge_Clear_All_Data fm_file

-    

-    Set to_db = dbGetConnection(fm_file)

-    

-    For rm_idx = 1 To UBound(rm_files)

-        Dim from_db As Object

-        

-        Set from_db = dbGetConnection(rm_files(rm_idx))

-        

-        Dim new_rm_id As Long

-        new_rm_id = dbMergeRM(from_db, to_db)

-

-        Dim i As Integer

-

-        For i = 1 To UBound(db)

-            Dim get_sql As String

-            Dim getRS As Object

-            Dim insRS As Object

-            Dim field_idx As Integer

-                        

-            get_sql = "SELECT * FROM " & db(i).Name

-            Set getRS = CreateObject("ADODB.Recordset")

-            Set insRS = CreateObject("ADODB.Recordset")

-            insRS.Open db(i).Name, to_db, 2, 2

-

-            getRS.Open get_sql, from_db

-            

-            If Not getRS.BOF Then

-                Do While Not getRS.EOF

-                    insRS.addnew

-                    Dim fld_name As String

-                    

-                    For field_idx = 1 To UBound(db(i).Fields)

-                        fld_name = db(i).Fields(field_idx)

-                        insRS(fld_name) = getRS(fld_name)

-                    Next field_idx

-                    

-                    insRS("rm_id") = new_rm_id

-                    insRS.Update

-                    getRS.MoveNext

-                Loop

-            

-            Else

-                'empty table

-                ' do nothing

-            End If

-            

-            

-        Next i

-        

-        dbCloseOpenedConnection from_db

-    Next rm_idx

-    

-    dbCloseOpenedConnection to_db

-End Sub

-

-Function dbMergeRM(from_dbConnection As Object, to_dbConnection As Object) As Long

-

-    Dim getRecordset As Object

-    Dim getREPData_SQL As String

-    Dim REP_fn As String

-    Dim REP_ln As String

-    Dim REP_region As String

-    Dim REP_city As String

-

-

-    getREPData_SQL = "SELECT * FROM reg_man"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getREPData_SQL, from_dbConnection

-        

-        If Not getRecordset.BOF Then

-            REP_fn = getRecordset("firstname")

-            REP_ln = getRecordset("lastname")

-            REP_city = getRecordset("city")

-            REP_region = getRecordset("region")

-        Else

-            MsgBox "There is no information about Regional Manager! This database cannot be merged!!!"

-            dbMergeRM = -1

-            Exit Function

-        End If

-    

-    Dim insertRecordset As Object

-    Set insertRecordset = CreateObject("ADODB.Recordset")

-        

-    insertRecordset.Open "reg_man", to_dbConnection, 2, 2

-    insertRecordset.addnew

-        

-    insertRecordset("firstname") = REP_fn

-    insertRecordset("lastname") = REP_ln

-    insertRecordset("region") = REP_region

-    insertRecordset("city") = REP_city

-    insertRecordset.Update

-    insertRecordset.MoveLast

-    'new ID

-    dbMergeRM = insertRecordset("mgr_id")

-    

-End Function

-

-Sub cmDataImport()

-    Dim def_dir As String

-    Dim flist() As String

-    Dim i As Integer

-

-    def_dir = GetWBPath(ThisWorkbook.FullName)

-    If GetImportDirectory(def_dir, flist) Then

-        Dim ImpMask() As String

-        ImpMask = Split(flist(1), Chr(95), Compare:=vbBinaryCompare)

-        flist(1) = ImpMask(0) & "*"

-        Dim db_list() As String

-        i = GetDBList(flist(), db_list)

-        

-        If i > 0 Then

-            ImportFromRegionalManagers db_list, GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-        End If

-    End If

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).Select

-End Sub

-

-

-<<<<<<
-======================
-PRJ_QTR
->>>>>>
-Attribute VB_Name = "PRJ_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CPRJ_QT As Integer = 0

-Const CPRJ_ID As Integer = 1

-Const CPRJ_PLN As Integer = 2

-Const CPRJ_FCT As Integer = 3

-Const CPRJ_BDG As Integer = 4

-Const CPRJ_CNT As Integer = 5

-Const CPRJ_BEDS As Integer = 6

-Const CPRJ_HIR As Integer = 7

-Const CPRJ_TER As Integer = 8

-Const CPRJ_CRD As Integer = 9

-Const CPRJ_CLXN_BDG As Integer = 10

-Const CPRJ_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Const LOCAL_ENT_DATE As String = "B11"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("PRJ_QTR")

-        s = "Все регионы, " & .getEnt_date()

-    End With

-    

-    MakeChartTitle = s

-End Function

-

-Sub update_history()

-    Dim objQTR() As tREGION

-    Dim i As Long

-    Dim r As Range

-

-

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetRGN_COMM_DATA(objQTR(), 0)

-    

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CPRJ_QT) = objQTR(i).ent_date

-            r.Offset(i - 1, CPRJ_ID) = ""

-            r.Offset(i - 1, CPRJ_PLN) = objQTR(i).sale_PLAN

-            r.Offset(i - 1, CPRJ_FCT) = objQTR(i).total_SALE

-            r.Offset(i - 1, CPRJ_BDG) = objQTR(i).total_BDGT

-            r.Offset(i - 1, CPRJ_CNT) = objQTR(i).total_LPU

-            r.Offset(i - 1, CPRJ_BEDS) = objQTR(i).total_REP

-            r.Offset(i - 1, CPRJ_HIR) = objQTR(i).total_HIR

-            r.Offset(i - 1, CPRJ_TER) = objQTR(i).total_TER

-            r.Offset(i - 1, CPRJ_CRD) = objQTR(i).total_ACS

-            If objQTR(i).total_BDGT <> 0 Then

-                r.Offset(i - 1, CPRJ_CLXN_BDG) = objQTR(i).total_SALE / objQTR(i).total_BDGT

-            End If

-            If objQTR(i).total_BDGT_NMG <> 0 Then

-                r.Offset(i - 1, CPRJ_CLXN_NMG) = objQTR(i).total_SALE / objQTR(i).total_BDGT_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR_PRJ()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(PRJ_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CPRJ_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CPRJ_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CPRJ_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CPRJ_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CPRJ_CRD + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-

-Sub Draw_PLN_QTR_PRJ()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(PRJ_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CPRJ_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CPRJ_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CPRJ_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CPRJ_FCT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PLN_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Draw_BDGT_QTR_PRJ()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(PRJ_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CPRJ_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CPRJ_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CPRJ_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CPRJ_CLXN_NMG + 1)

-        End If

-    Next i

-    Worksheets("CHRT_BDGT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-Public Sub cbxPRJ_QtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR_PRJ

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR_PRJ

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR_PRJ

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = PRJ_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    Protect UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CPRJ_QT + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    If r = "" Then

-        Worksheets(VAR_SHEET).Range("PRJ_ACTION") = 2

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        Worksheets(VAR_SHEET).Range("PRJ_ACTION") = 2

-        Range("LAST_FOCUS") = currRange.address

-        With Worksheets("REP_LIST")

-            .Range("ret_addr") = "PRJ_QTR"

-            .Range("ent_date") = r

-            .Range("VIEW_ONLY") = True

-        End With

-    End If

-    Cancel = True

-    btPRJ_QTR_Do_IT ' old btRM_OTR_DO_IT

-End Sub

-

-<<<<<<
-======================
-RM_LIST
->>>>>>
-Attribute VB_Name = "RM_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Const LOCAL_ENT_DATE As String = "C10"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-

-Public Function getCurrentRM_ID() As Long

-    Dim r As Range

-

-    With Worksheets("RM_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CRM_ID)

-    End With

-

-    getCurrentRM_ID = r

-End Function

-

-Public Sub RM_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("PM_CHR_IDX")

-        Case 1

-            Rm_Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Rm_Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Rm_Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-

-        Case 4

-            Rm_Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectRM_QTR(rm_id As Long)

-    Dim vo As Boolean

-

-    Range("JUMP") = "RM_QTR"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("RM_QTR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "RM_LIST"

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Public Sub SelectREP_LIST(rm_id As Long)

-    Dim vo As Boolean

-

-    Range("JUMP") = "REP_LIST"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("REP_LIST")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "RM_LIST"

-        .setEnt_date (getEnt_date())

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateRMList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Sub UpdateRMList()

-    Dim rmcd() As tRMID_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-

-    ent_date = getEnt_date

-

-    i = Get_RM_CommonList_by_QTR(rmcd(), ent_date)

-

-    With ThisWorkbook.Worksheets("RM_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(rmcd)

-            r.Offset(i - 1, CRM_NAME) = GetRegionName(rmcd(i).rm.Region)

-            r.Offset(i - 1, CRM_ID) = rmcd(i).rm.rm_id

-            r.Offset(i - 1, CRM_BEDS) = rmcd(i).rgcd(1).total_BEDS

-            r.Offset(i - 1, CRM_BDGT) = rmcd(i).rgcd(1).total_BDGT

-            r.Offset(i - 1, CRM_NMG) = rmcd(i).rgcd(1).total_BDGT_NMG

-            r.Offset(i - 1, CRM_HIR) = rmcd(i).rgcd(1).total_HIR

-            r.Offset(i - 1, CRM_TER) = rmcd(i).rgcd(1).total_TER

-            r.Offset(i - 1, CRM_CAR) = rmcd(i).rgcd(1).total_ACS

-            r.Offset(i - 1, CRM_FACT) = rmcd(i).rgcd(1).total_SALE

-            r.Offset(i - 1, CRM_PLAN) = rmcd(i).rgcd(1).sale_PLAN

-            

-            With rmcd(i).rgcd(1)

-                r.Offset(i - 1, CRM_PAT_LPU) = .total_HIR + .total_TER + .total_ACS

-            End With

-            

-            r.Offset(i - 1, CRM_BDGT_1) = rmcd(i).rgcd(1).total_BDGT

-            If rmcd(i).rgcd(1).total_BDGT > 0 Then

-                r.Offset(i - 1, CRM_BDGT_1 + 1) = rmcd(i).rgcd(1).total_SALE / rmcd(i).rgcd(1).total_BDGT

-            End If

-            If r.Offset(i - 1, CRM_BDGT_1 + 1) > 1 Then

-                r.Offset(i - 1, CRM_BDGT_1 + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim rep_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CRM_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CRM_AREA).row, CRM_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    rep_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CRM_AREA).Column

-

-    If i < 4 Then

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 1

-    Else

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 2

-    End If

-

-    If rep_id = 0 Then

-        Range("LAST_FOCUS") = Range(CRM_AREA).address

-    End If

-

-    If rep_id = 0 Then

-        i = CRM_NAME

-        Range("JUMP") = ""

-    Else

-        btRM_LIST_DO_IT

-    End If

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-<<<<<<
-======================
-mPRJ_QTR
->>>>>>
-Attribute VB_Name = "mPRJ_QTR"

-Sub btPRJ_QTR_Do_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    

-    idx = Worksheets(VAR_SHEET).Range("PRJ_ACTION")

-    ent_date = Worksheets(PRJ_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            cmDataImport

-        Case 2

-            Worksheets("RM_LIST").setEnt_date (Worksheets("PRJ_QTR").getEnt_date())

-            Worksheets("RM_LIST").Range("ret_addr") = "PRJ_QTR"

-            Worksheets("RM_LIST").Select

-        Case 3

-            cmNewReport

-    End Select

-    Worksheets(VAR_SHEET).Range("PRJ_ACTION") = 2

-End Sub

-

-

-<<<<<<
-======================
-mRM_LIST
->>>>>>
-Attribute VB_Name = "mRM_LIST"

-Option Explicit

-

-Public Const CRM_AREA As String = "B12"

-Public Const CRM_NAME As Integer = 0

-Public Const CRM_NAME1 As Integer = 1

-Public Const CRM_NAME2 As Integer = 2

-Public Const CRM_ID As Integer = 3

-Public Const CRM_BEDS As Integer = 4

-Public Const CRM_BDGT As Integer = 5

-Public Const CRM_NMG As Integer = 6

-Public Const CRM_HIR As Integer = 7

-Public Const CRM_TER As Integer = 8

-Public Const CRM_CAR As Integer = 9

-Public Const CRM_FACT As Integer = 10

-Public Const CRM_PLAN As Integer = 11

-Public Const CRM_PAT_LPU As Integer = 16

-Public Const CRM_BDGT_1 As Integer = 17

-

-

-Const LOCAL_ENT_DATE As String = "C10"

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Sub EditREP(CRM As tREPID, ent_date As String)

-    NoFunc

-End Sub

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("RM_LIST")

-        s = "Регионы, " & .getEnt_date()

-    End With

-    

-    MakeChartTitle = s

-End Function

-

-Sub Rm_Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_LPU_BBL").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rm_Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRM_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRM_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRM_FACT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PIE").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rm_Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CRM_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRM_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRM_HIR + 1)

-            psum = psum + src.Cells(i, CRM_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRM_TER + 1)

-            psum = psum + src.Cells(i, CRM_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRM_CAR + 1)

-            psum = psum + src.Cells(i, CRM_CAR + 1)

-            dst.Cells(i, 5) = psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU").Range("title") = MakeChartTitle

-    

-End Sub

-

-Sub Rm_Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CRM_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRM_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRM_HIR + 1)

-            psum = psum + src.Cells(i, CRM_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRM_TER + 1)

-            psum = psum + src.Cells(i, CRM_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRM_CAR + 1)

-            psum = psum + src.Cells(i, CRM_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CRM_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU_A").Range("title") = MakeChartTitle

-    

-End Sub

-

-Sub btRM_LIST_RET_IT()

-    With Worksheets("RM_LIST")

-        .setEnt_date ("")

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = "PRJ_QTR"

-    End With

-    ThisWorkbook.Worksheets("PRJ_QTR").Activate

-End Sub

-

-

-Sub btRM_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim rm_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("RM_LIST_ACTION")

-    With Worksheets("RM_LIST")

-        rm_id = .getCurrentRM_ID()

-        

-        Select Case i

-            Case 1:

-                .SelectRM_QTR rm_id

-            Case 2:

-                .SelectREP_LIST rm_id

-            End Select

-    End With

-    

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-

-

-

-

-<<<<<<
-Project Name : 'ClexaneMR'
-Quirk - duff tag length======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).ClearRepName

-    

-    Application.EnableEvents = True

-    Set MyAppEvents.app = Application

-    

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    

-    MyAppEvents.CheckWorkBooksArround ThisWorkbook

-    

-    cmSetStandaloneMode

-    

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-    

-    Application.ScreenUpdating = True

-    

-    If CheckUser Then

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-        ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-        ThisWorkbook.Worksheets(REP_QTR_SHEET).update_history

-        Application.Calculate

-    End If

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    

-    Dim RestMode As Boolean

-    RestMode = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE")

-    

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-'        If RestMode Then

-            ThisWorkbook.Saved = True

-'        Else

-'            ThisWorkbook.Save

-'        End If

-    End If

-    If RestMode Then

-        xlRestoreView

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    End If

-    Application.Caption = Empty

-    Application.CommandBars(STDBAR_NAME).Reset

-    

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-    Dim MaxX, MaxY As Integer

-    With ThisWorkbook.Worksheets(REP_QTR_SHEET)

-        MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-        MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-    End With

-

-    With ThisWorkbook.Application

-        .ScreenUpdating = False

-        .WindowState = xlNormal

-        .Height = MaxY

-        .Width = MaxX

-    End With

-End Sub

-

-

-

-

-

-<<<<<<
-======================
-REP_QTR
->>>>>>
-Attribute VB_Name = "REP_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CQTR_QT As Integer = 0

-Const CQTR_ID As Integer = 1

-Const CQTR_PLN As Integer = 2

-Const CQTR_FCT As Integer = 3

-Const CQTR_BDG As Integer = 4

-Const CQTR_CNT As Integer = 5

-Const CQTR_BEDS As Integer = 6

-Const CQTR_HIR As Integer = 7

-Const CQTR_TER As Integer = 8

-Const CQTR_CRD As Integer = 9

-Const CQTR_CLXN_BDG As Integer = 10

-Const CQTR_CLXN_NMG As Integer = 11

-Const CQTR_PAT_ALL As Integer = 16

-Const CQTR_BDGT_ALL As Integer = 17

-

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub ClearRepName()

-    Unprotect

-    Range("D4") = ""

-    Range("D5") = ""

-    Range("H4") = ""

-    Range("H5") = ""

-End Sub

-

-Sub update_history()

-    Dim objQTR() As tQTR

-    Dim i As Long

-    Dim r As Range

-    Dim cRep As tREP

-    

-    cRep = GetREPRecord

-    Range("D4") = cRep.LastName

-    Range("D5") = cRep.FirstName

-    

-    Range("H4") = GetRegionName(cRep.Region)

-    Range("H5") = GetCityName(cRep.Region, cRep.City)

-    

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    i = GetAll_QTR_Records(objQTR, "%")

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CQTR_QT) = objQTR(i).entry_date

-        Next i

-    End If

-    Dim qcd() As tQTR_COMMON

-    i = Get_QTR_CommonList(qcd)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(qcd)

-            r.Offset(i - 1, CQTR_QT) = qcd(i).qtr.entry_date

-            r.Offset(i - 1, CQTR_ID) = qcd(i).qtr.id

-            r.Offset(i - 1, CQTR_PLN) = qcd(i).qtr.sale_plan

-            r.Offset(i - 1, CQTR_FCT) = qcd(i).c_sale_ALL

-            r.Offset(i - 1, CQTR_BDG) = qcd(i).c_bdgt_LPU

-            r.Offset(i - 1, CQTR_CNT) = qcd(i).i_lcd

-            r.Offset(i - 1, CQTR_BEDS) = qcd(i).c_beds

-            r.Offset(i - 1, CQTR_HIR) = qcd(i).c_pat_HIR

-            r.Offset(i - 1, CQTR_TER) = qcd(i).c_pat_TER

-            r.Offset(i - 1, CQTR_CRD) = qcd(i).c_pat_CRD

-            If qcd(i).c_bdgt_LPU <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_BDG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_LPU

-            End If

-            If qcd(i).c_bdgt_NMG <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_NMG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_BBL_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-

-End Sub

-

-Sub Draw_PAT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CQTR_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRepQtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-

-Private Sub Worksheet_Activate()

-  

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-    

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.Count > 1 And r_sel.Columns.Count < CRow_Width Or r_sel.Rows.Count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.Count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.Count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.Count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CQTR_ID + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    i = currRange.Column - Range(CINP_AREA).Column

-    

-    QTR_ID = r

-

-    If QTR_ID = 0 Then

-        Worksheets(VAR_SHEET).Range("USER_ACTION") = 1

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        If i > CQTR_FCT Then

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-            Range("LAST_FOCUS") = currRange.address

-        Else

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 3

-            Range("LAST_FOCUS") = currRange.address

-        End If

-    End If

-    Cancel = True

-    btHomeDo_IT

-End Sub

-

-<<<<<<
-======================
-mRep_QTR
->>>>>>
-Attribute VB_Name = "mRep_QTR"

-Option Explicit

-

-Sub DO_New_qtr()

-    Dim res As Variant

-    Dim objQTR As tQTR

-    Dim s As String

-    s = GetLastQtr

-    objQTR.entry_date = GetNextQTR(s)

-    

-    If objQTR.entry_date = "" Then

-        Exit Sub

-    End If

-    

-    DO_Price_qtr objQTR.entry_date

-

-End Sub

-

-Sub DO_Price_qtr(ent_date As String)

-    If ent_date = "" Then

-        DO_New_qtr

-    Else

-        Dim qtr As tQTR

-        Dim res As Integer

-        

-        qtr = Get_QTR_Record(ent_date)

-        

-        If qtr.id = 0 Then

-            qtr.entry_date = ent_date

-    

-            With Worksheets(VAR_SHEET)

-                qtr.ClxnH20mg = .Range("ClxnH20mg")

-                qtr.ClxnH40mg = .Range("ClxnH40mg")

-                qtr.ClxnT40mg = .Range("ClxnT40mg")

-                qtr.ClxnC_ACS = .Range("ClxnC_ACS")

-                qtr.ClxnC_IM = .Range("ClxnC_IM")

-            End With

-        End If

-        

-        Dim dlg_nq As dlg_nextQTR

-        Set dlg_nq = New dlg_nextQTR

-        

-        With dlg_nq

-            .tb_qtr_name = qtr.entry_date

-            .tb_bdgt_avts = qtr.sale_plan

-            .tb_qtr_name = qtr.entry_date

-            .tb_ClxnH20mg = qtr.ClxnH20mg

-            .tb_ClxnH40mg = qtr.ClxnH40mg

-            .tb_ClxnT40mg = qtr.ClxnT40mg

-            .tb_ClxnC_ACS = qtr.ClxnC_ACS

-            .tb_ClxnC_IM = qtr.ClxnC_IM

-        End With

-        

-        dlg_nq.Show

-        res = dlg_nq.Tag

-        

-        If res = vbOK Then

-            With dlg_nq

-                If Not IsNumeric(.tb_bdgt_avts) Then

-                    MsgBox "Введите план продаж", vbOK, PROGRAM_NAME

-                Else

-                    If .tb_bdgt_avts = 0 Then

-                        MsgBox "Введите план продаж", vbOK, PROGRAM_NAME

-                        Exit Sub

-                    End If

-                End If

-                Dim bool As Boolean

-                bool = IsNumeric(.tb_ClxnH20mg) _

-                    And IsNumeric(.tb_ClxnH40mg) _

-                    And IsNumeric(.tb_ClxnT40mg) _

-                    And IsNumeric(.tb_ClxnC_ACS) _

-                    And IsNumeric(.tb_ClxnC_IM)

-                If Not bool Then

-                    MsgBox "Вводите правильно цыфры", vbOK, PROGRAM_NAME

-                    Exit Sub

-                End If

-                qtr.sale_plan = .tb_bdgt_avts

-                qtr.entry_date = .tb_qtr_name

-                qtr.ClxnH20mg = .tb_ClxnH20mg

-                qtr.ClxnH40mg = .tb_ClxnH40mg

-                qtr.ClxnT40mg = .tb_ClxnT40mg

-                qtr.ClxnC_ACS = .tb_ClxnC_ACS

-                qtr.ClxnC_IM = .tb_ClxnC_IM

-            End With

-            Insert_QTR_Record qtr

-        End If

-    End If

-End Sub

-

-Sub DO_Edit_qtr(ent_date As String)

-    If ent_date = "" Then

-        DO_New_qtr

-    Else

-        With ThisWorkbook.Worksheets("LPU_LIST")

-            .Range("VIEW_ONLY") = False

-            .Range("ent_date") = ent_date

-            .Select

-        End With

-    End If

-End Sub

-

-Sub DO_Delete_qtr(ent_date As String)

-    If ent_date <> "" Then

-        Dim i As Integer

-        i = MsgBox("Удалить данные за период [" & ent_date & "]?", vbDefaultButton2 + vbOKCancel, PROGRAM_NAME)

-        If i = vbOK Then

-            Dim objQTR As tQTR

-            If ent_date <> "" Then

-                objQTR.entry_date = ent_date

-                objQTR = Get_QTR_Record(ent_date)

-                Delete_QTR_Record objQTR

-                Worksheets(TITLE_SHEET).Select

-                Worksheets(REP_QTR_SHEET).Select

-            End If

-        End If

-    End If

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-

-Sub btHomeDo_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    idx = Worksheets(VAR_SHEET).Range("USER_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            DO_New_qtr

-            ' Обновляем экран

-        Case 2

-            DO_Edit_qtr ent_date

-        Case 3

-            DO_Price_qtr ent_date

-        Case 4

-            dbExport

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    End Select

-    If idx <> 2 Then

-        With ThisWorkbook

-            .Worksheets(TITLE_SHEET).Select

-            .Worksheets(REP_QTR_SHEET).Select

-        End With

-    End If

-End Sub

-

-Sub Delete_qtr()

-    Dim ent_date As String

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    DO_Delete_qtr ent_date

-End Sub

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane[MR]"

-Public Const PROGRAM_VERSION As String = "version 1.6"

-Public Const PROGRAM_FILENAME As String = "clexane-mr"

-Public Const PROGRAM_EXPORTNAME As String = "mr-ex-"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20030329

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "O40"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-End Sub

-

-Function Double2Str(ByVal d As Double, ByVal precision As Integer, Optional Delim As String = ".") As String

-    Dim s As String

-    If Not precision > 0 Then

-        s = Round(d)

-    Else

-        Dim i As Integer

-        i = Fix(d)

-        s = i & Delim

-        d = Abs(d - i)

-        Do

-            precision = precision - 1

-            d = d * 10

-            If precision > 0 Then

-                i = Fix(d)

-            Else

-                i = Round(d)

-            End If

-            If i < 1 Then

-                s = s & "0"

-            Else

-                s = s & i

-                d = d - i

-            End If

-        Loop While precision > 0

-    End If

-    Double2Str = s

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.Count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.name = VAR_SHEET Or sh.name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-<<<<<<
-======================
-Var
->>>>>>
-Attribute VB_Name = "Var"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-title
->>>>>>
-Attribute VB_Name = "title"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LPU_LIST
->>>>>>
-Attribute VB_Name = "LPU_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentLPU_ID() As Long

-    Dim r As Range

-    

-    With Worksheets("LPU_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CLPU_ID)

-    End With

-    

-    getCurrentLPU_ID = r

-End Function

-

-Public Sub LPU_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectLPU_NAME(lpu_id As Long, ent_date As String)

-    If Range("VIEW_ONLY") = True Then

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    Dim cLPU As tLPU

-    If lpu_id = 0 Then

-        cLPU.id = 0

-        cLPU.rep_id = 0

-        cLPU.address = ""

-        cLPU.name = ""

-    Else

-        cLPU = Get_LPU_Record(lpu_id)

-    End If

-    EditLPU cLPU, getEnt_date

-    Worksheet_Activate

-End Sub

-        

-Sub SelectLPU_BDGT(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    If lpu_id = 0 Then

-        SelectLPU_NAME lpu_id, ent_date

-    Else

-        With ThisWorkbook.Worksheets("LPU_BDGT")

-            .Range("VIEW_ONLY") = vo

-            .Range("ret_addr") = "LPU_LIST"

-            .Range("ent_date") = ent_date

-            .Range("lpu_id") = lpu_id

-        End With

-    End If

-End Sub

-

-Sub SelectLPU_HIR(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_CLSN_HIR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-                   

-Sub SelectLPU_TER(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_CLSN_TER")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-       

-Sub SelectLPU_C_ACS(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_CLSN_C_ACS")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateLPUList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.Count > 1 And r_sel.Columns.Count < CINP_WIDTH Or r_sel.Rows.Count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.Count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.Count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.Count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim lpu_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-    

-    ent_date = getEnt_date

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-    

-    Set r = Range(CINP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CINP_AREA).row, CLPU_ID)

-        

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-    

-    lpu_id = r

-    

-    i = Range(Range("LAST_FOCUS")).Column - Range(CINP_AREA).Column

-    

-    If lpu_id = 0 Then

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    End If

-    

-    If lpu_id = 0 Then

-        i = CLPU_NAME

-        Range("JUMP") = ""

-    End If

-    Select Case i

-        Case CLPU_NAME, CLPU_NAME1, CLPU_NAME2, CLPU_BEDS

-            SelectLPU_NAME lpu_id, ent_date

-            Range("JUMP") = ""

-

-        Case CLPU_NMG, CLPU_NFG, CLPU_PLAN, CLPU_FACT

-            SelectLPU_BDGT lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-            

-        Case CLPU_HIR

-            SelectLPU_HIR lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_HIR"

-        

-        Case CLPU_TER

-            SelectLPU_TER lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_TER"

-        

-        Case CLPU_CAR

-            SelectLPU_C_ACS lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_C_ACS"

-        

-        Case Else

-            Range("JUMP") = ""

-    End Select

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-    

-    is_input_range = INPUT_NO

-    

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateLPUList()

-    Dim lcd() As tLPU_COMMON

-    

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-    Dim objQTR As tQTR

-    Dim cRep As tREP

-    

-    ' ent_date = "%" ' % - all records

-    ent_date = getEnt_date

-    

-    objQTR = Get_QTR_Record(ent_date)

-    i = Get_LPU_CommonQTR(lcd, objQTR)

-     

-    ' стираем ФИО

-    Range("C3:C4").ClearContents

-    cRep = GetREPRecord

-    

-    Range("C3") = cRep.LastName

-    Range("C4") = cRep.FirstName

-    Range("G3") = GetRegionName(cRep.Region)

-    Range("G4") = GetCityName(cRep.Region, cRep.City)

-    Range("G5") = objQTR.sale_plan

-    

-

-    

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-        

-        For i = 1 To UBound(lcd)

-            r.Offset(i - 1, CLPU_NAME) = lcd(i).lpu.name

-            r.Offset(i - 1, CLPU_ID) = lcd(i).lpu.id

-            r.Offset(i - 1, CLPU_BEDS) = lcd(i).lpu.beds

-            

-         

-            r.Offset(i - 1, CLPU_NFG) = lcd(i).bdgt.bdgt_NFG

-            r.Offset(i - 1, CLPU_NMG) = lcd(i).bdgt.bdgt_NMG

-            r.Offset(i - 1, CLPU_PLAN) = lcd(i).bdgt.sale_plan

-            

-            r.Offset(i - 1, CLPU_HIR) = lcd(i).pat_HIR

-            r.Offset(i - 1, CLPU_TER) = lcd(i).pat_TER

-            r.Offset(i - 1, CLPU_CAR) = lcd(i).pat_CRD

-            r.Offset(i - 1, CLPU_FACT) = lcd(i).sale_ALL

-            r.Offset(i - 1, CLPU_PAT_LPU) = lcd(i).pat_LPU

-            r.Offset(i - 1, CLPU_BDGT) = lcd(i).bdgt_LPU

-            If lcd(i).bdgt_LPU > 0 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = lcd(i).sale_ALL / lcd(i).bdgt_LPU

-            End If

-            If r.Offset(i - 1, CLPU_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = 1

-            End If

-            

-        Next i

-    End If

-End Sub

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{566B33D6-957A-43E4-8444-D8EA3889700C}{42EE65B8-F8C6-4F95-9F52-7738BF6FCEAD}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-dbACS
->>>>>>
-Attribute VB_Name = "dbACS"

-Option Explicit

-

-Public Type tACS

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    patients_with_geparins As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objACS.ID <> 0 then updatre else insert

-Sub Insert_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objACS.id <> 0 Then

-        dbUpdate_ACS_Record dbConnection, objACS

-    Else

-        dbInsert_ACS_Record dbConnection, objACS

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_ACS_RecordsByLPU_ID(ByRef all_ACS_() As tACS, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_ACS_RecordsByLPU_ID = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, all_ACS_, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_ACS_Record dbConnection, objACS

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub dbInsert_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_acs", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objACS

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("patients_with_geparins") = .patients_with_geparins

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objACS.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim Update_SQL As String

-    

-    With objACS

-        Update_SQL = "UPDATE lpu_acs SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "patients_with_geparins=" & .patients_with_geparins & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_ACS_RecordsbyLPU_ID(dbConnection As Object, all_ACS() As tACS, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_ACS_SQL As String

-    Dim getAll_ACS_SQL As String

-    Dim ACS_Count As Long

-    ACS_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_ACS_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        ACS_Count = dbRecordset("ACS_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_ACS_RecordsbyLPU_ID = ACS_Count

-    

-    If ACS_Count > 0 Then

-        'we have records

-        ReDim all_ACS(1 To ACS_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_ACS_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_ACS As tACS

-                 With tmp_ACS

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .patients_with_geparins = dbRecordset("patients_with_geparins")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 all_ACS(index) = tmp_ACS

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE ID=" & objACS.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_ACS_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_HIR
->>>>>>
-Attribute VB_Name = "LPU_CLSN_HIR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-    

-        Dim objHir As tHIRURGIA

-        

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objHir

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .operations_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L9")

-                .patients_ambulator_clexan_20mg = Range("L10")

-                .patients_ambulator_clexan_40mg = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L19")

-                .patients_stationar_clexan_20mg = Range("L20")

-                .patients_stationar_clexan_40mg = Range("L21")

-            End With

-            Insert_Hir_Record objHir

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objHir.id = Range("rec_id")

-                    If objHir.id <> 0 Then

-                        Delete_Hir_Record objHir

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objHir As tHIRURGIA)

-    Dim qtr As tQTR

-    Dim formula As String

-

-    With objHir

-        Range("rec_id") = .id

-        Range("F6") = .operations_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L9") = .patients_ambulator_clexan

-        Range("L10") = .patients_ambulator_clexan_20mg

-        Range("I21") = .patients_stationar_nmg

-        Range("L19") = .patients_stationar_clexan

-        Range("L20") = .patients_stationar_clexan_20mg

-        

-        qtr = Get_QTR_Record(.entry_date)

-        formula = "=" & qtr.ClxnH20mg & "*($L$10+$L$20)+" & qtr.ClxnH40mg & "*($L$11+$L$21)"

-        Range("F11").formula = formula

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-    

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Range("h_DepFlag") = False

-    

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objHir() As tHIRURGIA

-        Dim i As Integer

-        i = GetAll_Hir_RecordsByLPU_ID(objHir, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.3

-        Else

-            SetupData objHir(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-mSapes
->>>>>>
-Attribute VB_Name = "mSapes"

-Option Explicit

-

-Const SHAPE_COLOR As Integer = 1

-Const SHAPE_NAME As Integer = 2

-

-

-Sub ShapeView(r_sh_finite_state As Range)

-    Dim chk As Range

-    Dim s As String

-    Dim c, idx As Integer

-    For Each chk In r_sh_finite_state

-        idx = 0

-        If chk = "+" Then

-            c = chk.Offset(0, idx + SHAPE_COLOR)

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While c <> 0

-                ShapeFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s)), c

-                idx = idx + 2

-                c = chk.Offset(0, idx + SHAPE_COLOR)

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        Else

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While s <> ""

-                ShapeUnFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s))

-                idx = idx + 2

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        End If

-    Next chk

-End Sub

-

-Sub ShapeFill(sh As ShapeRange, ByVal color As Integer)

-    sh.Fill.Visible = msoTrue

-    sh.Fill.Solid

-    sh.Fill.ForeColor.SchemeColor = color

-    sh.Fill.Transparency = 0#

-End Sub

-

-Sub ShapeUnFill(sh As ShapeRange)

-    sh.Fill.Visible = msoFalse

-    sh.Fill.Transparency = 0#

-End Sub

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Public Const INPUT_NO = 0

-Public Const INPUT_NUMBER = 1

-Public Const INPUT_PERCENT = 2

-Public Const INPUT_STRING = 3

-Public Const INPUT_CHECK = 4

-

-Public Const INP_IDX_TYPE = 1

-Public Const INP_IDX_NEXT = 2

-Public Const INP_IDX_MIN = 3

-Public Const INP_IDX_MAX = 4

-Public Const INP_IDX_DEP = 5

-Public Const INP_IDX_ALT = 7

-

-

-Public Type tInputSet

-    vType As Integer

-    vMin As Long

-    vMax As Long

-    rChk As String

-End Type

-

-Function is_input_cell(ByVal Target As Range, inputs As Range) As tInputSet

-    Dim t As Range

-    Dim iset As tInputSet

-    Dim test As Range

-    iset.vType = INPUT_NO

-    iset.vMin = 0

-    iset.vMax = 0

-    iset.rChk = ""

-    is_input_cell = iset

-

-' Закоментировать следующую сточку для работы

-'  Exit Function

-

-    Set test = Target.Cells(1, 1)

-    For Each t In inputs

-        If Range(t).Column = test.Column And Range(t).row = test.row Then

-            iset.vType = t.Offset(0, INP_IDX_TYPE).Value

-            Select Case iset.vType

-                Case INPUT_CHECK

-                    iset.rChk = t.Offset(0, INP_IDX_ALT)

-                Case INPUT_NUMBER, INPUT_PERCENT

-                    iset.vMin = t.Offset(0, INP_IDX_MIN).Value

-                    iset.vMax = t.Offset(0, INP_IDX_MAX).Value

-            End Select

-            is_input_cell = iset

-            Exit Function

-        End If

-    Next t

-End Function

-

-Function GetFocusAddress(ByVal r As Range, f_next As Range) As String

-    Dim chk, t As Range

-    

-    For Each chk In f_next

-        For Each t In r

-            If t.address = chk Then

-                GetFocusAddress = chk

-                Exit Function

-            End If

-            If Range(chk).Column = t.Column - 1 And Range(chk).row = t.row _

-            Or Range(chk).Column = t.Column And Range(chk).row = t.row - 1 _

-            Then

-                If Range(chk) <> "" Then

-                    If Range(chk) = 0 Then

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_ALT)).address

-                    Else

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_NEXT)).address

-                    End If

-                Else

-                    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-                End If

-                Exit Function

-            End If

-        Next t

-    Next chk

-    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-End Function

-

-Sub SetDependet(r As Range, inputs As Range)

-    Dim chk As Range

-    Dim s, serr As String

-    Dim idx As Integer

-    Dim iset As tInputSet

-    Dim err_found As Boolean

-    

-    If r.Count > 1 Then

-        Exit Sub

-    End If

-    

-    err_found = False

-    For Each chk In inputs

-        idx = INP_IDX_DEP

-        

-        

-        iset.vType = chk.Offset(0, INP_IDX_TYPE).Value

-        Select Case iset.vType

-            Case INPUT_NUMBER, INPUT_PERCENT

-                iset.vMin = chk.Offset(0, INP_IDX_MIN).Value

-                iset.vMax = chk.Offset(0, INP_IDX_MAX).Value

-                

-                If Range(chk) > iset.vMax Then

-                    err_found = True

-                    Range(chk) = iset.vMax

-                    serr = "Выход за дозволенный диапазон [" & iset.vMin & ".." & iset.vMax & "]! Данные скорректированы."

-                End If

-                

-                If Range(chk) = "" Then

-                    s = chk.Offset(0, idx)

-                    Do While s <> ""

-                        Range(s) = ""

-                        idx = idx + 1

-                        s = chk.Offset(0, idx)

-                    Loop

-                End If

-        End Select

-    Next chk

-    If err_found Then

-        MsgBox serr, vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Function CheckInputData(inputs As Range) As Boolean

-    Dim r As Range

-    

-    CheckInputData = True

-    For Each r In inputs

-        If Range(r) = "" Then

-            CheckInputData = False

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100.", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Sub Check_Int_Number(Target As Range, Def_Val As Long)

-    Dim err As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    err = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                err = True

-            End If

-        End If

-    Next r

-    If err Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_TER
->>>>>>
-Attribute VB_Name = "LPU_CLSN_TER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim objTer As tTERAPIA

-        

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objTer

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .patients_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L20")

-            End With

-            Insert_Ter_Record objTer

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objTer.id = Range("rec_id")

-                    If objTer.id <> 0 Then

-                        Delete_Ter_Record objTer

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objTer As tTERAPIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    With objTer

-        Range("rec_id") = .id

-        Range("F6") = .patients_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L11") = .patients_ambulator_clexan

-        Range("I21") = .patients_stationar_nmg

-        Range("L20") = .patients_stationar_clexan

-        

-        qtr = Get_QTR_Record(.entry_date)

-        formula = "=" & qtr.ClxnT40mg & "*($L$12+$L$20)"

-        Range("F11").formula = formula

-        

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-    

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Range("h_DepFlag") = False

-    

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objTer() As tTERAPIA

-        Dim i As Integer

-        i = GetAll_Ter_RecordsByLPU_ID(objTer, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.25

-        Else

-            SetupData objTer(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-    

-    Dim s As String

-    Dim iset As tInputSet

-    

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    

-    Select Case iset.vType

-        Case INPUT_NO

-        

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-            

-            Application.ScreenUpdating = False

-            

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-            

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-        

-        Case INPUT_STRING

-        

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{EBA94131-180E-4709-A2A3-B60D48987620}{47A860A1-BF92-4EBB-A333-AB7E83FAB868}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-LPU_BDGT
->>>>>>
-Attribute VB_Name = "LPU_BDGT"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub SetDefFocus()

-    Range(Range("DEF_FOCUS")).Select

-End Sub

-

-Public Sub ClearData()

-    ClearSheetData

-End Sub

-

-Sub ClearSheetData()

-    If Range("F10") = 0 And Range("F13") = 0 Then

-        Range("F11:F18") = ""

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("F11:F13") = ""

-    End If

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim bdgt As tBUDGET

-        Dim sum As Long

-        Dim test As Boolean

-        With bdgt

-            .lpu_id = Range("lpu_id")

-            .id = Range("rec_id")

-            .entry_date = Range("ent_date")

-            .bdgt_NMG = Round(Range("F11").Value, 0)

-            .bdgt_NFG = Round(Range("F12").Value, 0)

-            .sale_plan = Round(Range("F13").Value, 0)

-            

-            sum = .bdgt_NFG + .bdgt_NMG - .sale_plan

-            test = .bdgt_NFG <> 0 Or .bdgt_NMG <> 0 Or .sale_plan <> 0

-        End With

-        If test Then

-            If sum < 0 Then

-                MsgBox _

-                    "Ваш план превышает выделенный на гепарины бюджет. Сохранить данные?", _

-                    vbOKOnly, PROGRAM_NAME

-            End If

-            If test Then

-                Insert_BDGT_Record bdgt

-            End If

-        Else

-            If bdgt.id <> 0 Then

-                If vbYes = MsgBox("Сохранить нулевые значения?", vbYesNo, PROGRAM_NAME) Then

-                    Insert_BDGT_Record bdgt

-                End If

-                ret_back Range("DEF_FOCUS").Worksheet

-                Exit Sub

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-    End If

-    

-   ClearData

-   ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(cLPU As tLPU_COMMON)

-    Dim t_sum As Long

-    t_sum = 0

-' Setup budget data

-    Range("F11") = cLPU.bdgt.bdgt_NMG

-    Range("F12") = cLPU.bdgt.bdgt_NFG

-    Range("F13") = cLPU.bdgt.sale_plan

-    

-    With cLPU

-        Range("F14") = .pat_ALL

-        Range("F15") = .pat_HIR

-        Range("F16") = .pat_TER

-        Range("F17") = .pat_CRD

-        Range("F18") = .sale_ALL

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    ws_activate

-End Sub

-

-

-Sub ws_activate()

-    Dim cLPU As tLPU_COMMON

-    Dim objQTR As tQTR

-    Dim objLPU As tLPU

-    Dim ent_date As String

-    Dim id As Long

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    id = Range("lpu_id").Value

-    ent_date = Range("ent_date")

-    objQTR = Get_QTR_Record(ent_date)

-    objLPU = Get_LPU_Record(id)

-    Get_LPU_Common cLPU, objLPU, objQTR

-    

-    If cLPU.lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = cLPU.lpu.beds

-        Range("lpu_name") = cLPU.lpu.name

-        Range("lpu_addr") = cLPU.lpu.address

-        Range("rec_id") = cLPU.bdgt.id

-        

-        SetupData cLPU

-        

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-'    MsgBox Target.address

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Dim s As String

-    Dim iset As tInputSet

-    

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    

-    Select Case iset.vType

-        Case INPUT_NO

-        

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-            

-        Case INPUT_PERCENT

-        

-        Case INPUT_STRING

-        

-        Case INPUT_CHECK

-            

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{E3F10C5A-A4B4-42FF-A2C9-6F8198210A07}{563D0F3D-F79D-48F1-AFE4-A2136809B982}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mSheets
->>>>>>
-Attribute VB_Name = "mSheets"

-Option Explicit

-

-Function am_load_now() As Boolean

-    am_load_now = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE")

-End Function

-

-Sub Wks_select(RetSheet As String)

-    Dim sheet As Worksheet

-    For Each sheet In ThisWorkbook.Worksheets

-        If sheet.name = RetSheet Then

-            ThisWorkbook.Worksheets(RetSheet).Select

-            Exit Sub

-        End If

-    Next sheet

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub ret_back(sh As Worksheet)

-    Dim RetSheet As String

-    RetSheet = sh.Range("ret_addr")

-    sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    sh.Range("ret_addr") = ""

-    sh.Range("rec_id") = ""

-    sh.Range("lpu_id") = ""

-    sh.Range("ent_date") = ""

-    sh.Range("lpu_name") = ""

-    sh.Range("lpu_addr") = ""

-    sh.Range("lpu_beds") = ""

-    Wks_select RetSheet

-End Sub

-

-Sub ClearSheetData(r_start As Range)

-    If r_start <> "" Then

-        r_start.Worksheet.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        r_start = ""

-    Else

-        ret_back r_start.Worksheet

-    End If

-End Sub

-

-Sub wks_sel_chng(iset As tInputSet, ByVal Target As Range, sh As Worksheet)

-    Dim DebugMode As Boolean

-    Dim in_range As Range

-    

-    DebugMode = Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-

-    If DebugMode Then

-        sh.Unprotect

-    Else

-        sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    End If

-

-    If iset.vType = INPUT_CHECK Then

-        Set in_range = Target.Worksheet.Range(iset.rChk)

-    Else

-        Set in_range = Target

-    End If

-    

-    Dim str As String

-    str = GetFocusAddress(in_range, sh.Range("h_inputs"))

-

-'    MsgBox Target.Address & "; " & str

-    If str <> Target.address Then

-        sh.Range(str).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-Dlg_lpu_card
->>>>>>
-Attribute VB_Name = "Dlg_lpu_card"

-Attribute VB_Base = "0{137EDDE5-3DB4-4BAD-A245-324DC31ABB36}{3BD7159A-BF6C-403F-B3DF-4834FA9E4D92}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbLPU_List_Change()

-    Dim src As Range

-    Dim idx_src As Integer

-    

-    Set src = Worksheets(VAR_SHEET).Range(Me.cbLPU_List.RowSource)

-    idx_src = Me.cbLPU_List.ListIndex + 1

-    Me.tb_lpu_name.Text = src.Cells(idx_src, 1)

-    Me.tb_lpu_address.Text = src.Cells(idx_src, 2)

-    Me.tbBedsCount.Text = src.Cells(idx_src, 3)

-End Sub

-

-

-Private Sub cbxLPU_List_Enable_Click()

-    

-    If Me.cbxLPU_List_Enable Then

-        

-        Me.tb_lpu_name.Text = ""

-        Me.tb_lpu_name.Enabled = False

-        

-        Me.tb_lpu_address.Text = ""

-        Me.tb_lpu_address.Enabled = False

-        

-        Me.tbBedsCount.Text = ""

-        Me.tbBedsCount.Enabled = False

-        

-        Me.cbLPU_List.Enabled = True

-        cbLPU_List_Change

-    Else

-        Me.tb_lpu_name.Enabled = True

-        Me.tb_lpu_name.Text = ""

-        

-        Me.tb_lpu_address.Enabled = True

-        Me.tb_lpu_address.Text = ""

-        

-        Me.tbBedsCount.Enabled = True

-        Me.tbBedsCount.Text = ""

-        

-        Me.cbLPU_List.Enabled = False

-    End If

-End Sub

-

-<<<<<<
-======================
-UserInfo
->>>>>>
-Attribute VB_Name = "UserInfo"

-Attribute VB_Base = "0{8EB80D4C-3476-421A-A370-6332A07DE509}{A7542905-C9F8-4F39-AD67-B62A88F8F4E6}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Tag = vbOK

-End Sub

-

-Private Sub cbCity_Change()

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_CITY") = Me.cbCity.ListIndex

-        .Calculate

-    End With

-End Sub

-

-Private Sub cbRegion_Change()

-    Dim LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        NewRangeOffsetCol = cbRegion.Value * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).address

-        NewSumRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).address

-        .Calculate

-        .Range("IDX_CITY") = 0

-        cbCity.RowSource = NewCbxRange

-

-    End With

-    cbCity.ListIndex = 0

-End Sub

-

-<<<<<<
-======================
-mREP
->>>>>>
-Attribute VB_Name = "mREP"

-Option Explicit

-

-Sub hwnew()

-    Dim rs As Range

-    Dim re As Object

-    

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    HWReset

-    ReSetREPRecord

-    With Worksheets("REP_QTR")

-        .ClearRepName

-        .Range("REP_QTR_INPUT_DATA").ClearContents

-        .Range("QTR_SEL") = ""

-    End With

-    Worksheets(TITLE_SHEET).Select

-    With Application

-        .DisplayAlerts = False

-        .ThisWorkbook.Save

-        .Quit

-    End With

-End Sub

-

-Function CheckUser() As Boolean

-    Dim objHW() As Long

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    

-    GetHWInfo objHW()

-    i = GetHWRecords(objHW_DB)

-    

-    If i = 0 Then ' First time

-        StoreHWInfo objHW()

-        Worksheets("REP_QTR").Range("QTR_SEL") = ""

-    End If

-    If CheckHWInfo(objHW()) <> True Then

-        CheckUser = False

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    Else

-        CheckUser = SetupUser

-    End If

-End Function

-

-Function SetupUser() As Boolean

-    Dim cUser As tREP

-    Dim idx As Integer

-    Dim dlg_ui As UserInfo

-    

-    Set dlg_ui = New UserInfo

-    

-    cUser = GetREPRecord()

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_REGION") = cUser.Region

-        .Range("IDX_CITY") = cUser.City

-    End With

-        

-    With dlg_ui

-        .cbRegion = cUser.Region

-        .cbCity = cUser.City

-        .tbFName = cUser.FirstName

-        .tbLName = cUser.LastName

-    End With

-    

-    Worksheets(REGS_SHEET).Calculate

-    

-    Dim test_Ok As Boolean

-    test_Ok = False

-    

-    On Error GoTo l1

-

-    Do

-        dlg_ui.Show

-        If dlg_ui.Tag = vbOK Then

-            test_Ok = dlg_ui.tbFName.Value <> "" And dlg_ui.tbLName <> ""

-            If test_Ok Then

-                Exit Do

-            Else

-                MsgBox "Введите имя и фамилию", vbOKOnly, PROGRAM_NAME

-            End If

-        Else

-            Exit Do

-        End If

-    Loop Until False

-l1:

-    If test_Ok Then

-        With cUser

-            .Region = dlg_ui.cbRegion.Value

-            .City = dlg_ui.cbCity.Value

-            .FirstName = dlg_ui.tbFName.Value

-            .LastName = dlg_ui.tbLName.Value

-        End With

-        SetREPRecord cUser

-    Else

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .ThisWorkbook.Saved = True

-            .Quit

-        End With

-    End If

-    SetupUser = test_Ok

-End Function

-

-Sub GetHWInfo(objHW() As Long)

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    i = 1

-    For Each d In dc

-        If d.drivetype = 2 Then ' 2 - HardDisk

-            ReDim Preserve objHW(i)

-            objHW(i) = d.SerialNumber

-            i = i + 1

-        End If

-    Next

-    SortHW objHW

-End Sub

-

-Sub StoreHWInfo(objHW() As Long)

-    UpdateHWRecords objHW

-End Sub

-

-Sub SortHW(objHW() As Long)

-    Dim r As Range

-    Dim rs As Range

-    Dim re As Object

-    Dim i As Integer

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    For i = 1 To UBound(objHW)

-        r = objHW(i)

-        Set r = r.Offset(1, 0)

-    Next i

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).Sort _

-            Key1:=.Range("HW_Number"), _

-            Order1:=xlDescending, _

-            Header:=xlGuess, _

-            OrderCustom:=1, _

-            MatchCase:=False, _

-            Orientation:=xlTopToBottom

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    i = 1

-    Do While r <> ""

-        objHW(i) = r

-        Set r = r.Offset(1, 0)

-        i = i + 1

-    Loop

-End Sub

-

-Function CheckHWInfo(objHW() As Long)

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    CheckHWInfo = False

-        

-    i = GetHWRecords(objHW_DB)

-    If i > 0 Then

-        SortHW objHW_DB

-    End If

-    If UBound(objHW) = UBound(objHW_DB) Then

-        For i = 1 To UBound(objHW)

-            If objHW(i) <> objHW_DB(i) Then

-                Exit Function

-            End If

-        Next i

-        CheckHWInfo = True

-    End If

-End Function

-<<<<<<
-======================
-dbBudget
->>>>>>
-Attribute VB_Name = "dbBudget"

-Option Explicit

-

-Public Type tBUDGET

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    bdgt_NMG As Long

-    bdgt_NFG As Long

-    sale_plan As Long

-End Type

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function GetAll_BDGT_RecordsByLPU_ID(ByRef allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_BDGT_RecordsByLPU_ID = dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection, allBDGT, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function Get_BDGT_Record(ByVal lpu_id As Long, ByVal ent_date As String) As tBUDGET

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    Get_BDGT_Record = dbGet_BDGT_Record(dbConnection, lpu_id, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objBDGT.ID <> 0 then updatre else insert

-Public Sub Insert_BDGT_Record(objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    If objBDGT.id <> 0 Then

-        dbUpdate_BDGT_Record dbConnection, objBDGT

-    Else

-        dbInsert_BDGT_Record dbConnection, objBDGT

-    End If

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Public Sub Delete_BDGT_Record(ByRef objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    dbDelete_BDGT_Record dbConnection, objBDGT

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_BDGT_Record(dbConnection As Object, ByVal lpu_id As Long, ent_date As String) As tBUDGET

-    

-    Dim SQL As String

-    Dim objBDGT As tBUDGET

-    

-    With objBDGT

-        .id = 0

-        .lpu_id = lpu_id

-        .entry_date = ent_date

-        .bdgt_NMG = 0

-        .bdgt_NFG = 0

-        .sale_plan = 0

-    End With

-        

-    

-    SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        With objBDGT

-            .entry_date = dbRecordset("entry_date")

-            .id = dbRecordset("id")

-            .lpu_id = dbRecordset("lpu_id")

-            .bdgt_NFG = dbRecordset("bdgt_NFG")

-            .bdgt_NMG = dbRecordset("bdgt_NMG")

-            .sale_plan = dbRecordset("sale_PLAN")

-        End With

-    End If

-    

-    dbGet_BDGT_Record = objBDGT

-End Function

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection As Object, allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_BDGT_SQL As String

-    Dim getAll_BDGT_SQL As String

-    Dim BDGT_Count As Long

-    BDGT_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_BDGT_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        BDGT_Count = dbRecordset("BDGT_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_BDGT_RecordsbyLPU_ID = BDGT_Count

-    

-    If BDGT_Count > 0 Then

-        'we have records

-        ReDim allBDGT(1 To BDGT_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_BDGT_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpBDGT As tBUDGET

-                 With tmpBDGT

-                    .entry_date = dbRecordset("entry_date")

-                    .id = dbRecordset("id")

-                    .lpu_id = dbRecordset("lpu_id")

-                    .bdgt_NFG = dbRecordset("bdgt_NFG")

-                    .bdgt_NMG = dbRecordset("bdgt_NMG")

-                    .sale_plan = dbRecordset("sale_PLAN")

-                 End With

-                 

-                 allBDGT(index) = tmpBDGT

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbInsert_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "lpu_budget", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    dbRecordset("entry_date") = objBDGT.entry_date

-    dbRecordset("lpu_id") = objBDGT.lpu_id

-    dbRecordset("bdgt_NMG") = objBDGT.bdgt_NMG

-    dbRecordset("bdgt_NFG") = objBDGT.bdgt_NFG

-    dbRecordset("sale_PLAN") = objBDGT.sale_plan

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objBDGT.id = dbRecordset("id")

-  

-End Sub

-

-Public Sub dbUpdate_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu_budget SET " & _

-    "entry_date='" & objBDGT.entry_date & "'," & _

-    "lpu_id=" & objBDGT.lpu_id & "," & _

-    "bdgt_NMG=" & objBDGT.bdgt_NMG & "," & _

-    "bdgt_NFG=" & objBDGT.bdgt_NFG & "," & _

-    "sale_PLAN=" & objBDGT.sale_plan & _

-    " WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-Public Sub dbDelete_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_BDGT_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbDatabase
->>>>>>
-Attribute VB_Name = "dbDatabase"

-Option Explicit

-

-

-Sub dbOpenConnection(dbConnection As Object)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, SQL As String)

-    dbConnection.Execute (SQL)

-End Sub

-

-<<<<<<
-======================
-dbLPU
->>>>>>
-Attribute VB_Name = "dbLPU"

-Option Explicit

-

-Public Type tLPU

-    id As Long

-    rep_id As Long

-    name As String

-    address As String

-    beds As Integer

-End Type

-

-Function Get_LPU_Record(ByVal lpu_id As Long) As tLPU

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_LPU_Record = dbGet_LPU_Record(dbConnection, lpu_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAllLPU(allLPU() As tLPU) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAllLPU = dbGetAllLPU(dbConnection, allLPU)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAllLPUbyQTR(allLPU() As tLPU, ent_date As String) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAllLPUbyQTR = dbGetAllLPUbyQTR(dbConnection, allLPU, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objLPU.id = 0 then insert else update

-Sub Insert_LPU_Record(ByRef objLPU As tLPU)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    If objLPU.id = 0 Then

-        dbInsert_LPU_Record dbConnection, objLPU

-    Else

-        dbUpdate_LPU_Record dbConnection, objLPU

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub Delete_LPU_Record(ByRef objLPU As tLPU)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDelete_LPU_Record dbConnection, objLPU

-    dbCloseConnection dbConnection

-End Sub

-

-Sub Delete_LPU_RecordQTR(ByRef objLPU As tLPU, ent_date As String)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Hir_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Ter_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_ACS_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    

-    dbCloseConnection dbConnection

-    

-End Sub

-

-Function dbGet_LPU_Record(dbConnection As Object, ByVal lpu_id As Long) As tLPU

-    

-    Dim SQL As String

-    Dim objLPU As tLPU

-    

-    objLPU.id = lpu_id

-    objLPU.name = ""

-    objLPU.address = ""

-    

-    SQL = "SELECT * FROM lpu WHERE id=" & lpu_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objLPU.name = dbRecordset("name")

-        objLPU.address = dbRecordset("address")

-        objLPU.rep_id = dbRecordset("rep_id")

-        objLPU.beds = dbRecordset("beds")

-    End If

-    

-    dbGet_LPU_Record = objLPU

-

-End Function

-

-Sub dbInsert_LPU_Record(dbConnection As Object, ByRef objLPU As tLPU)

-  

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu", dbConnection, 2, 2

-    dbRecordset.addnew

-    dbRecordset("name") = objLPU.name

-    dbRecordset("address") = objLPU.address

-    dbRecordset("rep_id") = objLPU.rep_id

-    dbRecordset("beds") = objLPU.beds

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objLPU.id = dbRecordset("id")

-  

-End Sub

-

-Sub dbUpdate_LPU_Record(dbConnection As Object, ByRef objLPU As tLPU)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu SET " & _

-    "name='" & objLPU.name & "'," & _

-    "address='" & objLPU.address & "'," & _

-    "beds=" & objLPU.beds & "," & _

-    "rep_id=" & objLPU.rep_id& & _

-    " WHERE id=" & objLPU.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-

-Function dbGetAllLPU(dbConnection As Object, allLPU() As tLPU) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu"

-    getAll_LPU_SQL = "SELECT * FROM lpu"

-

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAllLPU = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-Function dbGetAllLPUbyQTR(dbConnection As Object, allLPU() As tLPU, ent_date As String) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    Dim where As String

-    where = "WHERE lpu_budget.entry_date like '" & ent_date & "'"

-    

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu_budget " & where

-    

-    getAll_LPU_SQL = "SELECT lpu.id as id, lpu.rep_id as rep_id, lpu.name as name, lpu.address as address, lpu.beds AS beds " & _

-    "FROM lpu, lpu_budget " & where & " AND lpu.id=lpu_budget.lpu_id"

-    

-

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAllLPUbyQTR = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-Sub dbDelete_LPU_Record(dbConnection As Object, ByRef objLPU As tLPU)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu " & _

-    "WHERE id=" & objLPU.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByLPU_ID dbConnection, objLPU.id

-    dbDelete_Hir_RecordsByLPU_ID dbConnection, objLPU.id

-    dbDelete_Ter_RecordsByLPU_ID dbConnection, objLPU.id

-    dbDelete_ACS_RecordsByLPU_ID dbConnection, objLPU.id

-    

-End Sub

-

-Sub dbDelete_LPU_RecordQTR(dbConnection As Object, ByRef objLPU As tLPU, ent_date As String)

-    

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Hir_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Ter_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_ACS_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    

-End Sub

-

-<<<<<<
-======================
-dbREP
->>>>>>
-Attribute VB_Name = "dbREP"

-Option Explicit

-

-Public Type tREP

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function GetREPRecord() As tREP

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetREPRecord = dbGetREPRecord(dbConnection)

-    dbCloseConnection dbConnection

-End Function

-

-Sub SetREPRecord(cUser As tREP)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbSetREPRecord dbConnection, cUser

-    dbCloseConnection dbConnection

-End Sub

-

-Sub ReSetREPRecord()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbReSetREPRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGetREPRecord(dbConnection As Object) As tREP

-    

-    Dim SQL As String

-    Dim objREP As tREP

-    

-    objREP.FirstName = ""

-    objREP.LastName = ""

-    objREP.Region = 0

-    objREP.City = 0

-    SQL = "SELECT firstname, lastname, region, city FROM " & _

-          "rep"

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open SQL, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREP.FirstName = dbRecordset("firstname")

-        objREP.LastName = dbRecordset("lastname")

-        objREP.Region = dbRecordset("region")

-        objREP.City = dbRecordset("city")

-        

-    End If

-    

-    dbGetREPRecord = objREP

-        

-End Function

-

-Public Sub dbSetREPRecord(dbConnection As Object, ByRef objREP As tREP)

-  

-    Dim DeleteSQL As String

-    Dim InsertSQL As String

-    

-    DeleteSQL = "DELETE FROM rep"

-    InsertSQL = "INSERT INTO rep (firstname, lastname, region, city) VALUES (" & _

-    "'" & objREP.FirstName & "', " & _

-    "'" & objREP.LastName & "', " & _

-    objREP.Region & ", " & _

-    objREP.City & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    dbRecordset.Open InsertSQL, dbConnection

-End Sub

-

-Public Sub dbReSetREPRecord(dbConnection As Object)

-  

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM rep"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    CheckWorkBooksArround Wb

-End Sub

-

-

-Sub CheckWorkBooksArround(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If app.Workbooks.Count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKOnly, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-        Exit Sub

-    End If

-

-End Sub

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub SaveExcelState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-        ActiveWorkbook.DisplayDrawingObjects = xlDisplayShapes

-        

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.Count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars(STDBAR_NAME).Visible = False

-End Sub

-

-

-Public Sub RestoreExcelState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars(STDBAR_NAME).Visible = True

-End Sub

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Public Const STDBAR_NAME = "Worksheet Menu Bar"

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Export"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 620

-                        .OnAction = "cmExport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Exit && Restore Excel"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 548

-                        .OnAction = "cmExitRestore"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(flag As Boolean)

-    If flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars(STDBAR_NAME)

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmExport()

-    dbExport

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    Dim dlg As dlgAbout

-    Set dlg = New dlgAbout

-    

-    dlg.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlg.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlg.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlg.Show

-End Sub

-

-Sub cmMail2Support()

-    Dim err_description As String

-    Dim dlg_msg As dlg_Mail

-    Set dlg_msg = New dlg_Mail

-    With dlg_msg

-        .Show

-        If .Tag = vbOK Then

-            ThisWorkbook.Worksheets(VAR_SHEET).Range("ERR_MESSAGE") _

-                = .tbMessage.Text

-            ThisWorkbook.Save

-            ThisWorkbook.SendMail Recipients:="infra@i-rs.ru", Subject:=PROGRAM_NAME & " ver.:" & PROGRAM_VERSION

-            MsgBox "Сообщение об ошибке отправлено. Перезагрузите программу.", vbOKOnly, PROGRAM_NAME

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-    End With

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-'        helppath = "hh.exe " & .Path & "\Telfast.chm"

-'        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub set_work_mode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetupEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-End Sub

-

-Sub cmSetStandaloneMode()

-    set_work_mode

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    Dim dlg As dlgGetPwd

-    rp = common_pwd

-    

-    Set dlg = New dlgGetPwd

-    dlg.edPwd = ""

-    dlg.Show

-    

-    If dlg.edPwd = rp Then

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmHomePage()

-    ThisWorkbook.Worksheets("REP_QTR").Select

-End Sub

-

-Sub cmExitRestore()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = True

-    Application.Quit

-End Sub

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    Dim dlg_prn As dlgPrint

-    

-    Set dlg_prn = New dlgPrint

-    

-    With dlg_prn

-        .cbMainReport = True

-        .cbMainBudget = False

-        .cbSrcData = False

-        .cbAllSheets = False

-    

-        .Show

-    

-        If .Tag = vbCancel Then

-            Exit Sub

-        End If

-    End With

-    

-    Dim PrnIdx As Integer

-    

-    With dlg_prn

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("REP_QTR", "budget", "Final")

-    Case 1111

-        plist = Array("REP_QTR", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("REP_QTR")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Clexane bar"

-Public Const common_pwd As String = "crdjhxtyjr"

-

-

-Sub SetupEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    Wb.Worksheets(TITLE_SHEET).Select

-    With Application

-        .Caption = PROGRAM_NAME & " " & PROGRAM_VERSION

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .SaveExcelState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = False

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Wb.Worksheets(TITLE_SHEET).Select

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-'                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    If cWindow.Type = xlWorkbook Then

-                        cWindow.DisplayHeadings = True

-                    End If

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu True

-        End If

-        With mobjAppState

-            .RestoreExcelState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Worksheets(TITLE_SHEET).Select

-'        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Option Explicit

-

-Sub UpdateHWRecords(objHW() As Long)

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    dbUpdateHWRecords dbConnection, objHW

-    dbCloseConnection dbConnection

-End Sub

-

-Function GetHWRecords(objHW() As Long) As Integer

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    GetHWRecords = dbGetHWRecords(dbConnection, objHW)

-    dbCloseConnection dbConnection

-End Function

-

-Sub HWReset()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbInsertHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    

-    Dim dbRecordset As Object

-    Dim i As Long

-    

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "hw", dbConnection, 2, 2

-    

-    For i = 1 To UBound(objHW)

-        dbRecordset.addnew

-        dbRecordset("num") = objHW(i)

-        dbRecordset.Update

-    Next i

-    

-End Sub

-

-Sub dbUpdateHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    dbDeleteHWRecord dbConnection

-    dbInsertHWRecords dbConnection, objHW

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-dbHir
->>>>>>
-Attribute VB_Name = "dbHir"

-Option Explicit

-

-Public Type tHIRURGIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    operations_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_ambulator_clexan_40mg As Integer

-    patients_ambulator_clexan_20mg As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-    patients_stationar_clexan_40mg As Integer

-    patients_stationar_clexan_20mg As Integer

-End Type

-

-' if objHir.ID <> 0 then updatre else insert

-Sub Insert_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objHir.id <> 0 Then

-        dbUpdate_Hir_Record dbConnection, objHir

-    Else

-        dbInsert_Hir_Record dbConnection, objHir

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Hir_RecordsByLPU_ID(ByRef allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Hir_RecordsByLPU_ID = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, allHir, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Hir_Record dbConnection, objHir

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objHir.ID <> 0 then updatre else insert

-

-Sub dbInsert_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_hir", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objHir

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("operations_per_quarter") = .operations_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_ambulator_clexan_20mg") = .patients_ambulator_clexan_20mg

-        dbRecordset("patients_ambulator_clexan_40mg") = .patients_ambulator_clexan_40mg

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-        dbRecordset("patients_stationar_clexan_20mg") = .patients_stationar_clexan_20mg

-        dbRecordset("patients_stationar_clexan_40mg") = .patients_stationar_clexan_40mg

-        

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objHir.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim UpdateSQL As String

-    

-    With objHir

-        UpdateSQL = "UPDATE lpu_hir SET " & _

-            "entry_date='" & objHir.entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "operations_per_quarter=" & .operations_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_ambulator_clexan_20mg=" & .patients_ambulator_clexan_20mg & "," & _

-            "patients_ambulator_clexan_40mg=" & .patients_ambulator_clexan_40mg & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & "," & _

-            "patients_stationar_clexan_20mg=" & .patients_stationar_clexan_20mg & "," & _

-            "patients_stationar_clexan_40mg=" & .patients_stationar_clexan_40mg & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_Hir_RecordsbyLPU_ID(dbConnection As Object, allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Hir_SQL As String

-    Dim getAll_Hir_SQL As String

-    Dim Hir_Count As Long

-    Hir_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Hir_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Hir_Count = dbRecordset("HIR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Hir_RecordsbyLPU_ID = Hir_Count

-    

-    If Hir_Count > 0 Then

-        'we have records

-        ReDim allHir(1 To Hir_Count)

-        Dim index As Integer

-        index = 1

-        dbRecordset.Open getAll_Hir_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpHir As tHIRURGIA

-                 With tmpHir

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .operations_per_quarter = dbRecordset("operations_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_ambulator_clexan_20mg = dbRecordset("patients_ambulator_clexan_20mg")

-                    .patients_ambulator_clexan_40mg = dbRecordset("patients_ambulator_clexan_40mg")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                    .patients_stationar_clexan_20mg = dbRecordset("patients_stationar_clexan_20mg")

-                    .patients_stationar_clexan_40mg = dbRecordset("patients_stationar_clexan_40mg")

-                 End With

-                 

-                 allHir(index) = tmpHir

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE ID=" & objHir.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Hir_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbTer
->>>>>>
-Attribute VB_Name = "dbTer"

-Option Explicit

-

-Public Type tTERAPIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objTer.ID <> 0 then updatre else insert

-Sub Insert_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objTer.id <> 0 Then

-        dbUpdate_Ter_Record dbConnection, objTer

-    Else

-        dbInsert_Ter_Record dbConnection, objTer

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Ter_RecordsByLPU_ID(ByRef allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Ter_RecordsByLPU_ID = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, allTer, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Ter_Record dbConnection, objTer

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objTer.ID <> 0 then updatre else insert

-

-Sub dbInsert_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_ter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objTer

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("risk_percent") = Double2Str(.risk_percent, 3)

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objTer.id = dbRecordset("ID")

-

-End Sub

-

-Sub test()

-    Dim s As String

-    Dim d As Single

-    d = 1235.6789

-    s = Format(d, "####0,00")

-    MsgBox s

-End Sub

-

-Sub dbUpdate_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim Update_SQL As String

-    

-    With objTer

-        Update_SQL = "UPDATE lpu_ter SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_Ter_RecordsbyLPU_ID(dbConnection As Object, allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Ter_SQL As String

-    Dim getAll_Ter_SQL As String

-    Dim Ter_Count As Long

-    Ter_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Ter_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Ter_Count = dbRecordset("TER_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Ter_RecordsbyLPU_ID = Ter_Count

-    

-    If Ter_Count > 0 Then

-        'we have records

-        ReDim allTer(1 To Ter_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_Ter_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpTer As tTERAPIA

-                 With tmpTer

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 allTer(index) = tmpTer

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE ID=" & objTer.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Ter_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-mLPU_LIST
->>>>>>
-Attribute VB_Name = "mLPU_LIST"

-Option Explicit

-

-Public Const CINP_AREA As String = "B12"

-Public Const CLPU_NAME As Integer = 0

-Public Const CLPU_NAME1 As Integer = 1

-Public Const CLPU_NAME2 As Integer = 2

-Public Const CLPU_ID As Integer = 3

-Public Const CLPU_BEDS As Integer = 4

-Public Const CLPU_NFG As Integer = 5

-Public Const CLPU_NMG As Integer = 6

-Public Const CLPU_HIR As Integer = 7

-Public Const CLPU_TER As Integer = 8

-Public Const CLPU_CAR As Integer = 9

-Public Const CLPU_FACT As Integer = 10

-Public Const CLPU_PLAN As Integer = 11

-Public Const CLPU_PAT_LPU As Integer = 16

-Public Const CLPU_BDGT As Integer = 17

-Public Const CLPU_PAT_ALL As Integer = 16

-

-

-

-Sub EditLPU(cLPU As tLPU, ent_date As String)

-    Dim del_request As Integer

-    Dim allLPU() As tLPU

-    Dim lpu_count As Integer

-    Dim i As Integer

-    Dim tmp_LPU_List As Range

-    Dim tmp_LPU_List_Addr As String

-    Dim r_end As Range

-    Dim dlg As Dlg_lpu_card

-    

-    Set dlg = New Dlg_lpu_card

-    

-    lpu_count = GetAllLPU(allLPU)

-    With Worksheets(VAR_SHEET)

-        Set tmp_LPU_List = .Range("tmp_LPU_List")

-        Set r_end = .Range(tmp_LPU_List, tmp_LPU_List.End(xlDown))

-        Set r_end = .Range(r_end, r_end.End(xlToRight))

-        .Range(tmp_LPU_List, r_end).ClearContents

-    End With

-        

-    If lpu_count <> 0 Then

-        dlg.cbxLPU_List_Enable.Enabled = True

-        For i = 1 To UBound(allLPU)

-            tmp_LPU_List.Cells(i, 1) = allLPU(i).name

-            tmp_LPU_List.Cells(i, 2) = allLPU(i).address

-            tmp_LPU_List.Cells(i, 3) = allLPU(i).beds

-            tmp_LPU_List.Cells(i, 4) = allLPU(i).id

-        Next i

-    Else

-        dlg.cbxLPU_List_Enable.Enabled = False

-    End If

-    

-    tmp_LPU_List_Addr = Worksheets(VAR_SHEET).name & "!" & _

-            Worksheets(VAR_SHEET).Range(tmp_LPU_List, tmp_LPU_List.End(xlDown)).address

-

-    With dlg

-        .cbLPU_List.RowSource = tmp_LPU_List_Addr

-        .cbLPU_List.ListIndex = 0

-        .cbxLPU_List_Enable = False

-        .cbLPU_List.Enabled = False

-        If cLPU.id <> 0 Then

-            .cbxLPU_List_Enable.Enabled = False

-        Else

-            If lpu_count <> 0 Then

-                .cbxLPU_List_Enable.Enabled = True

-            Else

-                .cbxLPU_List_Enable.Enabled = False

-            End If

-        End If

-        .tb_lpu_name.Text = cLPU.name

-        .tb_lpu_address.Text = cLPU.address

-        .tbBedsCount = cLPU.beds

-

-        .Tag = vbCancel

-    End With

-    

-    dlg.Show

-    

-    If Not IsNumeric(dlg.Tag) Then

-        Exit Sub

-    End If

-    

-    If dlg.Tag = vbOK Then

-        Dim n As Variant

-        Dim test As Integer

-        test = 0

-        n = dlg.tbBedsCount.Value

-        If Not IsNumeric(n) Then

-            test = 1

-        Else

-            If n = 0 Then

-                test = 1

-            End If

-        End If

-        If test = 0 Then

-            

-            cLPU.name = dlg.tb_lpu_name.Text

-            cLPU.address = dlg.tb_lpu_address.Text

-            cLPU.beds = dlg.tbBedsCount.Value

-                                    

-            If cLPU.name = "" Or cLPU.address = "" Then

-                test = 2

-            End If

-        End If

-        Select Case test

-            Case 0

-                If dlg.cbxLPU_List_Enable.Value = True Then

-                    cLPU.id = tmp_LPU_List.Cells(dlg.cbLPU_List.ListIndex + 1, 4)

-                End If

-                Insert_LPU_Record cLPU

-                ' Проверить наличие данных для ЛПУ в квартале

-                Dim bdgt As tBUDGET

-                bdgt = Get_BDGT_Record(cLPU.id, ent_date)

-                ' Записи нет: создать пустую запись в lpu_budget

-                If bdgt.id = 0 Then

-                    bdgt.lpu_id = cLPU.id

-                    bdgt.entry_date = ent_date

-                    Insert_BDGT_Record bdgt

-                End If

-            Case 1

-                MsgBox "Коечная мощьность измеряется числом более чем 1!", vbOKOnly, PROGRAM_NAME

-            Case 2

-                MsgBox "Наименование и адрес ЛПУ не должны быть пустыми!", vbOKOnly, PROGRAM_NAME

-        End Select

-    End If

-End Sub

-

-Sub Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-

-End Sub

-

-Sub Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btLPU_DEL_IT()

-    Dim cLPU As tLPU

-    Dim ent_date As String

-    Dim delete_all As Integer

-    Dim dlg_del As dlg_LPU_delete

-    

-    With Worksheets("LPU_LIST")

-        ent_date = .Range("ent_date")

-        cLPU.id = .getCurrentLPU_ID()

-    End With

-    

-    If cLPU.id = 0 Then

-        MsgBox "Укажите удаляемый объект", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    cLPU = Get_LPU_Record(cLPU.id)

-    

-    Set dlg_del = New dlg_LPU_delete

-    With dlg_del

-        .chbDeleteQTR.Value = True

-        .chbDeleteAll.Value = False

-        .lComment = ent_date & ": Удаление ЛПУ '" _

-        & cLPU.name & "', расположенного по адресу:" _

-        & cLPU.address & "."

-        .Show

-        

-        If .Tag = vbOK Then

-            If .chbDeleteAll.Value Then

-                delete_all = _

-                    MsgBox("Все записи об ЛПУ с именем '" & cLPU.name & _

-                    "' будут удалены навсегда.", vbOK, PROGRAM_NAME)

-                If delete_all = vbOK Then

-                    Delete_LPU_Record cLPU

-                End If

-            Else

-                Delete_LPU_RecordQTR cLPU, ent_date

-            End If

-        End If

-    End With

-    

-    With ThisWorkbook

-        .Worksheets(TITLE_SHEET).Select

-        .Worksheets("LPU_LIST").Select

-    End With

-End Sub

-

-Sub btLPU_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Activate

-End Sub

-

-

-Sub btLPU_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim lpu_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("QTR_ACTION").Value

-    With Worksheets("LPU_LIST")

-        ent_date = .getEnt_date()

-        

-    

-        lpu_id = .getCurrentLPU_ID

-        If lpu_id <> 0 And i = 1 Then

-            lpu_id = 0

-        End If

-        If lpu_id = 0 Then

-            i = 1

-        End If

-        Select Case i

-            Case 1, 6

-                .SelectLPU_NAME lpu_id, ent_date

-                .Range("JUMP") = ""

-            Case 2

-                If lpu_id <> 0 Then

-                    .SelectLPU_BDGT lpu_id, ent_date

-                    .Range("JUMP") = "LPU_BDGT"

-                End If

-            Case 3

-                If lpu_id <> 0 Then

-                    .SelectLPU_HIR lpu_id, ent_date

-                    .Range("JUMP") = "LPU_CLSN_HIR"

-                End If

-            Case 4

-                If lpu_id <> 0 Then

-                    .SelectLPU_TER lpu_id, ent_date

-                    .Range("JUMP") = "LPU_CLSN_TER"

-                End If

-            Case 5

-                If lpu_id <> 0 Then

-                    .SelectLPU_C_ACS lpu_id, ent_date

-                    .Range("JUMP") = "LPU_CLSN_C_ACS"

-                End If

-        End Select

-    End With

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-dbQTR
->>>>>>
-Attribute VB_Name = "dbQTR"

-Option Explicit

-

-Public Type tQTR

-    id As Long

-    entry_date As String

-    rep_id As Long

-    sale_plan As Long

-    ClxnH20mg As Long

-    ClxnH40mg As Long

-    ClxnT40mg As Long

-    ClxnC_IM As Long

-    ClxnC_ACS As Long

-End Type

-

-

-Function GetLastQTR_fromDB() As String

-    Dim dbConnection As Object

-    Dim getCount_QTR_SQL As String

-    Dim getLast_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter"

-    getLast_QTR_SQL = "SELECT MAX(entry_date) as ent_date FROM quarter"

-    

-    dbOpenConnection dbConnection

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    If QTR_Count > 0 Then

-        'we have records

-        dbRecordset.Open getLast_QTR_SQL, dbConnection

-        getLast_QTR_SQL = dbRecordset("ent_date")

-    Else

-        getLast_QTR_SQL = ""

-    End If

-    

-    GetLastQTR_fromDB = getLast_QTR_SQL

-    dbCloseConnection dbConnection

-End Function

-

-Sub Insert_QTR_Record(ByRef objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objQTR.id <> 0 Then

-        dbUpdate_QTR_Record dbConnection, objQTR

-    Else

-        dbInsert_QTR_Record dbConnection, objQTR

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-Function Get_QTR_Record(ent_date As String) As tQTR

-    Dim dbConnection As Object

-    Dim allQTR() As tQTR

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    i = dbGetAll_QTR_Records(dbConnection, allQTR, ent_date)

-    If i <> 0 Then

-        Get_QTR_Record = allQTR(1)

-    End If

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTR_Records(ByRef All_QTR() As tQTR, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_QTR_Records = dbGetAll_QTR_Records(dbConnection, All_QTR, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_QTR_Record(ByRef objQTR As tQTR)

-    Dim dbConnection As Object

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_QTR_Record dbConnection, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objQTR.ID <> 0 then updatre else insert

-Sub dbInsert_QTR_Record(dbConnection As Object, ByRef objQTR As tQTR)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "quarter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objQTR

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("sale_plan") = .sale_plan

-        dbRecordset("rep_id") = .rep_id

-        dbRecordset("ClxnH20mg") = .ClxnH20mg

-        dbRecordset("ClxnH40mg") = .ClxnH40mg

-        dbRecordset("ClxnT40mg") = .ClxnT40mg

-        dbRecordset("ClxnC_IM") = .ClxnC_IM

-        dbRecordset("ClxnC_ACS") = .ClxnC_ACS

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objQTR.id = dbRecordset("id")

-

-End Sub

-

-Sub dbUpdate_QTR_Record(dbConnection As Object, ByRef objQTR As tQTR)

-    Dim Update_SQL As String

-    

-    With objQTR

-        Update_SQL = "UPDATE quarter SET " & _

-            "entry_date='" & .entry_date & "'" & "," & _

-            "rep_id=" & .rep_id & "," & _

-            "sale_plan=" & .sale_plan & "," & _

-            "ClxnH20mg=" & .ClxnH20mg & "," & _

-            "ClxnH40mg=" & .ClxnH40mg & "," & _

-            "ClxnT40mg=" & .ClxnT40mg & "," & _

-            "ClxnC_IM=" & .ClxnC_IM & "," & _

-            "ClxnC_ACS=" & .ClxnC_ACS & _

-            " WHERE id=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if ent_date = % then all_records

-Function dbGetAll_QTR_Records(dbConnection As Object, All_QTR() As tQTR, ent_date As String) As Integer

-    

-    Dim getCount_QTR_SQL As String

-    Dim getAll_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter WHERE entry_date like '" & ent_date & "'"

-    getAll_QTR_SQL = "SELECT * FROM quarter WHERE entry_date like '" & ent_date & "' ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_QTR_Records = QTR_Count

-    

-    If QTR_Count > 0 Then

-        'we have records

-        ReDim All_QTR(1 To QTR_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTR_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTR As tQTR

-                 With tmp_QTR

-                    .entry_date = dbRecordset("entry_date")

-                    .rep_id = dbRecordset("rep_id")

-                    .sale_plan = dbRecordset("sale_plan")

-                    .ClxnH20mg = dbRecordset("ClxnH20mg")

-                    .ClxnH40mg = dbRecordset("ClxnH40mg")

-                    .ClxnT40mg = dbRecordset("ClxnT40mg")

-                    .ClxnC_IM = dbRecordset("ClxnC_IM")

-                    .ClxnC_ACS = dbRecordset("ClxnC_ACS")

-                    .id = dbRecordset("id")

-                 End With

-                 

-                 All_QTR(index) = tmp_QTR

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_QTR_Record(dbConnection As Object, ByRef objQTR As tQTR)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM quarter " & _

-    "WHERE id=" & objQTR.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByQTR dbConnection, objQTR.entry_date

-    dbDelete_Hir_RecordsByQTR dbConnection, objQTR.entry_date

-    dbDelete_Ter_RecordsByQTR dbConnection, objQTR.entry_date

-    dbDelete_ACS_RecordsByQTR dbConnection, objQTR.entry_date

-       

-End Sub

-<<<<<<
-======================
-cdbQTR
->>>>>>
-Attribute VB_Name = "cdbQTR"

-Option Explicit

-

-Public Type tQTR_COMMON

-    qtr As tQTR

-    i_lcd As Long           ' число ЛПУ в СПИСКЕ

-    lcd() As tLPU_COMMON    ' список ЛПУ

-    c_beds As Long          ' сумма коек

-    c_bdgt_NFG As Long      ' общий бюджет на НФГ

-    c_bdgt_NMG As Long      ' общий бюджет на НМГ

-    c_bdgt_LPU As Long      ' общий бюджет на гепарины

-    c_sale_PLAN As Long     ' план продаж репа

-    c_sale_ALL As Long      ' продажи

-    c_sale_HIR As Long      ' в хирургии

-    c_sale_TER  As Long     ' в терапии

-    c_sale_CRD  As Long     ' в кардиологии

-    c_pat_HIR   As Long     ' пациенты

-    c_pat_TER   As Long     '

-    c_pat_CRD   As Long     '

-    c_pat_ALL   As Long     '

-    c_pat_LPU   As Long     ' Всего операций

-End Type

-

-Function Get_QTR_CommonList(ByRef qcd() As tQTR_COMMON) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_QTR_CommonList = dbGet_QTR_CommonList(dbConnection, qcd)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_CommonList(dbConnection As Object, ByRef qcd() As tQTR_COMMON) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim allQTR() As tQTR

-    i = dbGetAll_QTR_Records(dbConnection, allQTR, "%")

-    dbGet_QTR_CommonList = i

-    If i > 0 Then

-        ReDim qcd(i)

-        For i = 1 To UBound(allQTR)

-            With qcd(i)

-                .qtr = allQTR(i)

-                .c_beds = 0

-                .c_bdgt_NFG = 0

-                .c_bdgt_NMG = 0

-                .c_bdgt_LPU = 0

-                .c_sale_PLAN = 0

-                .c_pat_HIR = 0

-                .c_pat_TER = 0

-                .c_pat_CRD = 0

-                .c_pat_ALL = 0

-                .c_sale_HIR = 0

-                .c_sale_TER = 0

-                .c_sale_CRD = 0

-                .c_sale_ALL = 0

-                .c_pat_LPU = 0

-                

-                j = dbGet_LPU_CommonQTR(dbConnection, .lcd, .qtr)

-                .i_lcd = j

-                If j > 0 Then

-                    For j = 1 To UBound(.lcd)

-                        .c_beds = .c_beds + .lcd(j).lpu.beds

-                        .c_bdgt_NFG = .c_bdgt_NFG + .lcd(j).bdgt.bdgt_NFG

-                        .c_bdgt_NMG = .c_bdgt_NMG + .lcd(j).bdgt.bdgt_NMG

-                        .c_bdgt_LPU = .c_bdgt_LPU + .lcd(j).bdgt_LPU

-                        .c_sale_PLAN = .c_sale_PLAN + .lcd(j).bdgt.sale_plan

-                        .c_pat_HIR = .c_pat_HIR + .lcd(j).pat_HIR

-                        .c_pat_TER = .c_pat_TER + .lcd(j).pat_TER

-                        .c_pat_CRD = .c_pat_CRD + .lcd(j).pat_CRD

-                        .c_pat_ALL = .c_pat_ALL + .lcd(j).pat_ALL

-                        .c_sale_HIR = .c_sale_HIR + .lcd(j).sale_HIR

-                        .c_sale_TER = .c_sale_TER + .lcd(j).sale_TER

-                        .c_sale_CRD = .c_sale_CRD + .lcd(j).sale_CRD

-                        .c_sale_ALL = .c_sale_ALL + .lcd(j).sale_ALL

-                        .c_pat_LPU = .c_pat_LPU + .lcd(j).pat_LPU

-                    Next j

-                    

-                End If

-            End With

-        Next i

-    End If

-End Function

-

-Function GetLastQtr() As String

-    Dim s As String

-    Dim r As Range

-    Set r = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Do While r.Cells(1, 1) <> ""

-        s = r.Cells(1, 1)

-        Set r = r.Cells.Offset(1, 0)

-    Loop

-    GetLastQtr = s

-End Function

-

-Function GetNextQTR(ent_date As String) As String

-    Dim rd As Range

-    Dim idx As Integer

-    Dim b As Variant

-    Dim dlg As dlg_newQTR

-    Set dlg = New dlg_newQTR

-    

-    On Error GoTo l_exit

-    If ent_date = "" Then

-        Dim ir As Variant

-        idx = 0

-        dlg.Show

-        b = dlg.Tag

-            

-        If IsNumeric(b) Then

-            GetNextQTR = dlg.cbQTR

-        Else

-            GetNextQTR = ""

-        End If

-    Else

-        Set rd = Worksheets(VAR_SHEET).Range("Date_Lst")

-        idx = WorksheetFunction.Match(ent_date, rd, 0)

-        GetNextQTR = WorksheetFunction.index(rd, idx + 1, 1)

-    End If

-l_exit:

-End Function

-<<<<<<
-======================
-mRestView
->>>>>>
-Attribute VB_Name = "mRestView"

-Option Explicit

-

-Sub xlRestoreView()

-Attribute xlRestoreView.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute xlRestoreView.VB_ProcData.VB_Invoke_Func = " \n14"

-    With Application

-        .CommandBars("Standard").Visible = True

-        .CommandBars("Formatting").Visible = True

-        .DisplayFormulaBar = True

-        .DisplayStatusBar = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = True

-        .EditDirectlyInCell = True

-    End With

-End Sub

-<<<<<<
-======================
-dlg_newQTR
->>>>>>
-Attribute VB_Name = "dlg_newQTR"

-Attribute VB_Base = "0{2FC04B4C-EB99-433E-ACDB-A920D02B9B5B}{777B85CC-ADE3-4188-94C8-9E07DA8B5076}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mDec2TS
->>>>>>
-Attribute VB_Name = "mDec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-CHRT_LPU_BBL
->>>>>>
-Attribute VB_Name = "CHRT_LPU_BBL"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Unprotect

-    Range("view_key") = True

-    On Error Resume Next

-    ChangeLabels

-    Range("A1").Select

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Unprotect

-    Dim s As String

-    s = Range("ret_addr")

-    Protect UserInterfaceOnly:=True

-    Wks_select (s)

-End Sub

-

-Sub BCLabelChng_Click()

-    Unprotect

-    If Range("view_key") Then

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать названия"

-    Else

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать объемы"

-    End If

-    Range("view_key") = Not Range("view_key")

-    ChangeLabels

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub ChangeLabels()

-    Dim i As Integer

-    Dim offset_text As Integer

-    Dim src As Range

-    Set src = Range("CHRT_BBL_DATA")

-    

-    offset_text = 3

-    If Range("view_key") Then

-        offset_text = 4

-    End If

-    

-    On Error GoTo ExitLabel

-    

-    With ChartObjects(1).Chart

-        With .SeriesCollection(1)

-            For i = 1 To .Points.Count

-                On Error Resume Next

-                .Points(i).DataLabel.Characters.Text = Format(src.Cells(i, offset_text))

-            Next i

-        End With

-    End With

-ExitLabel:

-End Sub

-

-<<<<<<
-======================
-CHRT_PAT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PAT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-<<<<<<
-======================
-CHRT_PAT_LPU
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_nextQTR
->>>>>>
-Attribute VB_Name = "dlg_nextQTR"

-Attribute VB_Base = "0{3F7D7D75-90F6-4829-9E24-CA5391BB2A03}{A1A0F296-0D28-4123-8E38-82FA6EE6F2EF}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-

-<<<<<<
-======================
-cdbLPU
->>>>>>
-Attribute VB_Name = "cdbLPU"

-Option Explicit

-

-Public Type tLPU_COMMON

-    lpu As tLPU

-    bdgt As tBUDGET

-    i_hir As Long

-    hir() As tHIRURGIA

-    i_ter As Long

-    ter() As tTERAPIA

-    i_ACS As Long

-    ACS() As tACS

-    bdgt_LPU As Long

-    sale_HIR As Long

-    sale_TER As Long

-    sale_CRD As Long

-    sale_ALL As Long

-    pat_HIR As Long

-    pat_TER As Long

-    pat_CRD As Long

-    pat_ALL As Long     ' Сумма всех пациентов на клексане

-    pat_LPU As Long     ' Число потенциальных пациентов для продаж клексана

-End Type

-

-Function Get_LPU_CommonQTR(ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    Get_LPU_CommonQTR = dbGet_LPU_CommonQTR(dbConnection, lcd, objQTR)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_CommonQTR(dbConnection As Object, ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    i = dbGetAllLPUbyQTR(dbConnection, allLPU, objQTR.entry_date)

-    dbGet_LPU_CommonQTR = i

-    If i > 0 Then

-        ReDim lcd(i)

-        For i = 1 To UBound(allLPU)

-            dbGet_LPU_Common dbConnection, lcd(i), allLPU(i), objQTR

-        Next i

-    End If

-End Function

-

-Sub Get_LPU_Common(ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    dbGet_LPU_Common dbConnection, lcd, cLPU, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbGet_LPU_Common(dbConnection As Object, ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-

-    lcd.lpu = cLPU

-    lcd.bdgt = dbGet_BDGT_Record(dbConnection, cLPU.id, objQTR.entry_date)

-    lcd.i_hir = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, lcd.hir, cLPU.id, objQTR.entry_date)

-    lcd.i_ter = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, lcd.ter, cLPU.id, objQTR.entry_date)

-    lcd.i_ACS = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, lcd.ACS, cLPU.id, objQTR.entry_date)

-    With lcd

-        .bdgt_LPU = .bdgt.bdgt_NFG + .bdgt.bdgt_NMG

-        .pat_LPU = 0

-        If .i_hir > 0 Then

-            .pat_HIR = .hir(1).patients_ambulator_clexan + .hir(1).patients_stationar_clexan

-            .sale_HIR = objQTR.ClxnH20mg * (.hir(1).patients_ambulator_clexan_20mg + .hir(1).patients_stationar_clexan_20mg)

-            .sale_HIR = .sale_HIR + objQTR.ClxnH40mg * (.hir(1).patients_ambulator_clexan_40mg + .hir(1).patients_stationar_clexan_40mg)

-            .pat_LPU = .pat_LPU + .hir(1).operations_per_quarter

-        End If

-        If .i_ter > 0 Then

-            .pat_TER = .ter(1).patients_ambulator_clexan + .ter(1).patients_stationar_clexan

-            .sale_TER = .pat_TER * objQTR.ClxnT40mg

-            .pat_LPU = .pat_LPU + .ter(1).patients_per_quarter

-        End If

-        If .i_ACS > 0 Then

-            .pat_CRD = .ACS(1).patients_stationar_clexan

-            .sale_CRD = .pat_CRD * objQTR.ClxnC_ACS

-            .pat_LPU = .pat_LPU + .ACS(1).patients_per_quarter

-        End If

-        .pat_ALL = .pat_HIR + .pat_TER + .pat_CRD

-        .sale_ALL = .sale_HIR + .sale_TER + .sale_CRD

-    End With

-End Sub

-

-<<<<<<
-======================
-CHRT_PIE
->>>>>>
-Attribute VB_Name = "CHRT_PIE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-   

-    Unprotect

-    On Error Resume Next

-    Range("P5:Q24").Sort _

-        Key1:=Range("Q5"), _

-        Order1:=xlDescending, _

-        Header:=xlGuess, _

-        OrderCustom:=1, _

-        MatchCase:=False, _

-        Orientation:=xlTopToBottom

-        

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PLN_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PLN_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_BDGT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_BDGT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_LPU_delete
->>>>>>
-Attribute VB_Name = "dlg_LPU_delete"

-Attribute VB_Base = "0{91AE5FA0-01C7-4C10-9E5F-D1D2DDF29401}{5726592A-BC0A-4E79-A963-35D354045716}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlg_Mail
->>>>>>
-Attribute VB_Name = "dlg_Mail"

-Attribute VB_Base = "0{FB055133-927F-41FF-BC90-442833A40591}{11BCAB43-1EDD-440B-AB0E-20CD6E42E11A}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dbREP_id
->>>>>>
-Attribute VB_Name = "dbREP_id"

-Public Type tID_REP

-    id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Public Type tID_REP_COMMON

-    id_rep As tID_REP

-    i_qtr As Long

-    qtrs As tQTR_COMMON

-End Type

-<<<<<<
-======================
-cdbExport
->>>>>>
-Attribute VB_Name = "cdbExport"

-Option Explicit

-

-Function GetDBSN() As String

-    Dim n As Long

-    Randomize Timer

-    n = Int((100000000 - 1000000 + 1) * Rnd + 1000000)

-    GetDBSN = Dec2ThirtySix(n)

-End Function

-

-Sub dbExport()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim last_qtr As String

-    

-    On Error GoTo ErrHandler

-    

-    last_qtr = GetLastQTR_fromDB

-    If last_qtr = "" Then

-        MsgBox "Нет записей в базе данных. Экспорт невозможен.", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & last_qtr & "_" & GetDBSN() & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Данные экспортированы в файл:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для передачи", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-Exit Sub

-

-ErrHandler:

-    If err.number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-<<<<<<
-======================
-mRegs
->>>>>>
-Attribute VB_Name = "mRegs"

-Option Explicit

-

-Function GetRegionName(idx As Integer) As String

-    GetRegionName = Worksheets(REGS_SHEET).Range("LST_REGIONS").Cells(idx + 1, 1).Text

-End Function

-

-Function GetCityName(idx_reg As Integer, idx_city As Integer) As String

-    GetCityName = Worksheets(REGS_SHEET).Range("CITY_TABLES").Offset(idx_city + 1, idx_reg * 2).Text

-End Function

-

-Sub t()

-    Dim r As Integer

-    Dim c As Integer

-    Dim s As String

-    

-    r = 3

-    c = 3

-    s = GetRegionName(r)

-    s = s & ", " & GetCityName(r, c)

-    MsgBox s

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-<<<<<<
-======================
-xTEST_NUM
->>>>>>
-Attribute VB_Name = "xTEST_NUM"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mSerialTNT
->>>>>>
-Attribute VB_Name = "mSerialTNT"

-Option Explicit

-Const MAX_NUM1 As Integer = ThirtySixBase

-Const MAX_NUM2 As Integer = ThirtySixBase ^ 2 / 2

-Const MAX_NUM3 As Integer = ThirtySixBase

-

-Const USERID_BASE As Long = ThirtySixBase ^ 3

-

-Const SRVC_BASE As Integer = 1000

-Const SRVC_MAX As Integer = 1999

-

-Const ORG_BASE As Integer = 100

-Const ORG_MAX As Integer = 199

-

-Sub test()

-    Dim user() As String

-    Dim i

-    Dim r As Range

-    Dim s As String

-    

-    Application.ScreenUpdating = False

-    

-    Dim calc_type As Integer

-    calc_type = Application.Calculation

-    Application.Calculation = xlCalculationManual

-   

-    Set r = Worksheets("TEST_SN").Range("B3")

-    For i = 0 To 50000

-        user = getNextSerial(1000, 100)

-        r = "'" & user(1)

-        r.Offset(0, 1) = "'" & user(2)

-        r.Offset(0, 2) = Len(user(1))

-        r.Offset(0, 3) = Len(user(2))

-        If i <> 0 Then

-            s = "=IF(" & r.Address & "=" & r.Offset(-1, 0).Address & ",1,0)"

-            r.Offset(0, 4).Formula = s

-        End If

-        Set r = r.Offset(1, 0)

-    Next i

-    

-    Application.Calculation = calc_type

-    Application.ScreenUpdating = False

-

-End Sub

-

-Function getNextSerial(srv As Integer, org As Integer) As String()

-    Dim num1 As Integer

-    Dim num2 As Integer

-    Dim num3 As Integer

-    Dim rdate As Long

-    Dim userID As Long

-    

-    num1 = nextNumber(MAX_NUM1)

-    num2 = nextNumber(MAX_NUM2)

-    num3 = nextNumber(MAX_NUM3)

-    

-    rdate = get_sn_date

-    

-    userID = nextUserID

-    

-    Dim serial As String

-    

-    serial = "" & srv & org & rdate & userID & num1 & num2 & num3

-    

-    Dim serial_SN As Integer

-    

-    serial_SN = get_serial_check_sum(serial)

-    

-    Dim login_1 As Long

-    Dim login_2 As Long

-    

-    Dim pass_1 As Long

-    Dim pass_2 As Long

-    

-    login_1 = "" & userID & serial_SN

-    login_2 = "" & num3 & rdate

-    

-    pass_1 = "" & num1 & srv

-    pass_2 = "" & num2 & org

-    

-    Dim out(2) As String

-    out(1) = Dec2ThirtySix(login_1) & Dec2ThirtySix(login_2)

-    out(2) = Dec2ThirtySix(pass_1) & Dec2ThirtySix(pass_2)

-    

-    getNextSerial = out

-End Function

-

-Function get_serial_check_sum(id_sn As String) As Integer

-    Dim i As Integer

-    Dim s As String

-    Dim chk As Integer

-    

-    s = id_sn

-    chk = 0

-    While s <> ""

-        i = Left(s, 1)

-        chk = (chk + i) Mod 10

-        s = Right(s, Len(s) - 1)

-    Wend

-    get_serial_check_sum = chk

-End Function

-

-Function get_sn_date() As Long

-    Dim d_date As Long

-    d_date = (Year(Now()) Mod 10)

-    d_date = d_date * 10000

-    d_date = d_date + Month(Now()) * 100

-    d_date = d_date + Day(Now())

-    get_sn_date = d_date

-End Function

-

-Function nextUserID() As Long

-    nextUserID = USERID_BASE + Int(Rnd() * USERID_BASE)

-End Function

-

-Function nextNumber(base As Integer) As Integer

-    nextNumber = base + Int(Rnd() * base)

-End Function

-

-Function serial_check_id_sum(id_sn As String) As Integer

-    Dim i As Integer

-    Dim s As String

-    Dim chk As Integer

-    

-    s = id_sn

-    chk = 0

-    While s <> ""

-        i = Left(s, 1)

-        chk = (chk + i) Mod 10

-        s = Right(s, Len(s) - 1)

-    Wend

-    serial_check_id_sum = chk

-End Function

-

-<<<<<<
-======================
-xTEST_SER
->>>>>>
-Attribute VB_Name = "xTEST_SER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Dec2TS
->>>>>>
-Attribute VB_Name = "Dec2TS"

-Option Explicit

-

-'Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-'Const ThirtySixBase As Integer = 36

-

-Public Const ThirtySixNumbers As String = "123456789ABCDEFGHIJKLMNPQRSTUVWXYZ"

-Public Const ThirtySixBase As Integer = 34

-

-Function randSN(Optional n As Integer = 34) As String

-    Dim t(ThirtySixBase) As String

-    Dim i As Integer

-    Dim j, k As Integer

-    Dim r As String

-    

-    For i = 1 To UBound(t)

-        t(i) = Mid(ThirtySixNumbers, i, 1)

-    Next i

-    For i = 1 To n

-        j = Int((ThirtySixBase * Rnd) + 1)

-        k = i Mod ThirtySixBase + 1

-        r = t(k)

-        t(k) = t(j)

-        t(j) = r

-    Next i

-    r = ""

-    For i = 1 To UBound(t)

-        r = r + t(i)

-    Next i

-    randSN = r

-End Function

-Function Dec2ThirtySix(ByVal Dec As Long) As String

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Double

-    

-    ThirtySixStr = TS

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If ThirtySixStr = "" Then

-        Dec = 0

-    Else

-        While ThirtySixStr <> ""

-            lastdigit = Right(ThirtySixStr, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            ThirtySixStr = Mid(ThirtySixStr, 1, Len(ThirtySixStr) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-

-Sub test()

-    Dim l As Long

-    l = ThirtySix2Dec("2HPI")

-    l = ThirtySix2ChkSum("2HPI")

-End Sub

-

-Function ThirtySix2ChkSum(TS As String) As Integer

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim chksum As Integer

-    

-    ThirtySixStr = TS

-

-    chksum = 0

-    

-    If ThirtySixStr = "" Then

-        chksum = 0

-    Else

-        While ThirtySixStr <> ""

-            lastdigit = Right(ThirtySixStr, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit) - 1

-            chksum = (chksum + idx) Mod ThirtySixBase

-            ThirtySixStr = Left(ThirtySixStr, Len(ThirtySixStr) - 1)

-        Wend

-    End If

-

-    ThirtySix2ChkSum = chksum

-End Function

-<<<<<<
-======================
-newItemDlg
->>>>>>
-Attribute VB_Name = "newItemDlg"

-Attribute VB_Base = "0{0B5E9521-7808-446E-9E61-7D38E1C2651A}{1C691B41-AC71-4558-927D-1487F1C50C72}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub AddSYS_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub resetSYS_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-<<<<<<
-======================
-Dec2Hex
->>>>>>
-Attribute VB_Name = "Dec2Hex"

-Option Explicit

-

-

-Const HexNumbers As String = "0123456789ABCDEF"

-Const HexBase As Integer = 16

-Const ThirtyNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRST"

-Const ThirtyBase As Integer = 30

-

-Function sDec2Hex(Dec As Long) As String

-    Dim HexStr As String

-    Dim idx As Integer

-    

-    HexStr = ""

-    

-    If Dec = 0 Then

-        HexStr = Mid(HexNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod HexBase

-            HexStr = Mid(HexNumbers, idx + 1, 1) + HexStr

-            Dec = Dec \ HexBase

-        Wend

-    End If

-    sDec2Hex = HexStr

-End Function

-

-Function Hex2Dec(HexString As String) As Long

-    Dim digit As Integer

-    Dim ch As String

-    Dim hexpower As Integer

-    Dim hexnum As String

-    Dim decnumber As Long

-    

-    hexnum = UCase(HexString)

-    hexpower = 0

-    decnumber = 0

-    

-    While hexnum <> ""

-        ch = Right(hexnum, 1)

-        hexnum = Left(hexnum, Len(hexnum) - 1)

-        digit = InStr(1, HexNumbers, ch, vbBinaryCompare)

-        decnumber = decnumber + digit ' power(hexbase, hexpower)

-        hexpower = hexpower + 1

-    Wend

-    Hex2Dec = decnumber

-End Function

-

-

-

-Function Dec2Thirty(Dec As Long) As String

-    

-    Dim ThirtyStr As String

-    Dim idx As Integer

-    

-    ThirtyStr = ""

-    

-    If Dec = 0 Then

-        ThirtyStr = Mid(ThirtyNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtyBase

-            ThirtyStr = Mid(ThirtyNumbers, idx + 1, 1) + ThirtyStr

-            Dec = Dec \ ThirtyBase

-        Wend

-    End If

-    Dec2Thirty = ThirtyStr

-End Function

-

-<<<<<<
-======================
-TEST_SN
->>>>>>
-Attribute VB_Name = "TEST_SN"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ETIME
->>>>>>
-Attribute VB_Name = "ETIME"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Tools
->>>>>>
-Attribute VB_Name = "Tools"

-Option Explicit

-

-Function GetLinesCount(ByVal Location As Range) As Long

-    Dim n As Long

-    n = 0

-    Do While Location.Offset(n, 0) <> ""

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Sub hide_sheets()

-    Dim ws As Worksheet

-    Dim wsname As String

-    For Each ws In ThisWorkbook.Worksheets

-        wsname = ws.Name

-        ws.Protect UserInterfaceonly:=True

-        If Left(wsname, 1) = "x" Then

-            ws.EnableCalculation = False

-            ws.Visible = xlSheetVeryHidden

-        End If

-    Next ws

-End Sub

-

-Sub show_sheets()

-    Dim ws As Worksheet

-    Dim wsname As String

-    For Each ws In ThisWorkbook.Worksheets

-        ws.Unprotect

-        wsname = ws.Name

-        If Left(wsname, 1) = "x" Then

-            ws.EnableCalculation = True

-            ws.Visible = xlSheetVisible

-        End If

-    Next ws

-End Sub

-

-Sub check_sn_seria()

-    Dim r1 As Range

-    Dim r2 As Range

-    Dim i As Long

-    Dim j As Long

-    

-    Dim calc_type As Integer

-    calc_type = Application.Calculation

-    Application.Calculation = xlCalculationManual

-    

-    Set r1 = Worksheets("OEM_100").Range("B7")

-    Set r2 = Worksheets("OEM_100").Range("C7")

-        

-    i = GetLinesCount(r1)

-    j = GetLinesCount(r2)

-    

-    Dim as1() As String

-    Dim as2() As String

-    

-    ReDim as1(i)

-    ReDim as2(j)

-    

-    i = 1

-    While r1 <> ""

-        as1(i) = r1

-        as2(i) = r2

-        Set r1 = r1.Offset(1, 0)

-        Set r2 = r2.Offset(1, 0)

-        i = i + 1

-    Wend

-    

-    Set r1 = Worksheets("OEM_100").Range("E6")

-    Set r2 = Worksheets("OEM_100").Range("E7")

-    

-    r1.EntireColumn.ClearContents

-    r1.Offset(0, 1).EntireColumn.ClearContents

-    r1.Select

-    

-    For i = 1 To UBound(as1)

-        r1 = i

-        For j = 1 To UBound(as2)

-            If as1(i) = as2(j) Then

-                r2 = i

-                r2.Offset(0, 1) = j

-                r1.Offset(0, 1) = r1.Offset(0, 1) + 1

-            End If

-        Next j

-    Next i

-    If r2.Row = 7 Then

-        r2 = ";-)"

-    End If

-    Application.Calculation = calc_type

-    Application.Calculate

-End Sub

-

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Tools
->>>>>>
-Attribute VB_Name = "Tools"

-Option Explicit

-

-Sub Dom2_Stat()

-    Dim sr As Range

-    

-    Set sr = Worksheets("DOM2-Stat1w").Range("c7:e54")

-    

-    DelAllBlanks sr

-End Sub

-

-Sub Dom2_Stat2()

-    Dim sr As Range

-    

-    Set sr = Worksheets("DOM2-Stat2w").Range("e7:e92")

-    

-    DelAllPercentage sr

-End Sub

-

-Sub DelAllBlanks(ByRef r As Range)

-    Dim c As Range

-    Dim s_in As String

-    Dim s_out As String

-    Dim spaceIdx As Integer

-    

-    For Each c In r

-        s_in = c.Value2

-        s_out = Left(s_in, Len(s_in) - 4) + Right(s_in, 3)

-        c = s_out

-        c.NumberFormat = "###"

-    Next c

-End Sub

-

-Sub DelAllPercentage(ByRef r As Range)

-    Dim c As Range

-    Dim s_in As String

-    Dim s_out As String

-    Dim spaceIdx As Integer

-    

-    For Each c In r

-        s_in = c.Value2

-        s_in = Left(s_in, InStr(s_in, "(") - 2)

-        If Len(s_in) > 4 Then

-            s_out = Left(s_in, Len(s_in) - 4) + Right(s_in, 3)

-        Else

-            s_out = s_in

-        End If

-        c = s_out

-        c.NumberFormat = "###"

-    Next c

-End Sub

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Digit2String
->>>>>>
-Attribute VB_Name = "Digit2String"

-Sub main()

-

-Dim dd As Double

-Dim st As String

-

-dd = 21.2234

-

-' 0 - rub

-' 1 - y.e.

-

-st = Digit2String(dd, 1)

-

-End Sub

-

-Function Digit2String(digit As Double, p As Integer) As String

-

-' Макрос записан 18.06.01 mikle-2

-Dim W1(20) As String

-Dim W1a(20) As String

-Dim W10(10) As String

-Dim W100(10) As String

-Dim W1000(10) As String

-

-W1(0) = ""

-W1(1) = "один"

-W1(2) = "два"

-W1(3) = "три"

-W1(4) = "четыре"

-W1(5) = "пять"

-W1(6) = "шесть"

-W1(7) = "семь"

-W1(8) = "восемь"

-W1(9) = "девять"

-W1(10) = "десять"

-W1(11) = "одинадцать"

-W1(12) = "двенадцать"

-W1(13) = "тринадцать"

-W1(14) = "четырнадцать"

-W1(15) = "пятнадцать"

-W1(16) = "шестнадцать"

-W1(17) = "семнадцать"

-W1(18) = "восемнадцать"

-W1(19) = "девятнадцать"

-W1a(0) = ""

-W1a(1) = "одна"

-W1a(2) = "две"

-W1a(3) = "три"

-W1a(4) = "четыре"

-W1a(5) = "пять"

-W1a(6) = "шесть"

-W1a(7) = "семь"

-W1a(8) = "восемь"

-W1a(9) = "девять"

-W1a(10) = "десять"

-W1a(11) = "одинадцать"

-W1a(12) = "двенадцать"

-W1a(13) = "тринадцать"

-W1a(14) = "четырнадцать"

-W1a(15) = "пятнадцать"

-W1a(16) = "шестнадцать"

-W1a(17) = "семнадцать"

-W1a(18) = "восемнадцать"

-W1a(19) = "девятнадцать"

-W10(0) = ""

-W10(1) = "десять"

-W10(2) = "двадцать"

-W10(3) = "тридцать"

-W10(4) = "сорок"

-W10(5) = "пятьдесят"

-W10(6) = "шестьдесят"

-W10(7) = "семьдесят"

-W10(8) = "восемьдесят"

-W10(9) = "девяносто"

-W100(0) = ""

-W100(1) = "сто"

-W100(2) = "двести"

-W100(3) = "триста"

-W100(4) = "четыреста"

-W100(5) = "пятьсот"

-W100(6) = "шестьсот"

-W100(7) = "семьсот"

-W100(8) = "восемьсот"

-W100(9) = "девятьсот"

-

-Result = ""

-

-e = Int((digit - Int(digit)) * 100) ' decimal

-digit_long = Int(digit)

-a = Int(digit_long / 1000000) '32123456/1000000 = 32 -> 10^6

-b = digit_long - (a * 1000000) '32123456-32000000 = 123456

-c = Int(b / 1000) '123456/1000 = 123 -> 10^3

-d = b - (c * 1000) '123456-123*1000 = 456 -> 1

-

-Add = ""

-For i = 2 To 0 Step -1

-    m = Int(a / (10 ^ i))

-    If i = 2 Then

-        If m <> 0 Then

-            R = W100(m) + " "

-            Add = "миллионов "

-        End If

-    End If

-    If i = 1 Then

-        If m <> 0 Then

-            If a < 20 Then

-                Result = Result + W1(a) + " миллионов "

-                GoTo con_0

-            End If

-            R = W10(m) + " "

-            Add = "миллионов "

-        End If

-    End If

-    If i = 0 Then

-        If m <> 0 Then

-            If m >= 5 Then

-                R = W1(m) + " "

-                Add = "миллионов "

-            End If

-            If m <= 4 Then

-                R = W1(m) + " "

-                Add = "миллиона "

-            End If

-            If m = 1 Then

-                R = "один "

-                Add = "миллион "

-            End If

-        End If

-        

-    End If

-    a = a - (m * (10 ^ i))

-    Result = Result + R

-    R = ""

-Next i

-Result = Result + Add

-con_0:

-

-Add = ""

-For i = 2 To 0 Step -1

-    m = Int(c / (10 ^ i))

-    If i = 2 Then

-        If m <> 0 Then

-            R = W100(m) + " "

-            Add = "тысяч "

-        End If

-    End If

-    If i = 1 Then

-        If m <> 0 Then

-            If c < 20 Then

-                Result = Result + W1(c) + " тысяч "

-                GoTo con_1

-            End If

-            R = W10(m) + " "

-            Add = "тысяч "

-        End If

-    End If

-    If i = 0 Then

-        If m <> 0 Then

-            If m >= 5 Then

-                R = W1(m) + " "

-                Add = "тысяч "

-            End If

-            If m <= 4 Then

-                R = W1(m) + " "

-                Add = "тысячи "

-            End If

-            If m = 2 Then

-                R = "две "

-                Add = "тысячи "

-            End If

-            If m = 1 Then

-                R = "одна "

-                Add = "тысяча "

-            End If

-        End If

-    End If

-    c = c - (m * (10 ^ i))

-    Result = Result + R

-    R = ""

-Next i

-Result = Result + Add

-con_1:

-

-Add = ""

-For i = 2 To 0 Step -1

-    m = Int(d / (10 ^ i))

-    If i = 2 Then

-        If m <> 0 Then

-            R = W100(m) + " "

-        End If

-    End If

-    If i = 1 Then

-        If m <> 0 Then

-            If d < 20 Then

-                R = W1(d) + " "

-                Result = Result + R

-                GoTo con_2

-            End If

-            R = W10(m) + " "

-        End If

-    End If

-    If i = 0 Then

-        If m <> 0 Then

-            If p = 0 Then

-                R = W1(m) + " "

-            Else

-                R = W1a(m) + " "

-            End If

-        End If

-    End If

-    

-    d = d - (m * (10 ^ i))

-    Result = Result + R

-    R = ""

-Next i

-con_2:

-

-

-If p = 0 Then       ' rub

-    Result = Result + "руб. "

-End If

-

-For i = 1 To 0 Step -1

-    m = Int(e / (10 ^ i))

-    Result = Result + Chr$(m + Asc("0"))

-    e = e - (m * (10 ^ i))

-Next i

-

-If p = 0 Then       ' rub

-    Result = Result + " коп."

-Else                ' y.e.

-    Result = Result + "/100 у.е"

-End If

-

-Result(1) = Result(1) + Chr(Asc("A")) - Chr(Asc("a"))

-

-Digit2String = Result

-

-End Function

-

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Sub Forecast()

-Attribute Forecast.VB_Description = "Macro recorded 06.12.2002 by nick"

-Attribute Forecast.VB_ProcData.VB_Invoke_Func = "f\n14"

-    With Selection

-        .Cells(1, 2).GoalSeek Goal:=1746, ChangingCell:=.Cells(1, 1)

-    End With

-End Sub

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-

-Sub RandFill()

-Attribute RandFill.VB_ProcData.VB_Invoke_Func = "r\n14"

-    Selection.Formula = "=rand()"

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-

-Sub RandFill()

-Attribute RandFill.VB_ProcData.VB_Invoke_Func = "r\n14"

-    Selection.Formula = "=rand()"

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-

-Sub RandFill()

-Attribute RandFill.VB_ProcData.VB_Invoke_Func = "r\n14"

-    Selection.Formula = "=rand()"

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Sub RandFill()

-    Selection.Formula = "=rand()"

-End Sub

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-

-Sub RandFill()

-Attribute RandFill.VB_ProcData.VB_Invoke_Func = "r\n14"

-    Selection.Formula = "=rand()"

-End Sub

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-

-Sub RandFill()

-Attribute RandFill.VB_ProcData.VB_Invoke_Func = "r\n14"

-    Selection.Formula = "=rand()"

-End Sub

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet19
->>>>>>
-Attribute VB_Name = "Sheet19"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-

-Sub RandFill()

-    Selection.Formula = "=rand()"

-End Sub

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-

-Sub RandFill()

-Attribute RandFill.VB_ProcData.VB_Invoke_Func = "r\n14"

-    Selection.Formula = "=rand()"

-End Sub

-

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-

-Sub RandFill()

-Attribute RandFill.VB_ProcData.VB_Invoke_Func = "r\n14"

-    Selection.Formula = "=rand()"

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ListFunc
->>>>>>
-Attribute VB_Name = "ListFunc"

-Option Explicit

-

-Function getEqClass(r As Range, ClRange As Range) As Integer

-    Dim i As Integer

-    For i = 1 To ClRange.Count

-        If r < ClRange.Cells(i) Then

-            getEqClass = i

-            Exit Function

-        End If

-    Next i

-End Function

-

-Function getClassLetter(Idx As Integer, ClNames As Range) As String

-    getClassLetter = ClNames.Cells(Idx)

-End Function

-

-Function GetEqLetter(r As Range, ClRange As Range, ClNames As Range) As String

-    GetEqLetter = getClassLetter(getEqClass(r, ClRange), ClNames)

-End Function

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag lengthProject Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    Call CleanUp

-End Sub

-

-Private Sub Workbook_Open()

-    Call CreateFormBar

-    frmFaceID.Show

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-'Global variables hold preious choices

-'for begining and ending FaceID numbers

-Public glbLastFirstID As Long

-Public glbLastLastID As Long

-

-

-Function CBShowButtonFaceIDs(lngIDStart As Long, _

-                             lngIDStop As Long)

-    ' This procedure creates a toolbar with buttons that display the

-    ' images associated with the values starting at lngIDStart and

-    ' ending at lngIDStop.

-    

-    Dim cbrNewToolbar   As CommandBar

-    Dim cmdNewButton    As CommandBarButton

-    Dim intCntr         As Integer

-    

-    ' Delete existing ShowFaceIds toolbar if it exists.

-    On Error Resume Next

-    Application.CommandBars("ShowFaceIds").Delete

-    frmFaceID.MousePointer = fmMousePointerHourGlass

-    ' Create a new toolbar.

-    Set cbrNewToolbar = Application.CommandBars.Add _

-        (Name:="ShowFaceIds", temporary:=True)

-    

-    ' Create a new button with an image matching the FaceId property value

-    ' indicated by intCntr.

-    For intCntr = lngIDStart To lngIDStop

-        Set cmdNewButton = cbrNewToolbar.Controls.Add(Type:=msoControlButton)

-        With cmdNewButton

-            ' Setting the FaceId property value specifies the appearance

-            ' but not the functionality of the button.

-            .FaceId = intCntr

-            .Caption = "FaceId = " & intCntr

-        End With

-    Next intCntr

-    

-    ' Show the images on the toolbar.

-    With cbrNewToolbar

-        .Width = 600

-        .Left = 100

-        .Top = 200

-        .Visible = True

-    End With

-    frmFaceID.MousePointer = fmMousePointerDefault

-End Function

-

-

-

-Public Function Validate()

-Dim lngTempNumber As Long

-

-'Procedure to check data entered by user

-With frmFaceID

-'If the first number requested < last number

-'then reverse them and rationalize

-'display next time form opens

-    If .txtFirstID Or .txtLastID > 0 Then

-        If CLng(.txtFirstID) > CLng(.txtLastID) Then

-           lngTempNumber = .txtFirstID

-           .txtFirstID = .txtLastID

-           .txtLastID = lngTempNumber

-         glbLastFirstID = .txtFirstID

-         glbLastLastID = .txtLastID

-        End If

- 'Only allow 200 FaceIDs per operation

- 'Call procedure to create FaceID values

- 'Take form out of memory

- 

-        If (.txtLastID - .txtFirstID) <= 200 Then

-            Call CBShowButtonFaceIDs(.txtFirstID, .txtLastID)

-            Unload frmFaceID

-        Else

-            MsgBox "Please request less than 200 FaceID's ", , "FaceID Number Finder"

-        End If

-    Else

-            .txtFirstID.SetFocus

-    End If

-End With

-End Function

-

-Public Function CleanUp()

-    On Error Resume Next

-   

-    Application.CommandBars("ShowFaceIds").Delete

-    Application.CommandBars("ShowForm").Delete

-      

-        

-End Function

-

-Public Function CreateFormBar()

-    Dim cmdBar As CommandBar

-    Dim btnForm As CommandBarButton

-'Delete the object if it already exists

-    On Error Resume Next

-    Application.CommandBars("ShowForm").Delete

-'Set the commandbar object variable

-    Set cmdBar = Application.CommandBars.Add

-        cmdBar.Name = "ShowForm"

-'Add a button

-    With cmdBar.Controls

-        

-        Set btnForm = .Add(msoControlButton)

-        

-    End With

-'Set the new button's properties

-    With btnForm

-        .Style = msoButtonIconAndCaption

-        .Caption = "Show FaceId Finder Form"

-        .FaceId = 2104

-        .OnAction = "OpenForm"

-        .TooltipText = "Show FaceID Form"

-    End With

-  ' Made visible in the form terminate event

-

-End Function

-

-Public Function OpenForm()

-'OnAction event procedure of ShowForm toolbar

-    frmFaceID.Show

-End Function

-

-

-<<<<<<
-======================
-frmFaceID
->>>>>>
-Attribute VB_Name = "frmFaceID"

-Attribute VB_Base = "0{5F1D3654-0CF0-11D2-B619-00AA00BBB974}{5F1D3641-0CF0-11D2-B619-00AA00BBB974}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-

-Private Sub cmdFaceId_Click()

-  

-  Dim strDefaultStatus As String

- 'Set up global variables with current requested values

-    glbLastFirstID = txtFirstID

-    glbLastLastID = txtLastID

- 'Detect current status bar value

- 'Set status bar message while FaceId's are generated

-    strDefaultStatus = Application.DisplayStatusBar

-    Application.DisplayStatusBar = True

-    Application.StatusBar = "Working on FaceID display please wait"

-    

-'Call validation procedure

-   

-    Call Validate

- 'Put Status bar back as it was

-    Application.DisplayStatusBar = False

-    Application.StatusBar = strDefaultStatus

-End Sub

-

-

-Private Sub txtFirstID_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)

-   'Test for non numeric entry then cancel or convert to long

-    If IsNumeric(txtFirstID) = False Then

-       txtFirstID = ""

-       Cancel = True

-    Else

-        txtFirstID = CLng(txtFirstID)

-    End If

-    

-End Sub

-

-

-Private Sub txtLastID_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)

-    'Test for non numeric entry then cancel or convert to long

-    If IsNumeric(txtLastID) = False Then

-       txtLastID = ""

-       Cancel = True

-    Else

-        txtLastID = CLng(txtLastID)

-    End If

-    

-End Sub

-

-Private Sub UserForm_Activate()

- 'Set up form with last requested values

- 'Make toolbar not visible

- On Error Resume Next

-    txtFirstID = glbLastFirstID

-    txtLastID = glbLastLastID

-    Application.CommandBars("ShowForm").Visible = False

-End Sub

-

-

-

-Private Sub UserForm_Terminate()

-    'Show toolbar if form is unloaded in

-    'Validate procedure of if X is clicked

-    Application.CommandBars("ShowForm").Visible = True

-End Sub

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Function GetRegion(idx As Integer) As String

-    GetRegion = Range("LST_REGIONS").Offset(i, 0)

-End Function

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Workbook_Activate()

-    Worksheets("Home").Select

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub ExportCopy()

-    ChartObjects("Chart 1").CopyPicture xlScreen, xlBitmap

-End Sub

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub ExportCopy()

-    Range("C4:G30").CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub ExportCopy()

-    Range("D44:H59").CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-PPExport
->>>>>>
-Attribute VB_Name = "PPExport"

-Option Explicit

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Sub ViewReport()

-    Dim ReportDoc As PowerPoint.Presentation

-    Set ReportDoc = GetObject(GetWBPath(ThisWorkbook.FullName) + "report.ppt")

-    ReportDoc.Application.Visible = True

-End Sub

-

-Sub CreateReportSlide(ReportDoc As PowerPoint.Presentation, Title As String)

-    Dim ReportPage As PowerPoint.Slide

-    

-    Set ReportPage = ReportDoc.Slides.Add(ReportDoc.Slides.Count + 1, ppLayoutBlank)

-    ReportPage.Shapes.Paste

-    ReportPage.Shapes.AddLabel(msoTextOrientationHorizontal, 20, 20, 640, 40) _

-      .TextFrame.TextRange.Text = Title

-End Sub

-

-Sub CreateReport()

-    Dim ReportApp As PowerPoint.Application

-    Dim ReportDoc As PowerPoint.Presentation

-    

-    Set ReportApp = CreateObject("PowerPoint.Application")

-    Set ReportDoc = ReportApp.Presentations.Add

-    

-    Dim i As Integer

-    For i = 1 To 4

-        ThisWorkbook.Worksheets("Sheet" + Format(i)).ExportCopy

-        CreateReportSlide ReportDoc, "Create slide name #" + Format(i)

-    Next i

-    

-    ReportDoc.SaveAs GetWBPath(ThisWorkbook.FullName) + "report"

-    ReportApp.Quit

-End Sub

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub ExportCopy()

-    ChartObjects("Chart 1").CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Workbook_Activate()

-    Worksheets("Home").Select

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub ExportCopy()

-    ChartObjects("Chart 1").CopyPicture xlScreen, xlBitmap

-End Sub

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub ExportCopy()

-    Range("C4:G30").CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub ExportCopy()

-    Range("D44:H59").CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-PPExport
->>>>>>
-Attribute VB_Name = "PPExport"

-Option Explicit

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Sub ViewReport()

-    Dim ReportDoc As PowerPoint.Presentation

-    Set ReportDoc = GetObject(GetWBPath(ThisWorkbook.FullName) + "report.ppt")

-    ReportDoc.Application.Visible = True

-End Sub

-

-Sub CreateReportSlide(ReportDoc As PowerPoint.Presentation, Title As String)

-    Dim ReportPage As PowerPoint.Slide

-    

-    Set ReportPage = ReportDoc.Slides.Add(ReportDoc.Slides.Count + 1, ppLayoutBlank)

-    ReportPage.Shapes.Paste

-    ReportPage.Shapes.AddLabel(msoTextOrientationHorizontal, 20, 20, 640, 40) _

-      .TextFrame.TextRange.Text = Title

-End Sub

-

-Sub CreateReport()

-    Dim ReportApp As PowerPoint.Application

-    Dim ReportDoc As PowerPoint.Presentation

-    

-    Set ReportApp = CreateObject("PowerPoint.Application")

-    Set ReportDoc = ReportApp.Presentations.Add

-    

-    Dim i As Integer

-    For i = 1 To 4

-        ThisWorkbook.Worksheets("Sheet" + Format(i)).ExportCopy

-        CreateReportSlide ReportDoc, "Create slide name #" + Format(i)

-    Next i

-    

-    ReportDoc.SaveAs GetWBPath(ThisWorkbook.FullName) + "report"

-    ReportApp.Quit

-End Sub

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub ExportCopy()

-    ChartObjects("Chart 1").CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'Telfast_marketing'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    Set MyAppEvents.app = Application

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    If Application.Workbooks.Count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEL сейчас будут закрыты!", vbOKCancel, "$" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close Savechanges:=False

-            Exit Sub

-        End If

-    End If

-    cmSetStandaloneMode

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    Dim res

-    res = MsgBox( _

-        prompt:="Вы желаете завершить программу? Не правда ли?", _

-        Buttons:=vbQuestion + vbYesNo, _

-        Title:=PROGRAM_NAME _

-    )

-    If res <> vbYes Then

-        Cancel = True

-        Exit Sub

-    End If

-    

-    

-    Dim NewFileName, DefFileName, WBPath As String

-    NewFileName = MakeNewFileName( _

-                        Worksheets("home").Range("USER_NAME_F"), _

-                        Worksheets("home").Range("USER_NAME_S"), _

-                        Worksheets("data").Range("CITY_TABLES") _

-                        .Offset( _

-                            Worksheets("data").Range("IDX_CITY"), _

-                            (Worksheets("data").Range("IDX_REGION") - 1) * 2 _

-                        ) _

-                    )

-    DefFileName = MakeNewFileName( _

-                        DEF_USER_NAME_F, _

-                        DEF_USER_NAME_S, _

-                        Worksheets("data").Range("CITY_TABLES") _

-                        .Offset(DEF_IDX_CITY, (DEF_IDX_REGION - 1) * 2) _

-                    )

-    WBPath = GetWBPath(ThisWorkbook.FullName)

-    

-    If ThisWorkbook.Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-        If ThisWorkbook.Saved = False Then

-            If NewFileName <> DefFileName Then

-                dlgFname.Caption = PROGRAM_NAME

-                dlgFname.lbFName = NewFileName

-                dlgFname.lbFPath = WBPath

-                dlgFname.Show

-                NewFileName = WBPath & NewFileName

-                ThisWorkbook.SaveAs FileName:=NewFileName

-            Else

-                ThisWorkbook.Save

-            End If

-        End If

-    End If

-    Application.Caption = Empty

-    Application.CommandBars("Worksheet Menu Bar").Reset

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-        Dim MaxX, MaxY As Integer

-        With ThisWorkbook.Worksheets(HOME_SHEET)

-            MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-            MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-        End With

-

-        With ThisWorkbook.Application

-            .ScreenUpdating = False

-            .WindowState = xlNormal

-            .Height = MaxY

-            .Width = MaxX

-        End With

-End Sub

-

-

-

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INP_NO As Integer = 0

-Const INP_DAT As Integer = 1

-Const INP_TXT As Integer = 2

-Const INP_NUM As Integer = 3

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Select Case is_InputRange(Target)

-    Case INP_NUM

-        Check_Number Target, 1

-    Case INP_TXT

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE")

-

-    If is_InputRange(Target) <> INP_NO Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-Function is_InputRange(r As Range) As Integer

-    Dim test As Boolean

-    

-    is_InputRange = INP_NO

-    

-    If r.Column = Range("USER_NAME_F").Column Then

-        test = r.Row = Range("USER_NAME_S").Row _

-                        Or r.Row = Range("USER_NAME_F").Row

-        If test Then

-            is_InputRange = INP_TXT

-        End If

-    Else

-        If r.Column = Range("USER_PLAN").Column Then

-            test = r.Row = Range("USER_PLAN").Row _

-                            Or r.Row = Range("USER_FACT").Row _

-                            Or r.Row = Range("USER_BUDGET").Row _

-                            Or r.Row = Range("USER_SVNORM").Row

-            

-            Dim idx As Integer

-            idx = Worksheets(DATA_SHEET).Range("IDX_PERSONE")

-            

-            If test Then

-                is_InputRange = INP_NUM

-            Else

-                If r.Row = Range("USER_STAF").Row Then

-                    If idx = 1 Then

-                        is_InputRange = INP_NUM

-                    End If

-                End If

-            End If

-        End If

-    End If

-End Function

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INP_DOC As String = "C9"

-Const INP_APT As String = "C11"

-Const INP_ADV As String = "C13"

-Const INP_ACT As String = "C15"

-Const INP_VIP As String = "C17"

-Const INP_SUM As String = "C19"

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("C9").Select

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    

-    If is_InputRange(Target) Then

-        GoalSeekNow Range(INP_SUM), Target

-    Else

-        If Target.Row = Range(INP_SUM).Row And Target.Column = Range(INP_SUM).Column Then

-            Dim Addr As String

-            

-            Addr = INP_DOC & "," & INP_APT & "," & INP_ADV & "," & INP_ACT & "," & INP_VIP

-            RangeNormalize Range(Addr), Target

-            

-        End If

-    End If

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If is_InputRange(Target) Then

-        Check_Percent Target, 0.2

-    End If

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE")

-    

-    If is_InputRange(Target) Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-Function is_InputRange(r As Range) As Boolean

-    is_InputRange = r.Column = Range(INP_DOC).Column _

-                And ( _

-                    r.Row = Range(INP_DOC).Row _

-                    Or r.Row = Range(INP_APT).Row _

-                    Or r.Row = Range(INP_ADV).Row _

-                    Or r.Row = Range(INP_ACT).Row _

-                    Or r.Row = Range(INP_VIP).Row _

-                )

-End Function

-

-

-<<<<<<
-======================
-mHome
->>>>>>
-Attribute VB_Name = "mHome"

-Option Explicit

-

-Sub cboxPersone_Change()

-    With ThisWorkbook.Worksheets(HOME_SHEET)

-        Dim r As Range

-        Range("A1").Select

-        If .Shapes("cboxPersone").ControlFormat.ListIndex = 2 Then

-            .Unprotect

-            .Range("G15") = 1

-            If Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") Then

-                .Protect

-            End If

-        End If

-    End With

-End Sub

-

-Sub cboxArea_Change()

-    Dim GroupIdx, LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    With ThisWorkbook.Worksheets(DATA_SHEET)

-        GroupIdx = .Range("IDX_REGION")

-        .Range("IDX_CITY") = 1

-        NewRangeOffsetCol = (GroupIdx - 1) * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .Name & "!" & .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).Address

-        NewSumRange = .Name & "!" & .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).Address

-    End With

-    With ThisWorkbook.Worksheets(HOME_SHEET)

-        .Shapes("cboxCity").ControlFormat.ListFillRange = NewCbxRange

-        .Unprotect

-        .Range("G10").Formula = "=sum(" & NewSumRange & ")"

-        If Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") Then

-            .Protect

-        End If

-    End With

-End Sub

-

-Sub cboxCity_Change()

-    

-End Sub

-

-<<<<<<
-======================
-mCommands
->>>>>>
-Attribute VB_Name = "mCommands"

-Option Explicit

-

-Sub btHome_Click()

-    Worksheets(HOME_SHEET).Select

-    Worksheets(DATA_SHEET).Range("CUR_STATE") = 0

-End Sub

-

-Sub bt2Budget_Click()

-    Sheets("budget").Select

-End Sub

-

-

-Sub btBdgtPrev_Click()

-    btHome_Click

-End Sub

-

-Sub btBdgtNext_Click()

-    If check_budget(Range("BDGT_TOTAL")) Then

-        Sheets("Final").Select

-    End If

-End Sub

-

-Sub btDoc_Click()

-    If check_budget(Range("BDGT_TOTAL")) Then

-        Sheets("Doc").Select

-    End If

-End Sub

-

-Sub btDocVisit_Click()

-    Sheets("Doc.Visit").Select

-End Sub

-

-Sub btDocConf_Click()

-    Sheets("Doc.Conf").Select

-End Sub

-

-Sub btApt_Click()

-    If check_budget(Range("BDGT_TOTAL")) Then

-        Sheets("Apt").Select

-    End If

-End Sub

-

-Sub btAptVisit_Click()

-    Sheets("Apt.Visit").Select

-End Sub

-

-

-Sub btAptConf_Click()

-    Sheets("Apt.Conf").Select

-End Sub

-

-Sub btAdv_Click()

-    If check_budget(Range("BDGT_TOTAL")) Then

-        Sheets("Adv").Select

-    End If

-End Sub

-

-Sub btAdvPrev_Click()

-    If check_Adv Then

-        bt2Budget_Click

-    End If

-End Sub

-

-Sub btAct_Click()

-    If check_budget(Range("BDGT_TOTAL")) Then

-        Sheets("Act").Select

-    End If

-End Sub

-

-Sub btCost_Click()

-    If check_budget(Range("BDGT_TOTAL")) Then

-        Sheets("Cost").Select

-    End If

-End Sub

-

-Sub btCostPrev_Click()

-    If check_budget(Range("Cost!C17")) Then

-        Sheets("budget").Select

-    End If

-End Sub

-

-<<<<<<
-======================
-Sheet40
->>>>>>
-Attribute VB_Name = "Sheet40"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("C9").Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If is_InputRange(Target) Then

-        Check_Percent Target, 0.7

-    End If

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = True

-    If is_InputRange(Target) Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-

-Function is_InputRange(r As Range) As Boolean

-    is_InputRange = r.Column = Range("C9").Column _

-                    And r.Row = Range("C9").Row

-End Function

-

-

-<<<<<<
-======================
-Tools
->>>>>>
-Attribute VB_Name = "Tools"

-Option Explicit

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub test()

-    Dim str As String

-    str = GetWBPath(ThisWorkbook.FullName)

-End Sub

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-Attribute SetDesignFlagOn.VB_ProcData.VB_Invoke_Func = "E\n14"

-    Dim Sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each Sh In Worksheets

-        Sh.Unprotect

-        Sh.Visible = xlSheetVisible

-    Next Sh

-    Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-Attribute SetDesignFlagOff.VB_ProcData.VB_Invoke_Func = " \n14"

-    Application.ScreenUpdating = False

-    Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim Sh As Worksheet

-    For Each Sh In Worksheets

-        If Sh.Name <> "data" Then

-            Sh.Protect

-        Else

-            Sh.Visible = xlSheetVeryHidden

-        End If

-    Next Sh

-    Application.ScreenUpdating = True

-End Sub

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma training"

-Public Const PROGRAM_VERSION As String = "version 1.0"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-

-'Public Const ESTIMATION_DATE As Long = 20030329

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "N35"

-Public Const CITY_TABLES As String = "N30"

-

-

-Public Const DATA_SHEET As String = "data"

-

-' Костанты листа Home

-Public Const DEF_USER_NAME_F As String = "Иван"

-Public Const DEF_USER_NAME_S As String = "Тургенев"

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-Public Const HOME_SHEET As String = "Home"

-Public Const USER_NAME_F As String = "USER_NAME_F"

-Public Const USER_NAME_S As String = "USER_NAME_S"

-Public Const USER_PLAN As String = "USER_PLAN"

-Public Const USER_BUDGET As String = "USER_BUDGET"

-Public Const USER_FACT As String = "USER_FACT"

-

-' Костанты листа Adv

-Public Const ADV_SHEET As String = "Adv"

-Public Const ADV_SUM_CAP As String = "K9"

-Public Const ADV_SUM_DOC As String = "C17"

-Public Const ADV_SUM_APT As String = "E17"

-Public Const ADV_SUM_CAST As String = "G17"

-Public Const ADV_SUM_DIST As String = "I17"

-

-

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{81B9D41B-89F6-4B17-9F1D-45017FFC6C8F}{EF972C75-B6C6-407C-BAF6-74472541F2BB}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{0D5199B4-A753-4F74-A564-40388FABC4B0}{19DC56E2-E0F4-44B4-8B23-51B77A2564D5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-Sheet52
->>>>>>
-Attribute VB_Name = "Sheet52"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INPUTDATE_LT As String = "B11"

-Const INPUTDATE_RB As String = "B25"

-Const INPUTTEXT_LT As String = "C11"

-Const INPUTTEXT_RB As String = "C25"

-Const INPUTNUMB_LT As String = "F11"

-Const INPUTNUMB_RB As String = "I25"

-

-Const INP_NO As Integer = 0

-Const INP_DAT As Integer = 1

-Const INP_TXT As Integer = 2

-Const INP_NUM As Integer = 3

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("B11").Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Select Case is_InputRange(Target)

-    Case INP_NUM

-        Check_Number Target, 100

-    Case INP_TXT, INP_DAT

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = True

-    If is_InputRange(Target) <> 0 Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-Function is_InputRange(r As Range) As Integer

-    If is_InputArea(r, Range(INPUTDATE_LT), Range(INPUTDATE_RB)) Then

-        is_InputRange = INP_DAT

-    Else

-        If is_InputArea(r, Range(INPUTTEXT_LT), Range(INPUTTEXT_RB)) Then

-            is_InputRange = INP_TXT

-        Else

-            If is_InputArea(r, Range(INPUTNUMB_LT), Range(INPUTNUMB_RB)) Then

-                    is_InputRange = INP_NUM

-            Else

-                is_InputRange = INP_NO

-            End If

-        End If

-    End If

-End Function

-

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Function check_Adv() As Boolean

-    Dim b As Boolean

-    b = Abs(Range(ADV_SUM_CAP) - 1) < 0.0001 _

-        And Abs(Range(ADV_SUM_DOC) - 1) < 0.0001 _

-        And Abs(Range(ADV_SUM_APT) - 1) < 0.0001 _

-        And Abs(Range(ADV_SUM_CAST) - 1) < 0.0001 _

-        And Abs(Range(ADV_SUM_DIST) - 1) < 0.0001 _

-        Or Range("D13") = 0

-    If Not b Then

-        MsgBox "Не правильно составлен бюджет. Итоговые суммы должны быть = 100%"

-    End If

-    check_Adv = b

-End Function

-

-Function check_budget(r As Range) As Boolean

-    Dim f As Double

-    Dim b As Boolean

-    f = r

-    b = Abs(f - 1#) < 0.0001

-    If Not b Then

-        MsgBox "Не правильно составлен бюджет. Итоговые суммы должны быть = 100%"

-    End If

-    check_budget = b

-End Function

-

-Sub RangeNormalize(Src As Range, Dst As Range)

-    Dim f As Double

-    Dim c As Range

-    f = Dst

-    If f <> 0 Then

-        Src.Worksheet.Unprotect

-        For Each c In Src

-            c = c / f

-        Next c

-        If Not Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") Then

-            Src.Worksheet.Protect

-        End If

-    Else

-        MsgBox "Введите хотя бы одно число!"

-    End If

-End Sub

-

-Sub GoalSeekNow(Goal As Range, Target As Range)

-    Dim diff As Double

-    

-    diff = Goal - 1

-    If Abs(diff) > 0.0001 Then

-        If (diff > 0 And diff < Target) Or (diff < 0 And 1 - Target > Abs(diff)) Then

-            Goal.GoalSeek Goal:=1, ChangingCell:=Range(Target.Address)

-        Else

-            MsgBox "Автоподбор значения не возможен. Выберите другой параметр!"

-        End If

-    End If

-

-End Sub

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100."

-    End If

-End Sub

-

-Sub Check_Number(Target As Range, Def_Val As Double)

-    Dim test As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                test = True

-            End If

-        End If

-    Next r

-    

-    If test Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!"

-    End If

-    

-End Sub

-

-Function is_InputArea(r As Range, LT As Range, RB As Range) As Boolean

-    is_InputArea = r.Column >= LT.Column _

-                And r.Row >= LT.Row _

-                And r.Column <= RB.Column _

-                And r.Row <= RB.Row

-End Function

-

-<<<<<<
-======================
-Sheet70
->>>>>>
-Attribute VB_Name = "Sheet70"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INP_NUM_1_LT As String = "E14"

-Const INP_NUM_1_RB As String = "J14"

-Const INP_NUM_2_LT As String = "E16"

-Const INP_NUM_2_RB As String = "J16"

-Const INP_NUM_3_LT As String = "E18"

-Const INP_NUM_3_RB As String = "J18"

-Const INP_NUM_4_LT As String = "E20"

-Const INP_NUM_4_RB As String = "J20"

-Const INP_NUM_5_LT As String = "E22"

-Const INP_NUM_5_RB As String = "J22"

-

-Const INP_DAT_1_LT As String = "B14"

-Const INP_DAT_1_RB As String = "C14"

-Const INP_DAT_2_LT As String = "B16"

-Const INP_DAT_2_RB As String = "C16"

-Const INP_DAT_3_LT As String = "B18"

-Const INP_DAT_3_RB As String = "C18"

-Const INP_DAT_4_LT As String = "B20"

-Const INP_DAT_4_RB As String = "C20"

-Const INP_DAT_5_LT As String = "B22"

-Const INP_DAT_5_RB As String = "C22"

-

-Const INP_NO As Integer = 0

-Const INP_DAT As Integer = 1

-Const INP_TXT As Integer = 2

-Const INP_NUM As Integer = 3

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("B14").Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Select Case is_InputRange(Target)

-    Case INP_NUM

-        Check_Number Target, 100

-    Case INP_TXT, INP_DAT

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE")

-    

-    If is_InputRange(Target) <> INP_NO Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-

-Function is_InputRange(r As Range) As Integer

-    Dim test As Boolean

-    

-    test = is_InputArea(r, Range(INP_NUM_1_LT), Range(INP_NUM_1_RB)) _

-        Or is_InputArea(r, Range(INP_NUM_2_LT), Range(INP_NUM_2_RB)) _

-        Or is_InputArea(r, Range(INP_NUM_3_LT), Range(INP_NUM_3_RB)) _

-        Or is_InputArea(r, Range(INP_NUM_4_LT), Range(INP_NUM_4_RB)) _

-        Or is_InputArea(r, Range(INP_NUM_5_LT), Range(INP_NUM_5_RB))

-    If test Then

-       is_InputRange = INP_NUM

-    Else

-        test = is_InputArea(r, Range(INP_DAT_1_LT), Range(INP_DAT_1_RB)) _

-            Or is_InputArea(r, Range(INP_DAT_2_LT), Range(INP_DAT_2_RB)) _

-            Or is_InputArea(r, Range(INP_DAT_3_LT), Range(INP_DAT_3_RB)) _

-            Or is_InputArea(r, Range(INP_DAT_4_LT), Range(INP_DAT_4_RB)) _

-            Or is_InputArea(r, Range(INP_DAT_5_LT), Range(INP_DAT_5_RB))

-        If test Then

-            is_InputRange = INP_DAT

-        Else

-            is_InputRange = INP_NO

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-Sheet30
->>>>>>
-Attribute VB_Name = "Sheet30"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet41
->>>>>>
-Attribute VB_Name = "Sheet41"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const MEMBERSHIP As String = "D7"

-Const MILEAGE As String = "D9"

-Const INPUTAREA_LT As String = "C17"

-Const INPUTAREA_RB As String = "E24"

-

-Const ChangeCheckFlag As Boolean = False

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("C17").Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Select Case is_InputRange(Target)

-        Case 1

-            Check_Number Target, 1

-        Case 2

-            Check_Number Target, 15

-        Case 3

-            Check_Number Target, 50

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = True

-    If is_InputRange(Target) <> 0 Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-Function is_InputRange(r As Range) As Integer

-    If r.Column = Range(MEMBERSHIP).Column And r.Row = Range(MEMBERSHIP).Row Then

-        is_InputRange = 1

-    Else

-        If r.Column = Range(MILEAGE).Column And r.Row = Range(MILEAGE).Row Then

-            is_InputRange = 2

-        Else

-            If r.Column >= Range(INPUTAREA_LT).Column _

-                And r.Row >= Range(INPUTAREA_LT).Row _

-                And r.Column <= Range(INPUTAREA_RB).Column _

-                And r.Row <= Range(INPUTAREA_RB).Row Then

-                    is_InputRange = 3

-            Else

-                is_InputRange = 0

-            End If

-        End If

-    End If

-End Function

-

-

-<<<<<<
-======================
-Sheet42
->>>>>>
-Attribute VB_Name = "Sheet42"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INPUTDATE_LT As String = "B11"

-Const INPUTDATE_RB As String = "B25"

-Const INPUTTEXT_LT As String = "C11"

-Const INPUTTEXT_RB As String = "C25"

-Const INPUTNUMB_LT As String = "F11"

-Const INPUTNUMB_RB As String = "I25"

-

-Const INP_NO As Integer = 0

-Const INP_DAT As Integer = 1

-Const INP_TXT As Integer = 2

-Const INP_NUM As Integer = 3

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range(INPUTDATE_LT).Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Select Case is_InputRange(Target)

-    Case INP_NUM

-        Check_Number Target, 100

-    Case INP_TXT, INP_DAT

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = True

-    If is_InputRange(Target) <> 0 Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-Function is_InputRange(r As Range) As Integer

-    If is_InputArea(r, Range(INPUTDATE_LT), Range(INPUTDATE_RB)) Then

-        is_InputRange = INP_DAT

-    Else

-        If is_InputArea(r, Range(INPUTTEXT_LT), Range(INPUTTEXT_RB)) Then

-            is_InputRange = INP_TXT

-        Else

-            If is_InputArea(r, Range(INPUTNUMB_LT), Range(INPUTNUMB_RB)) Then

-                    is_InputRange = INP_NUM

-            Else

-                is_InputRange = INP_NO

-            End If

-        End If

-    End If

-End Function

-

-

-<<<<<<
-======================
-Sheet60
->>>>>>
-Attribute VB_Name = "Sheet60"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INP_DOC_LT As String = "C10"

-Const INP_DOC_RB As String = "C16"

-Const INP_APT_LT As String = "E10"

-Const INP_APT_RB As String = "E16"

-Const INP_CAST_LT As String = "G10"

-Const INP_CAST_RB As String = "G16"

-Const INP_DIST_LT As String = "I10"

-Const INP_DIST_RB As String = "I16"

-Const CAP_DOC As String = "C9"

-Const CAP_APT As String = "E9"

-Const CAP_CAST As String = "G9"

-Const CAP_DIST As String = "I9"

-

-

-Const INP_NO As Integer = 0

-Const INP_CAP As Integer = 1

-Const INP_DOC As Integer = 2

-Const INP_APT As Integer = 3

-Const INP_CAST As Integer = 4

-Const INP_DIST As Integer = 5

-

-Const INP_SUM_CAP As Integer = 11

-Const INP_SUM_DOC As Integer = 12

-Const INP_SUM_APT As Integer = 13

-Const INP_SUM_CAST As Integer = 14

-Const INP_SUM_DIST As Integer = 15

-

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("C9").Select

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim Inp As Integer

-    Dim Addr As String

-    Inp = is_InputRange(Target)

-    Select Case is_InputRange(Target)

-        Case INP_NO

-            Cancel = False

-        

-        Case INP_CAP

-            GoalSeekNow Range(ADV_SUM_CAP), Target

-        

-        Case INP_DOC

-            GoalSeekNow Range(ADV_SUM_DOC), Target

-        

-        Case INP_APT

-            GoalSeekNow Range(ADV_SUM_APT), Target

-        

-        Case INP_CAST

-            GoalSeekNow Range(ADV_SUM_CAST), Target

-        

-        Case INP_DIST

-            GoalSeekNow Range(ADV_SUM_DIST), Target

-        

-        Case INP_SUM_CAP

-            Addr = CAP_DOC & "," & CAP_APT & "," & CAP_CAST & "," & CAP_DIST

-            RangeNormalize Range(Addr), Target

-        

-        Case INP_SUM_DOC

-            Addr = INP_DOC_LT & ":" & INP_DOC_RB

-            RangeNormalize Range(Addr), Target

-        

-        Case INP_SUM_APT

-            Addr = INP_APT_LT & ":" & INP_APT_RB

-            RangeNormalize Range(Addr), Target

-        

-        Case INP_SUM_CAST

-            Addr = INP_CAST_LT & ":" & INP_CAST_RB

-            RangeNormalize Range(Addr), Target

-        

-        Case INP_SUM_DIST

-            Addr = INP_DIST_LT & ":" & INP_DIST_RB

-            RangeNormalize Range(Addr), Target

-    End Select

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Select Case is_InputRange(Target)

-    Case INP_CAP

-        Check_Percent Target, 0.25

-    Case INP_DOC, INP_APT, INP_CAST, INP_DIST

-        Check_Percent Target, 0.15

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE")

-    

-    If is_InputRange(Target) > 0 Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-

-Function is_InputRange(r As Range) As Integer

-    is_InputRange = INP_NO

-    If r.Row = Range(CAP_DOC).Row Then

-        If r.Column = Range(CAP_DOC).Column _

-                Or r.Column = Range(CAP_APT).Column _

-                Or r.Column = Range(CAP_CAST).Column _

-                Or r.Column = Range(CAP_DIST).Column Then

-            is_InputRange = INP_CAP

-        End If

-        If r.Column = Range(ADV_SUM_CAP).Column Then

-            is_InputRange = INP_SUM_CAP

-        End If

-    Else

-        If is_InputArea(r, Range(INP_DOC_LT), Range(INP_DOC_RB)) Then

-            is_InputRange = INP_DOC

-        Else

-            If is_InputArea(r, Range(INP_APT_LT), Range(INP_APT_RB)) Then

-                is_InputRange = INP_APT

-            Else

-                If is_InputArea(r, Range(INP_CAST_LT), Range(INP_CAST_RB)) Then

-                    is_InputRange = INP_CAST

-                Else

-                    If is_InputArea(r, Range(INP_DIST_LT), Range(INP_DIST_RB)) Then

-                        is_InputRange = INP_DIST

-                    Else

-                        If r.Row = Range(ADV_SUM_DOC).Row Then

-                            If r.Column = Range(ADV_SUM_DOC).Column Then

-                                is_InputRange = INP_SUM_DOC

-                            End If

-                            If r.Column = Range(ADV_SUM_APT).Column Then

-                                is_InputRange = INP_SUM_APT

-                            End If

-                            If r.Column = Range(ADV_SUM_APT).Column Then

-                                is_InputRange = INP_SUM_APT

-                            End If

-                            If r.Column = Range(ADV_SUM_CAST).Column Then

-                                is_InputRange = INP_SUM_CAST

-                            End If

-                            If r.Column = Range(ADV_SUM_DIST).Column Then

-                                is_InputRange = INP_SUM_DIST

-                            End If

-                        End If

-                    End If

-                End If

-            End If

-        End If

-    End If

-End Function

-

-

-<<<<<<
-======================
-Sheet50
->>>>>>
-Attribute VB_Name = "Sheet50"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("C9").Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If is_InputRange(Target) Then

-        Check_Percent Target, 0.7

-    End If

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = True

-    If is_InputRange(Target) Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-

-Function is_InputRange(r As Range) As Boolean

-    is_InputRange = r.Column = Range("C9").Column _

-                    And r.Row = Range("C9").Row

-End Function

-

-

-<<<<<<
-======================
-Sheet51
->>>>>>
-Attribute VB_Name = "Sheet51"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INPUTAREA_LT As String = "C17"

-Const INPUTAREA_RB As String = "E20"

-

-Const ChangeCheckFlag As Boolean = False

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("C17").Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If is_InputRange(Target) <> 0 Then

-        Check_Number Target, 50

-    End If

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = True

-    If is_InputRange(Target) <> 0 Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-Function is_InputRange(r As Range) As Integer

-    If is_InputArea(r, Range(INPUTAREA_LT), Range(INPUTAREA_RB)) Then

-        is_InputRange = 3

-    Else

-        is_InputRange = 0

-    End If

-End Function

-

-

-<<<<<<
-======================
-Sheet80
->>>>>>
-Attribute VB_Name = "Sheet80"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INP_DOC As String = "C9"

-Const INP_APT As String = "C11"

-Const INP_CUST As String = "C13"

-Const INP_DIST As String = "C15"

-Const INP_SUM As String = "C17"

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("C9").Select

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    

-    If is_InputRange(Target) Then

-        GoalSeekNow Range(INP_SUM), Target

-    Else

-        If Target.Row = Range(INP_SUM).Row And Target.Column = Range(INP_SUM).Column Then

-            Dim Addr As String

-            

-            Addr = INP_DOC & "," & INP_APT & "," & INP_CUST & "," & INP_DIST

-            RangeNormalize Range(Addr), Target

-            

-        End If

-    End If

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If is_InputRange(Target) Then

-        Check_Percent Target, 0.25

-    End If

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE")

-    

-    If is_InputRange(Target) Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-Function is_InputRange(r As Range) As Boolean

-    is_InputRange = r.Column = Range(INP_DOC).Column _

-                And ( _

-                    r.Row = Range(INP_DOC).Row _

-                    Or r.Row = Range(INP_APT).Row _

-                    Or r.Row = Range(INP_CUST).Row _

-                    Or r.Row = Range(INP_DIST).Row _

-                )

-End Function

-

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Print"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 4

-                        .OnAction = "cmPrint"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-'                With .Controls

-'                    With .Add(msoControlButton)

-'                        .Caption = "&Contents"

-'                        .Style = msoButtonIconAndCaption

-'                        .FaceId = 49

-'                        .OnAction = "cmHelpContents"

-'                    End With

-'                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(Flag As Boolean)

-    If Flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars("Worksheet Menu Bar")

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    dlgAbout.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlgAbout.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlgAbout.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlgAbout.Show

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-        helppath = "hh.exe " & .Path & "\Telfast.chm"

-        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub cmSetStandaloneMode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-    ThisWorkbook.Worksheets("home").Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    rp = common_pwd

-    dlgGetPwd.edPwd = ""

-    dlgGetPwd.Show

-    If dlgGetPwd.edPwd = rp Then

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-    Else

-        cmSetStandaloneMode

-    End If

-    ThisWorkbook.Worksheets("home").Select

-End Sub

-

-

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If Application.Workbooks.Count > 1 Then

-        wbname = Wb.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKCancel, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            Wb.Close Savechanges:=False

-        End If

-        Exit Sub

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub GetState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.Count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.Name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars("Worksheet Menu Bar").Visible = False

-End Sub

-

-

-Public Sub RestoreState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars("Worksheet Menu Bar").Visible = True

-End Sub

-

-

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        cmHelpContents

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Telfast bar"

-Public Const common_pwd As Long = 31415926

-

-

-Sub SetEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    With Application

-        .Caption = PROGRAM_NAME

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .GetState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(HOME_SHEET).Select

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                     cWindow.DisplayHeadings = True

-                Next

-            End If

-        Next

-        .Worksheets(HOME_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu (True)

-        End If

-        With mobjAppState

-            .RestoreState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{6B54EA33-E5D1-44C0-BC3C-E5960329B246}{639FA6FC-FBAC-44B4-ACC5-7DAF95DA47F4}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    

-    dlgPrint.cbMainReport = True

-    dlgPrint.cbMainBudget = False

-    dlgPrint.cbSrcData = False

-    dlgPrint.cbAllSheets = False

-    

-    dlgPrint.Show

-    

-    If dlgPrint.Tag = vbCancel Then

-        Exit Sub

-    End If

-    

-    Dim PrnIdx As Integer

-    

-    With dlgPrint

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("home", "budget", "Final")

-    Case 1111

-        plist = Array("home", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("home")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-dlgFname
->>>>>>
-Attribute VB_Name = "dlgFname"

-Attribute VB_Base = "0{AB4D9ABD-F40E-4C39-8FE4-0625E69E5365}{2CC3E532-33AC-44D8-9195-34917AF21E8C}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btOK_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Sub Macro1()

-Attribute Macro1.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute Macro1.VB_ProcData.VB_Invoke_Func = " \n14"

-'

-' Macro1 Macro

-' Macro recorded 25.09.2003 by nick

-'

-

-'

-    Charts.Add

-    ActiveChart.ChartType = xlBubble

-    ActiveChart.SetSourceData Source:=Sheets("file1").Range("H2:J11"), PlotBy:= _

-        xlColumns

-    ActiveChart.Location Where:=xlLocationAsObject, Name:="file1"

-    With ActiveChart

-        .HasTitle = True

-        .ChartTitle.Characters.Text = "Матрица"

-        .Axes(xlCategory, xlPrimary).HasTitle = True

-        .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Доля клексана"

-        .Axes(xlValue, xlPrimary).HasTitle = True

-        .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Количество больных"

-    End With

-    With ActiveChart.Axes(xlCategory)

-        .HasMajorGridlines = True

-        .HasMinorGridlines = False

-    End With

-    With ActiveChart.Axes(xlValue)

-        .HasMajorGridlines = True

-        .HasMinorGridlines = False

-    End With

-    ActiveChart.HasLegend = False

-    ActiveChart.ApplyDataLabels Type:=xlDataLabelsShowValue, LegendKey:=False

-    ActiveChart.SeriesCollection(1).Select

-    ActiveChart.SeriesCollection(1).DataLabels.Select

-    ActiveChart.SeriesCollection(1).Select

-    ActiveChart.SeriesCollection(1).DataLabels.Select

-    ActiveChart.SeriesCollection(1).Points(9).DataLabel.Select

-    Selection.Characters.Text = "8379 №1"

-    Selection.AutoScaleFont = False

-    With Selection.Characters(Start:=1, Length:=7).Font

-        .Name = "Arial"

-        .FontStyle = "Обычный"

-        .Size = 10

-        .Strikethrough = False

-        .Superscript = False

-        .Subscript = False

-        .OutlineFont = False

-        .Shadow = False

-        .Underline = xlUnderlineStyleNone

-        .ColorIndex = xlAutomatic

-    End With

-    ActiveChart.Axes(xlValue).MajorGridlines.Select

-End Sub

-Sub Macro2()

-Attribute Macro2.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute Macro2.VB_ProcData.VB_Invoke_Func = " \n14"

-'

-' Macro2 Macro

-' Macro recorded 25.09.2003 by nick

-'

-

-'

-    Application.CutCopyMode = False

-    With ActiveChart.ChartGroups(1)

-        .VaryByCategories = True

-        .ShowNegativeBubbles = False

-        .SizeRepresents = xlSizeIsArea

-        .BubbleScale = 100

-    End With

-End Sub

-Sub Macro3()

-Attribute Macro3.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute Macro3.VB_ProcData.VB_Invoke_Func = " \n14"

-'

-' Macro3 Macro

-' Macro recorded 25.09.2003 by nick

-'

-

-'

-    ActiveChart.SeriesCollection(1).DataLabels.Select

-    ActiveChart.SeriesCollection(1).Points(6).DataLabel.Select

-    ActiveChart.Axes(xlValue).MajorGridlines.Select

-    ActiveChart.SeriesCollection(1).DataLabels.Select

-    ActiveChart.SeriesCollection(1).Points(6).DataLabel.Select

-    Selection.Characters.Text = "9847 №2"

-    Selection.AutoScaleFont = False

-    With Selection.Characters(Start:=1, Length:=7).Font

-        .Name = "Arial"

-        .FontStyle = "Обычный"

-        .Size = 12

-        .Strikethrough = False

-        .Superscript = False

-        .Subscript = False

-        .OutlineFont = False

-        .Shadow = False

-        .Underline = xlUnderlineStyleNone

-        .ColorIndex = xlAutomatic

-    End With

-    ActiveChart.PlotArea.Select

-End Sub

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Private Sub Workbook_Open()

-    xlRestoreView

-End Sub

-

-Sub xlRestoreView()

-    Application.CommandBars("Standard").Visible = True

-    Application.CommandBars("Formatting").Visible = True

-    Application.DisplayFormulaBar = True

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'ClexanePM'
-Quirk - duff tag length======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-

-    Application.EnableEvents = True

-    Set MyAppEvents.app = Application

-    

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    

-    MyAppEvents.CheckWorkBooksArround ThisWorkbook

-    

-    cmSetStandaloneMode

-    

-    Application.ScreenUpdating = True

-'    CheckUser

-

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).Select

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).update_history

-    Application.Calculate

-

-End Sub

-

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    

-    Dim RestMode As Boolean

-    RestMode = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE")

-    

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-'        If RestMode Then

-            ThisWorkbook.Saved = True

-'        Else

-'            ThisWorkbook.Save

-'        End If

-    End If

-    If RestMode Then

-        xlRestoreView

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    End If

-    Application.Caption = Empty

-    Application.CommandBars(STDBAR_NAME).Reset

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-    Dim MaxX, MaxY As Integer

-    With ThisWorkbook.Worksheets(TITLE_SHEET)

-        MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-        MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-    End With

-

-    With ThisWorkbook.Application

-        .ScreenUpdating = False

-        .WindowState = xlNormal

-        .Height = MaxY

-        .Width = MaxX

-    End With

-End Sub

-

-

-

-

-

-<<<<<<
-======================
-REP_QTR
->>>>>>
-Attribute VB_Name = "REP_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CQTR_QT As Integer = 0

-Const CQTR_ID As Integer = 1

-Const CQTR_PLN As Integer = 2

-Const CQTR_FCT As Integer = 3

-Const CQTR_BDG As Integer = 4

-Const CQTR_CNT As Integer = 5

-Const CQTR_BEDS As Integer = 6

-Const CQTR_HIR As Integer = 7

-Const CQTR_TER As Integer = 8

-Const CQTR_CRD As Integer = 9

-Const CQTR_CLXN_BDG As Integer = 10

-Const CQTR_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Const LOCAL_ENT_DATE As String = "QTR_SEL"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("REP_QTR")

-        s = .Range("D5") & " " & .Range("D4") & ", " & .Range("H5") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub update_history()

-    Dim objQTR() As tQTR

-    Dim i As Long

-    Dim r As Range

-    Dim cRep As tREPID

-    Dim rm_id As Long

-

-    rm_id = Range("RM_ID")

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    Range("D4") = cRep.LastName

-    Range("D5") = cRep.FirstName

-

-    Range("H4") = GetRegionName(cRep.Region)

-    Range("H5") = GetCityName(cRep.Region, cRep.City)

-

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetAll_QTR_Records_by_REP(objQTR, "%", cRep.rep_id, rm_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CQTR_QT) = objQTR(i).entry_date

-        Next i

-    End If

-    Dim qcd() As tQTR_COMMON

-    i = Get_QTR_CommonList_by_REP(qcd, "%", cRep.rep_id, rm_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(qcd)

-            r.Offset(i - 1, CQTR_QT) = qcd(i).qtr.entry_date

-            r.Offset(i - 1, CQTR_ID) = qcd(i).qtr.id

-            r.Offset(i - 1, CQTR_PLN) = qcd(i).qtr.sale_PLAN

-            r.Offset(i - 1, CQTR_FCT) = qcd(i).c_sale_ALL

-            r.Offset(i - 1, CQTR_BDG) = qcd(i).c_bdgt_LPU

-            r.Offset(i - 1, CQTR_CNT) = qcd(i).i_lcd

-            r.Offset(i - 1, CQTR_BEDS) = qcd(i).c_beds

-            r.Offset(i - 1, CQTR_HIR) = qcd(i).c_pat_HIR

-            r.Offset(i - 1, CQTR_TER) = qcd(i).c_pat_TER

-            r.Offset(i - 1, CQTR_CRD) = qcd(i).c_pat_CRD

-            If qcd(i).c_bdgt_LPU <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_BDG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_LPU

-            End If

-            If qcd(i).c_bdgt_NMG <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_NMG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CQTR_CRD + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-

-Sub Draw_PLN_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_FCT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PLN_QTR").Range("title") = MakeChartTitle

-End Sub

-

-Sub Draw_BDGT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_CLXN_NMG + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_BDGT_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Public Sub cbxRepQtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CQTR_ID + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    i = currRange.Column - Range(CINP_AREA).Column

-

-    QTR_ID = r

-

-    If QTR_ID = 0 Then

-        Worksheets(VAR_SHEET).Range("USER_ACTION") = 1

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        If i > CQTR_FCT Then

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-            Range("LAST_FOCUS") = currRange.address

-        Else

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 3

-            Range("LAST_FOCUS") = currRange.address

-        End If

-    End If

-    Cancel = True

-    btHomeDo_IT

-End Sub

-

-<<<<<<
-======================
-mRep_QTR
->>>>>>
-Attribute VB_Name = "mRep_QTR"

-Option Explicit

-

-Sub NoFunc()

-    MsgBox "Функция не доступна", vbOKOnly, PROGRAM_NAME

-End Sub

-

-Sub DO_Price_qtr(ent_date As String)

-    Dim qtr As tQTR

-    Dim res As Integer

-    Dim cRep As tREPID

-    Dim rm_id As Long

-

-    rm_id = Worksheets(REP_QTR_SHEET).Range("RM_ID")

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    qtr = Get_QTR_Record_by_REP(ent_date, cRep.rep_id, cRep.rm_id)

-

-    If qtr.id = 0 Then

-        qtr.entry_date = ent_date

-

-        With Worksheets(VAR_SHEET)

-            qtr.ClxnH20mg = .Range("ClxnH20mg")

-            qtr.ClxnH40mg = .Range("ClxnH40mg")

-            qtr.ClxnT40mg = .Range("ClxnT40mg")

-            qtr.ClxnC_ACS = .Range("ClxnC_ACS")

-            qtr.ClxnC_IM = .Range("ClxnC_IM")

-        End With

-    End If

-

-    Dim dlg_nq As dlg_nextQTR

-    Set dlg_nq = New dlg_nextQTR

-

-    With dlg_nq

-        .tb_qtr_name = qtr.entry_date

-        .tb_bdgt_avts = qtr.sale_PLAN

-        .tb_qtr_name = qtr.entry_date

-        .tb_ClxnH20mg = qtr.ClxnH20mg

-        .tb_ClxnH40mg = qtr.ClxnH40mg

-        .tb_ClxnT40mg = qtr.ClxnT40mg

-        .tb_ClxnC_ACS = qtr.ClxnC_ACS

-        .tb_ClxnC_IM = qtr.ClxnC_IM

-    End With

-

-    dlg_nq.Show

-End Sub

-

-Sub DO_Edit_qtr(ent_date As String)

-    If ent_date = "" Then

-        NoFunc

-    Else

-        Dim rep_id As Long

-        rep_id = Worksheets(REP_QTR_SHEET).Range("REP_ID")

-        With ThisWorkbook.Worksheets("LPU_LIST")

-            .Range("VIEW_ONLY") = True

-            .setEnt_date (ent_date)

-            .Range("REP_ID") = rep_id

-            .Select

-        End With

-    End If

-End Sub

-

-Sub DO_Delete_qtr(ent_date As String)

-    If ent_date <> "" Then

-        MsgBox "Удалить данные за период [" & ent_date & "] нельзя ", vbOKOnly, PROGRAM_NAME

-    End If

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-

-Sub btHomeDo_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    idx = Worksheets(VAR_SHEET).Range("USER_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).getEnt_date()

-    Select Case idx

-        Case 1

-            NoFunc

-            ' Обновляем экран

-        Case 2

-            DO_Edit_qtr ent_date

-        Case 3

-            DO_Price_qtr ent_date

-        Case 4

-            NoFunc

-    End Select

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-Sub Delete_qtr()

-'    Dim ent_date As String

-'    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-'    DO_Delete_qtr ent_date

-End Sub

-

-Sub btREP_QTR_RET_IT()

-    Dim s As String

-    With Worksheets("REP_QTR")

-        .Range("LAST_FOCUS") = ""

-        s = .Range("ret_addr")

-        .Range("ret_addr") = ""

-    End With

-    If s <> "" Then

-        ThisWorkbook.Worksheets(s).Select

-    Else

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public ppReport As New cPPReport

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane[PM]"

-Public Const PROGRAM_VERSION As String = "Clexane[PM] ver 1.1"

-Public Const PROGRAM_FILENAME As String = "clexane-pm"

-Public Const PROGRAM_BACKUPNAME As String = "pm-backup-"

-Public Const PROGRAM_EXPORTNAME As String = "pm-ex-"

-Public Const PROGRAM_IMPORTNAME As String = "rm-ex*"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-Public Const CHART_DEF_TITLE As String = "* * *"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20031207

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "O41"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-Public Const RM_QTR_SHEET As String = "RM_QTR"

-Public Const PRJ_QTR_SHEET As String = "PRJ_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-Function time_correct(end_date As Long, ByVal theDate As Date) As Boolean

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-    If end_date = NO_ESTIMATION_DATE Then

-        time_correct = True

-        Exit Function

-    End If

-    

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    

-    time_correct = CurDate <= end_date

-    

-End Function

-

-Sub EnableRun(end_date As Long)

-    If Not time_correct(end_date, Now) Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-Sub t()

-    EnableRun ESTIMATION_DATE

-End Sub

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Sub OpenPPT()

-    ppReport.ReportView

-End Sub

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-

-End Sub

-

-Function Double2Str(ByVal d As Double, ByVal precision As Integer, Optional Delim As String = ".") As String

-    Dim s As String

-    If Not precision > 0 Then

-        s = Round(d)

-    Else

-        Dim i As Integer

-        i = Fix(d)

-        s = i & Delim

-        d = Abs(d - i)

-        Do

-            precision = precision - 1

-            d = d * 10

-            If precision > 0 Then

-                i = Fix(d)

-            Else

-                i = Round(d)

-            End If

-            If i < 1 Then

-                s = s & "0"

-            Else

-                s = s & i

-                d = d - i

-            End If

-        Loop While precision > 0

-    End If

-    Double2Str = s

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetWBName(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBName = Right(FullName, s_len - pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.Name = VAR_SHEET Or sh.Name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-<<<<<<
-======================
-Var
->>>>>>
-Attribute VB_Name = "Var"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-title
->>>>>>
-Attribute VB_Name = "title"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LPU_LIST
->>>>>>
-Attribute VB_Name = "LPU_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Const LOCAL_ENT_DATE As String = "C10"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Function getCurrentLPU_ID() As Long

-    Dim r As Range

-

-    With Worksheets("LPU_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CLPU_ID)

-    End With

-

-    getCurrentLPU_ID = r

-End Function

-

-Public Sub LPU_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectLPU_NAME(lpu_id As Long, ent_date As String)

-    SelectLPU_BDGT lpu_id, ent_date

-End Sub

-

-Sub SelectLPU_BDGT(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    If lpu_id = 0 Then

-        SelectLPU_NAME lpu_id, ent_date

-    Else

-        With ThisWorkbook.Worksheets("LPU_BDGT")

-            .Range("VIEW_ONLY") = vo

-            .Range("ret_addr") = "LPU_LIST"

-            .setEnt_date (ent_date)

-            .Range("lpu_id") = lpu_id

-            .Range("REP_ID") = rep_id

-            .Range("RM_ID") = rm_id

-        End With

-    End If

-End Sub

-

-Sub SelectLPU_HIR(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_HIR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .setEnt_date (ent_date)

-        .Range("lpu_id") = lpu_id

-        .Range("REP_ID") = rep_id

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Sub SelectLPU_TER(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_TER")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .setEnt_date (ent_date)

-        .Range("lpu_id") = lpu_id

-        .Range("REP_ID") = rep_id

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Sub SelectLPU_C_ACS(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_C_ACS")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .setEnt_date (ent_date)

-        .Range("RM_ID") = rm_id

-        .Range("REP_ID") = rep_id

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateLPUList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim lpu_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CINP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CINP_AREA).row, CLPU_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    lpu_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CINP_AREA).Column

-

-    If lpu_id = 0 Then

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    End If

-

-    If lpu_id = 0 Then

-        i = CLPU_NAME

-        Range("JUMP") = ""

-    End If

-    Select Case i

-        Case CLPU_NAME, CLPU_NAME1, CLPU_NAME2, CLPU_BEDS

-            SelectLPU_NAME lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-

-        Case CLPU_NMG, CLPU_NFG, CLPU_PLAN, CLPU_FACT

-            SelectLPU_BDGT lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-

-        Case CLPU_HIR

-            SelectLPU_HIR lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_HIR"

-

-        Case CLPU_TER

-            SelectLPU_TER lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_TER"

-

-        Case CLPU_CAR

-            SelectLPU_C_ACS lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        Case Else

-            Range("JUMP") = ""

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateLPUList()

-    Dim lcd() As tLPU_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-    Dim objQTR As tQTR

-    Dim cRep As tREPID

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    ent_date = getEnt_date

-

-'     ent_date = "%" ' % - all records

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id, cRep.rm_id)

-    i = Get_LPU_CommonQTR(lcd, objQTR)

-

-'     стираем ФИО

-    Range("C3:C4").ClearContents

-

-    Range("C3") = cRep.LastName

-    Range("C4") = cRep.FirstName

-    Range("G3") = GetRegionName(cRep.Region)

-    Range("G4") = GetCityName(cRep.Region, cRep.City)

-    Range("G5") = objQTR.sale_PLAN

-

-

-

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(lcd)

-            r.Offset(i - 1, CLPU_NAME) = lcd(i).lpu.Name

-            r.Offset(i - 1, CLPU_ID) = lcd(i).lpu.id

-            r.Offset(i - 1, CLPU_BEDS) = lcd(i).lpu.beds

-

-

-            r.Offset(i - 1, CLPU_NFG) = lcd(i).bdgt.bdgt_NFG

-            r.Offset(i - 1, CLPU_NMG) = lcd(i).bdgt.bdgt_NMG

-            r.Offset(i - 1, CLPU_PLAN) = lcd(i).bdgt.sale_PLAN

-

-            r.Offset(i - 1, CLPU_HIR) = lcd(i).pat_HIR

-            r.Offset(i - 1, CLPU_TER) = lcd(i).pat_TER

-            r.Offset(i - 1, CLPU_CAR) = lcd(i).pat_CRD

-            r.Offset(i - 1, CLPU_FACT) = lcd(i).sale_ALL

-            r.Offset(i - 1, CLPU_PAT_LPU) = lcd(i).pat_LPU

-            r.Offset(i - 1, CLPU_BDGT) = lcd(i).bdgt_LPU

-            If lcd(i).bdgt_LPU > 0 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = lcd(i).sale_ALL / lcd(i).bdgt_LPU

-            End If

-            If r.Offset(i - 1, CLPU_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{32FB0F3D-6884-41DC-99DB-E2C55B2257C4}{DED79A66-DA60-4CCC-9003-082480235D55}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-dbACS
->>>>>>
-Attribute VB_Name = "dbACS"

-Option Explicit

-

-Public Type tACS

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    patients_with_geparins As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objACS.ID <> 0 then updatre else insert

-Sub Insert_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objACS.id <> 0 Then

-        dbUpdate_ACS_Record dbConnection, objACS

-    Else

-        dbInsert_ACS_Record dbConnection, objACS

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_ACS_RecordsByLPU_ID(ByRef all_ACS_() As tACS, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_ACS_RecordsByLPU_ID = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, all_ACS_, lpu_id, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_ACS_Record dbConnection, objACS

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub dbInsert_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_acs", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objACS

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("patients_with_geparins") = .patients_with_geparins

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objACS.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim Update_SQL As String

-    

-    With objACS

-        Update_SQL = "UPDATE lpu_acs SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "patients_with_geparins=" & .patients_with_geparins & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_ACS_RecordsbyLPU_ID(dbConnection As Object, all_ACS() As tACS, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_ACS_SQL As String

-    Dim getAll_ACS_SQL As String

-    Dim ACS_Count As Long

-    ACS_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    Else

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_ACS_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        ACS_Count = dbRecordset("ACS_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_ACS_RecordsbyLPU_ID = ACS_Count

-    

-    If ACS_Count > 0 Then

-        'we have records

-        ReDim all_ACS(1 To ACS_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_ACS_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_ACS As tACS

-                 With tmp_ACS

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .patients_with_geparins = dbRecordset("patients_with_geparins")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 all_ACS(index) = tmp_ACS

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE ID=" & objACS.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_ACS_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_HIR
->>>>>>
-Attribute VB_Name = "LPU_CLSN_HIR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const LOCAL_ENT_DATE As String = "S38"

-

-Sub PrintCopy()

-    Range("A1:M26").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-

-        Dim objHir As tHIRURGIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objHir

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .operations_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L9")

-                .patients_ambulator_clexan_20mg = Range("L10")

-                .patients_ambulator_clexan_40mg = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L19")

-                .patients_stationar_clexan_20mg = Range("L20")

-                .patients_stationar_clexan_40mg = Range("L21")

-            End With

-            Insert_Hir_Record objHir

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objHir.id = Range("rec_id")

-                    If objHir.id <> 0 Then

-                        Delete_Hir_Record objHir

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-End Sub

-

-Sub SetupData(objHir As tHIRURGIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    With objHir

-        Range("rec_id") = .id

-        Range("F6") = .operations_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L9") = .patients_ambulator_clexan

-        Range("L10") = .patients_ambulator_clexan_20mg

-        Range("I21") = .patients_stationar_nmg

-        Range("L19") = .patients_stationar_clexan

-        Range("L20") = .patients_stationar_clexan_20mg

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id, cRep.rm_id)

-

-        formula = "=" & qtr.ClxnH20mg & "*($L$10+$L$20)+" & qtr.ClxnH40mg & "*($L$11+$L$21)"

-        Range("F11").formula = formula

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id, Range("RM_ID"))

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.Name

-        Range("lpu_addr") = lpu.address

-

-        Dim objHir() As tHIRURGIA

-        Dim i As Integer

-        i = GetAll_Hir_RecordsByLPU_ID(objHir, id, Range("ent_date"), Range("RM_ID"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.3

-        Else

-            SetupData objHir(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-mSapes
->>>>>>
-Attribute VB_Name = "mSapes"

-Option Explicit

-

-Const SHAPE_COLOR As Integer = 1

-Const SHAPE_NAME As Integer = 2

-

-

-Sub ShapeView(r_sh_finite_state As Range)

-    Dim chk As Range

-    Dim s As String

-    Dim c, idx As Integer

-    For Each chk In r_sh_finite_state

-        idx = 0

-        If chk = "+" Then

-            c = chk.Offset(0, idx + SHAPE_COLOR)

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While c <> 0

-                ShapeFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s)), c

-                idx = idx + 2

-                c = chk.Offset(0, idx + SHAPE_COLOR)

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        Else

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While s <> ""

-                ShapeUnFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s))

-                idx = idx + 2

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        End If

-    Next chk

-End Sub

-

-Sub ShapeFill(sh As ShapeRange, ByVal color As Integer)

-    sh.Fill.Visible = msoTrue

-    sh.Fill.Solid

-    sh.Fill.ForeColor.SchemeColor = color

-    sh.Fill.Transparency = 0#

-End Sub

-

-Sub ShapeUnFill(sh As ShapeRange)

-    sh.Fill.Visible = msoFalse

-    sh.Fill.Transparency = 0#

-End Sub

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Public Const INPUT_NO = 0

-Public Const INPUT_NUMBER = 1

-Public Const INPUT_PERCENT = 2

-Public Const INPUT_STRING = 3

-Public Const INPUT_CHECK = 4

-

-Public Const INP_IDX_TYPE = 1

-Public Const INP_IDX_NEXT = 2

-Public Const INP_IDX_MIN = 3

-Public Const INP_IDX_MAX = 4

-Public Const INP_IDX_DEP = 5

-Public Const INP_IDX_ALT = 7

-

-

-Public Type tInputSet

-    vType As Integer

-    vMin As Long

-    vMax As Long

-    rChk As String

-End Type

-

-Function is_input_cell(ByVal Target As Range, inputs As Range) As tInputSet

-    Dim t As Range

-    Dim iset As tInputSet

-    Dim test As Range

-    iset.vType = INPUT_NO

-    iset.vMin = 0

-    iset.vMax = 0

-    iset.rChk = ""

-    is_input_cell = iset

-

-' Закоментировать следующую сточку для работы

-'  Exit Function

-

-    Set test = Target.Cells(1, 1)

-    For Each t In inputs

-        If Range(t).Column = test.Column And Range(t).row = test.row Then

-            iset.vType = t.Offset(0, INP_IDX_TYPE).Value

-            Select Case iset.vType

-                Case INPUT_CHECK

-                    iset.rChk = t.Offset(0, INP_IDX_ALT)

-                Case INPUT_NUMBER, INPUT_PERCENT

-                    iset.vMin = t.Offset(0, INP_IDX_MIN).Value

-                    iset.vMax = t.Offset(0, INP_IDX_MAX).Value

-            End Select

-            is_input_cell = iset

-            Exit Function

-        End If

-    Next t

-End Function

-

-Function GetFocusAddress(ByVal r As Range, f_next As Range) As String

-    Dim chk, t As Range

-    

-    For Each chk In f_next

-        For Each t In r

-            If t.address = chk Then

-                GetFocusAddress = chk

-                Exit Function

-            End If

-            If Range(chk).Column = t.Column - 1 And Range(chk).row = t.row _

-            Or Range(chk).Column = t.Column And Range(chk).row = t.row - 1 _

-            Then

-                If Range(chk) <> "" Then

-                    If Range(chk) = 0 Then

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_ALT)).address

-                    Else

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_NEXT)).address

-                    End If

-                Else

-                    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-                End If

-                Exit Function

-            End If

-        Next t

-    Next chk

-    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-End Function

-

-Sub SetDependet(r As Range, inputs As Range)

-    Dim chk As Range

-    Dim s, serr As String

-    Dim idx As Integer

-    Dim iset As tInputSet

-    Dim err_found As Boolean

-    

-    If r.count > 1 Then

-        Exit Sub

-    End If

-    

-    err_found = False

-    For Each chk In inputs

-        idx = INP_IDX_DEP

-        

-        

-        iset.vType = chk.Offset(0, INP_IDX_TYPE).Value

-        Select Case iset.vType

-            Case INPUT_NUMBER, INPUT_PERCENT

-                iset.vMin = chk.Offset(0, INP_IDX_MIN).Value

-                iset.vMax = chk.Offset(0, INP_IDX_MAX).Value

-                

-                If Range(chk) > iset.vMax Then

-                    err_found = True

-                    Range(chk) = iset.vMax

-                    serr = "Выход за дозволенный диапазон [" & iset.vMin & ".." & iset.vMax & "]! Данные скорректированы."

-                End If

-                

-                If Range(chk) = "" Then

-                    s = chk.Offset(0, idx)

-                    Do While s <> ""

-                        Range(s) = ""

-                        idx = idx + 1

-                        s = chk.Offset(0, idx)

-                    Loop

-                End If

-        End Select

-    Next chk

-    If err_found Then

-        MsgBox serr, vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Function CheckInputData(inputs As Range) As Boolean

-    Dim r As Range

-    

-    CheckInputData = True

-    For Each r In inputs

-        If Range(r) = "" Then

-            CheckInputData = False

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100.", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Sub Check_Int_Number(Target As Range, Def_Val As Long)

-    Dim err As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    err = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                err = True

-            End If

-        End If

-    Next r

-    If err Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_TER
->>>>>>
-Attribute VB_Name = "LPU_CLSN_TER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const LOCAL_ENT_DATE As String = "S38"

-

-Sub PrintCopy()

-    Range("A1:M26").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim objTer As tTERAPIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objTer

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .patients_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L20")

-            End With

-            Insert_Ter_Record objTer

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objTer.id = Range("rec_id")

-                    If objTer.id <> 0 Then

-                        Delete_Ter_Record objTer

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-

-End Sub

-

-Sub SetupData(objTer As tTERAPIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    With objTer

-        Range("rec_id") = .id

-        Range("F6") = .patients_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L11") = .patients_ambulator_clexan

-        Range("I21") = .patients_stationar_nmg

-        Range("L20") = .patients_stationar_clexan

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id, cRep.rm_id)

-        formula = "=" & qtr.ClxnT40mg & "*($L$12+$L$20)"

-        Range("F11").formula = formula

-

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id, Range("RM_ID"))

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.Name

-        Range("lpu_addr") = lpu.address

-

-        Dim objTer() As tTERAPIA

-        Dim i As Integer

-        i = GetAll_Ter_RecordsByLPU_ID(objTer, id, Range("ent_date"), Range("RM_ID"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.25

-        Else

-            SetupData objTer(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{0DC9E035-CE0A-49FF-85A2-A4EC5FF8FE96}{D54DDC8A-1EE2-4BB3-8B94-343B521AF098}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-LPU_BDGT
->>>>>>
-Attribute VB_Name = "LPU_BDGT"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const LOCAL_ENT_DATE As String = "S15"

-

-Sub PrintCopy()

-    Range("B1:K21").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Sub SetDefFocus()

-    Range(Range("DEF_FOCUS")).Select

-End Sub

-

-Public Sub ClearData()

-    ClearSheetData

-End Sub

-

-Sub ClearSheetData()

-    If Range("F10") = 0 And Range("F13") = 0 Then

-        Range("F11:F18") = ""

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("F11:F13") = ""

-    End If

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim bdgt As tBUDGET

-        Dim sum As Long

-        Dim test As Boolean

-        With bdgt

-            .lpu_id = Range("lpu_id")

-            .id = Range("rec_id")

-            .entry_date = Range("ent_date")

-            .bdgt_NMG = Round(Range("F11").Value, 0)

-            .bdgt_NFG = Round(Range("F12").Value, 0)

-            .sale_PLAN = Round(Range("F13").Value, 0)

-

-            sum = .bdgt_NFG + .bdgt_NMG - .sale_PLAN

-            test = .bdgt_NFG <> 0 Or .bdgt_NMG <> 0 Or .sale_PLAN <> 0

-        End With

-        If test Then

-            If sum < 0 Then

-                MsgBox _

-                    "Ваш план превышает выделенный на гепарины бюджет. Сохранить данные?", _

-                    vbOKOnly, PROGRAM_NAME

-            End If

-            If test Then

-                Insert_BDGT_Record bdgt

-            End If

-        Else

-            If bdgt.id <> 0 Then

-                If vbYes = MsgBox("Удалить данные из базы!", vbYesNo, PROGRAM_NAME) Then

-                    Delete_BDGT_Record bdgt

-                End If

-                ret_back Range("DEF_FOCUS").Worksheet

-                Exit Sub

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-    End If

-

-   ClearData

-   ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(cLPU As tLPU_COMMON)

-    Dim t_sum As Long

-    t_sum = 0

-' Setup budget data

-    Range("F11") = cLPU.bdgt.bdgt_NMG

-    Range("F12") = cLPU.bdgt.bdgt_NFG

-    Range("F13") = cLPU.bdgt.sale_PLAN

-

-    With cLPU

-        Range("F14") = .pat_ALL

-        Range("F15") = .pat_HIR

-        Range("F16") = .pat_TER

-        Range("F17") = .pat_CRD

-        Range("F18") = .sale_ALL

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    ws_activate

-End Sub

-

-

-Sub ws_activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Dim cLPU As tLPU_COMMON

-    Dim objQTR As tQTR

-    Dim objLPU As tLPU

-    Dim ent_date As String

-    Dim id As Long

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"), Range("RM_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    id = Range("lpu_id").Value

-    ent_date = Range("ent_date")

-    

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id, cRep.rm_id)

-

-    objLPU = Get_LPU_Record(id, Range("RM_ID"))

-    Get_LPU_Common cLPU, objLPU, objQTR

-

-    If cLPU.lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = cLPU.lpu.beds

-        Range("lpu_name") = cLPU.lpu.Name

-        Range("lpu_addr") = cLPU.lpu.address

-        Range("rec_id") = cLPU.bdgt.id

-

-        SetupData cLPU

-

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-'    MsgBox Target.address

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case INPUT_CHECK

-

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{BFB4547C-96A7-4739-AA0A-CEF1E35E2BDC}{C3D618A3-9410-4BC7-9D93-3B049D361132}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mSheets
->>>>>>
-Attribute VB_Name = "mSheets"

-Option Explicit

-

-Function am_load_now() As Boolean

-    am_load_now = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE")

-End Function

-

-Sub Wks_select(RetSheet As String)

-    Dim sheet As Worksheet

-    For Each sheet In ThisWorkbook.Worksheets

-        If sheet.Name = RetSheet Then

-            ThisWorkbook.Worksheets(RetSheet).Select

-            Exit Sub

-        End If

-    Next sheet

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub ret_back(sh As Worksheet)

-    Dim RetSheet As String

-    RetSheet = sh.Range("ret_addr")

-    sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    sh.Range("rec_id") = ""

-    sh.Range("lpu_id") = ""

-    sh.Range("ent_date") = ""

-    sh.Range("lpu_name") = ""

-    sh.Range("lpu_addr") = ""

-    sh.Range("lpu_beds") = ""

-    Wks_select RetSheet

-    sh.Range("ret_addr") = ""

-End Sub

-

-Sub ClearSheetData(r_start As Range)

-    If r_start <> "" Then

-        r_start.Worksheet.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        r_start = ""

-    Else

-        ret_back r_start.Worksheet

-    End If

-End Sub

-

-Sub wks_sel_chng(iset As tInputSet, ByVal Target As Range, sh As Worksheet)

-    Dim DebugMode As Boolean

-    Dim in_range As Range

-    

-    DebugMode = Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-

-    If DebugMode Then

-        sh.Unprotect

-    Else

-        sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    End If

-

-    If iset.vType = INPUT_CHECK Then

-        Set in_range = Target.Worksheet.Range(iset.rChk)

-    Else

-        Set in_range = Target

-    End If

-    

-    Dim str As String

-    str = GetFocusAddress(in_range, sh.Range("h_inputs"))

-

-'    MsgBox Target.Address & "; " & str

-    If str <> Target.address Then

-        sh.Range(str).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-Dlg_lpu_card
->>>>>>
-Attribute VB_Name = "Dlg_lpu_card"

-Attribute VB_Base = "0{9AAD262F-A6C4-4912-9C58-D7A2071181B8}{9470F4EB-DA9F-4584-9159-D09319548D21}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbLPU_List_Change()

-    Dim src As Range

-    Dim idx_src As Integer

-    

-    Set src = Worksheets(VAR_SHEET).Range(Me.cbLPU_List.RowSource)

-    idx_src = Me.cbLPU_List.ListIndex + 1

-    Me.tb_lpu_name.Text = src.Cells(idx_src, 1)

-    Me.tb_lpu_address.Text = src.Cells(idx_src, 2)

-    Me.tbBedsCount.Text = src.Cells(idx_src, 3)

-End Sub

-

-

-Private Sub cbxLPU_List_Enable_Click()

-    

-    If Me.cbxLPU_List_Enable Then

-        

-        Me.tb_lpu_name.Text = ""

-        Me.tb_lpu_name.Enabled = False

-        

-        Me.tb_lpu_address.Text = ""

-        Me.tb_lpu_address.Enabled = False

-        

-        Me.tbBedsCount.Text = ""

-        Me.tbBedsCount.Enabled = False

-        

-        Me.cbLPU_List.Enabled = True

-        cbLPU_List_Change

-    Else

-        Me.tb_lpu_name.Enabled = True

-        Me.tb_lpu_name.Text = ""

-        

-        Me.tb_lpu_address.Enabled = True

-        Me.tb_lpu_address.Text = ""

-        

-        Me.tbBedsCount.Enabled = True

-        Me.tbBedsCount.Text = ""

-        

-        Me.cbLPU_List.Enabled = False

-    End If

-End Sub

-

-<<<<<<
-======================
-UserInfo
->>>>>>
-Attribute VB_Name = "UserInfo"

-Attribute VB_Base = "0{A8FBEE9C-DE59-49DE-971D-07BC9C0E9BD2}{C712732B-D8E4-4C2D-8E78-AC90968E0CD7}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Tag = vbOK

-End Sub

-

-Private Sub cbCity_Change()

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_CITY") = Me.cbCity.ListIndex

-        .Calculate

-    End With

-End Sub

-

-Private Sub cbRegion_Change()

-    Dim LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        NewRangeOffsetCol = cbRegion.Value * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .Name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).address

-        NewSumRange = .Name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).address

-        .Calculate

-        .Range("IDX_CITY") = 0

-        cbCity.RowSource = NewCbxRange

-

-    End With

-    cbCity.ListIndex = 0

-End Sub

-

-<<<<<<
-======================
-mREGMAN
->>>>>>
-Attribute VB_Name = "mREGMAN"

-Option Explicit

-

-Sub hw_reset()

-    Dim rs As Range

-    Dim re As Object

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    HWReset

-    With Application

-        .DisplayAlerts = False

-        .Quit

-    End With

-End Sub

-

-Sub CheckUser()

-    If Range("HW_Number") = "" Then

-        StoreHWInfo

-    End If

-    If CheckHWInfo <> True Then

-        MsgBox "2"

-        cmAbout

-'        With Application

-'            .DisplayAlerts = False

-'            .Quit

-'        End With

-    Else

-        SetupUser

-    End If

-End Sub

-

-

-Sub SetupUser()

-'    Dim cREGMAN As tREGMAN

-'    Dim idx As Integer

-'    Dim dlg_ui As UserInfo

-'

-'    Set dlg_ui = New UserInfo

-'

-'    cREGMAN = Get_REGMAN_Record()

-'

-'    With ThisWorkbook.Worksheets(REGS_SHEET)

-'        .Range("IDX_REGION") = cREGMAN.Region

-'        .Range("IDX_CITY") = cREGMAN.City

-'    End With

-'

-'    With dlg_ui

-'        .cbRegion = cREGMAN.Region

-'        .cbCity = cREGMAN.City

-'        .tbFName = cREGMAN.FirstName

-'        .tbLName = cREGMAN.LastName

-'    End With

-'

-'    dlg_ui.Show

-'    Worksheets(REGS_SHEET).Calculate

-'

-'    If dlg_ui.Tag = vbOK Then

-'        With cREGMAN

-'            .Region = dlg_ui.cbRegion.Value

-'            .City = dlg_ui.cbCity.Value

-'            .FirstName = dlg_ui.tbFName.Value

-'            .LastName = dlg_ui.tbLName.Value

-'        End With

-'        Set_REGMAN_Record cREGMAN

-'    Else

-'        cmAbout

-'        With Application

-'            .DisplayAlerts = False

-'            .Quit

-'        End With

-'    End If

-End Sub

-

-Sub StoreHWInfo()

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim objHW() As Long

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    Set r = Range("HW_Number")

-    i = 1

-    For Each d In dc

-        If d.drivetype = 2 Then

-            r = d.SerialNumber

-            Set r = r.Offset(1, 0)

-            ReDim Preserve objHW(i)

-            objHW(i) = d.SerialNumber

-            i = i + 1

-        End If

-    Next

-    

-    UpdateHWRecords objHW

-End Sub

-

-Function CheckHWInfo()

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim objHW() As Long

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    

-    CheckHWInfo = False

-    

-    i = GetHWRecords(objHW)

-    If i = 0 And Range("HW_Number") <> 0 Then

-        Exit Function

-    End If

-    For Each d In dc

-        If d.drivetype = 2 Then

-            Set r = Range("HW_Number")

-            Do While r <> ""

-                If r = d.SerialNumber Then

-                    For i = 1 To UBound(objHW)

-                        If d.SerialNumber = objHW(i) Then

-                            CheckHWInfo = True

-                            Exit Function

-                        End If

-                    Next i

-                End If

-                Set r = r.Offset(1, 0)

-            Loop

-        End If

-    Next

-End Function

-<<<<<<
-======================
-dbBudget
->>>>>>
-Attribute VB_Name = "dbBudget"

-Option Explicit

-

-Public Type tBUDGET

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    rm_id As Long

-    bdgt_NMG As Long

-    bdgt_NFG As Long

-    sale_PLAN As Long

-End Type

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function GetAll_BDGT_RecordsByLPU_ID(ByRef allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_BDGT_RecordsByLPU_ID = dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection, allBDGT, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function Get_BDGT_Record(ByVal lpu_id As Long, ByVal ent_date As String, rm_id As Long) As tBUDGET

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    Get_BDGT_Record = dbGet_BDGT_Record(dbConnection, lpu_id, ent_date, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-' if objBDGT.ID <> 0 then updatre else insert

-Public Sub Insert_BDGT_Record(objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    If objBDGT.id <> 0 Then

-        dbUpdate_BDGT_Record dbConnection, objBDGT

-    Else

-        dbInsert_BDGT_Record dbConnection, objBDGT

-    End If

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Public Sub Delete_BDGT_Record(ByRef objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    dbDelete_BDGT_Record dbConnection, objBDGT

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_BDGT_Record(dbConnection As Object, ByVal lpu_id As Long, ent_date As String, rm_id As Long) As tBUDGET

-    

-    Dim sql As String

-    Dim objBDGT As tBUDGET

-    

-    With objBDGT

-        .id = 0

-        .lpu_id = lpu_id

-        .rm_id = rm_id

-        .entry_date = ent_date

-        .bdgt_NMG = 0

-        .bdgt_NFG = 0

-        .sale_PLAN = 0

-    End With

-        

-    

-    sql = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        With objBDGT

-            .entry_date = dbRecordset("entry_date")

-            .id = dbRecordset("id")

-            .lpu_id = dbRecordset("lpu_id")

-            .bdgt_NFG = dbRecordset("bdgt_NFG")

-            .bdgt_NMG = dbRecordset("bdgt_NMG")

-            .sale_PLAN = dbRecordset("sale_PLAN")

-        End With

-    End If

-    

-    dbGet_BDGT_Record = objBDGT

-End Function

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection As Object, allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_BDGT_SQL As String

-    Dim getAll_BDGT_SQL As String

-    Dim BDGT_Count As Long

-    BDGT_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_BDGT_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        BDGT_Count = dbRecordset("BDGT_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_BDGT_RecordsbyLPU_ID = BDGT_Count

-    

-    If BDGT_Count > 0 Then

-        'we have records

-        ReDim allBDGT(1 To BDGT_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_BDGT_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpBDGT As tBUDGET

-                 With tmpBDGT

-                    .entry_date = dbRecordset("entry_date")

-                    .id = dbRecordset("id")

-                    .lpu_id = dbRecordset("lpu_id")

-                    .bdgt_NFG = dbRecordset("bdgt_NFG")

-                    .bdgt_NMG = dbRecordset("bdgt_NMG")

-                    .sale_PLAN = dbRecordset("sale_PLAN")

-                 End With

-                 

-                 allBDGT(index) = tmpBDGT

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbInsert_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "lpu_budget", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    dbRecordset("entry_date") = objBDGT.entry_date

-    dbRecordset("lpu_id") = objBDGT.lpu_id

-    dbRecordset("bdgt_NMG") = objBDGT.bdgt_NMG

-    dbRecordset("bdgt_NFG") = objBDGT.bdgt_NFG

-    dbRecordset("sale_PLAN") = objBDGT.sale_PLAN

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objBDGT.id = dbRecordset("id")

-  

-End Sub

-

-Public Sub dbUpdate_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu_budget SET " & _

-    "entry_date='" & objBDGT.entry_date & "'," & _

-    "lpu_id=" & objBDGT.lpu_id & "," & _

-    "bdgt_NMG=" & objBDGT.bdgt_NMG & "," & _

-    "bdgt_NFG=" & objBDGT.bdgt_NFG & "," & _

-    "sale_PLAN=" & objBDGT.sale_PLAN & _

-    " WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-Public Sub dbDelete_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_BDGT_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbDatabase
->>>>>>
-Attribute VB_Name = "dbDatabase"

-Option Explicit

-

-

-Sub dbOpenConnection(dbConnection As Object)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-<<<<<<
-======================
-dbLPU
->>>>>>
-Attribute VB_Name = "dbLPU"

-Option Explicit

-

-Public Type tLPU

-    id As Long

-    rep_id As Long

-    rm_id As Long

-    Name As String

-    address As String

-    beds As Integer

-End Type

-

-Function Get_LPU_Record(ByVal lpu_id As Long, rm_id As Long) As tLPU

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_LPU_Record = dbGet_LPU_Record(dbConnection, lpu_id, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_LPU_byQTR(allLPU() As tLPU, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_LPU_byQTR = dbGetAll_LPU_byQTR(dbConnection, allLPU, ent_date, rep_id, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_Record(dbConnection As Object, ByVal lpu_id As Long, rm_id As Long) As tLPU

-    

-    Dim sql As String

-    Dim objLPU As tLPU

-    

-    objLPU.id = lpu_id

-    objLPU.Name = ""

-    objLPU.address = ""

-    

-    sql = "SELECT * FROM lpu WHERE id=" & lpu_id & " AND rm_id=" & rm_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objLPU.Name = dbRecordset("name")

-        objLPU.address = dbRecordset("address")

-        objLPU.rep_id = dbRecordset("rep_id")

-        objLPU.rm_id = dbRecordset("rm_id")

-        objLPU.beds = dbRecordset("beds")

-    End If

-    

-    dbGet_LPU_Record = objLPU

-

-End Function

-

-Function dbGetAll_LPU_byQTR(dbConnection As Object, allLPU() As tLPU, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    Dim Where As String

-    Where = "WHERE lpu_budget.entry_date like '" & ent_date & "'" & " AND lpu.id=lpu_budget.lpu_id " & _

-    "AND lpu.rep_id=" & rep_id & " AND lpu.rm_id=lpu_budget.rm_id AND lpu.rm_id=" & rm_id

-

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu_budget, lpu " & Where

-    

-    getAll_LPU_SQL = "SELECT lpu.id as id, lpu.rep_id as rep_id, lpu.name as name, lpu.address as address, lpu.beds AS beds, lpu.rm_id AS rm_id " & _

-    "FROM lpu, lpu_budget " & Where

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_LPU_byQTR = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .Name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-dbREP
->>>>>>
-Attribute VB_Name = "dbREP"

-'Option Explicit

-'

-'Public Type tREP

-'    FirstName As String

-'    LastName As String

-'    Region As Integer

-'    City As Integer

-'End Type

-'

-'Function GetREPRecord() As tREP

-'    Dim dbConnection As Object

-'

-'    dbOpenConnection dbConnection

-'    GetREPRecord = dbGetREPRecord(dbConnection)

-'    dbCloseConnection dbConnection

-'End Function

-'

-'Sub SetREPRecord(cUser As tREP)

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbSetREPRecord dbConnection, cUser

-'    dbCloseConnection dbConnection

-'End Sub

-'

-'Public Function dbGetREPRecord(dbConnection As Object) As tREP

-'

-'    Dim SQL As String

-'    Dim objREP As tREP

-'

-'    objREP.FirstName = ""

-'    objREP.LastName = ""

-'    objREP.Region = 0

-'    objREP.City = 0

-'    SQL = "SELECT firstname, lastname, region, city FROM " & _

-'          "rep"

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open SQL, dbConnection

-'    ', 3, 3

-'    If Not dbRecordset.BOF Then

-'

-'        objREP.FirstName = dbRecordset("firstname")

-'        objREP.LastName = dbRecordset("lastname")

-'        objREP.Region = dbRecordset("region")

-'        objREP.City = dbRecordset("city")

-'

-'    End If

-'

-'    dbGetREPRecord = objREP

-'

-'End Function

-'

-'Public Sub dbSetREPRecord(dbConnection As Object, ByRef objREP As tREP)

-'

-'    Dim DeleteSQL As String

-'    Dim InsertSQL As String

-'

-'    DeleteSQL = "DELETE FROM rep"

-'    InsertSQL = "INSERT INTO rep (firstname, lastname, region, city) VALUES (" & _

-'    "'" & objREP.FirstName & "', " & _

-'    "'" & objREP.LastName & "', " & _

-'    objREP.Region & ", " & _

-'    objREP.City & ")"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-'

-'End Sub

-'

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    CheckWorkBooksArround Wb

-End Sub

-

-

-Sub CheckWorkBooksArround(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If app.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEL сейчас будут закрыты!", vbOKOnly, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub GetState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-        ActiveWorkbook.DisplayDrawingObjects = xlDisplayShapes

-        

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.Name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars(STDBAR_NAME).Visible = False

-End Sub

-

-

-Public Sub RestoreState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars(STDBAR_NAME).Visible = True

-End Sub

-

-

-

-<<<<<<
-======================
-cdbRM
->>>>>>
-Attribute VB_Name = "cdbRM"

-Option Explicit

-

-Public Type tRMID_COMMON

-    rm As tREGMAN

-    rgcd_count As Integer

-    rgcd() As tREGION

-End Type

-

-Function Get_RM_CommonList_by_QTR(ByRef rmcd() As tRMID_COMMON, ent_date As String) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_RM_CommonList_by_QTR = dbGet_RM_CommonList_by_QTR(dbConnection, rmcd(), ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_RM_CommonList_by_QTR(dbConnection As Object, ByRef rmcd() As tRMID_COMMON, ent_date As String) As Integer

-    ' Получить список RM-ов

-    Dim count As Integer

-    count = db_get_All_RM_by_QTR(dbConnection, rmcd(), ent_date)

-    

-    Dim i As Integer

-    For i = 1 To count

-        rmcd(i).rgcd_count = 1

-        ReDim rmcd(i).rgcd(1 To 1)

-        getREGION_by_QTR ent_date, rmcd(i).rgcd(1), rmcd(i).rm.rm_id

-    Next i

-    dbGet_RM_CommonList_by_QTR = count

-End Function

-

-Function db_get_All_RM_by_QTR(dbConnection As Object, rmcd() As tRMID_COMMON, ent_date As String) As Integer

-    

-    Dim count_sql As String

-    Dim get_sql As String

-    Dim rs As Object

-    Dim RM_Count As Integer

-        

-    count_sql = "SELECT COUNT(*) AS RM_TOTAL FROM reg_man"

-    get_sql = "SELECT * FROM reg_man"

-    Set rs = CreateObject("ADODB.Recordset")

-    rs.Open count_sql, dbConnection

-    

-    If Not rs.BOF Then

-        RM_Count = rs("RM_TOTAL")

-    End If

-    

-    rs.Close

-    

-     db_get_All_RM_by_QTR = RM_Count

-    

-    If RM_Count > 0 Then

-        'we have records

-        ReDim rmcd(1 To RM_Count)

-        Dim index As Long

-        index = 1

-        rs.Open get_sql, dbConnection

-        

-        If Not rs.BOF Then

-             Do While Not rs.EOF

-                 Dim tmp_rmcd As tRMID_COMMON

-                 With tmp_rmcd

-                    .rgcd_count = 0

-                    .rm.City = rs("city")

-                    .rm.FirstName = rs("firstname")

-                    .rm.LastName = rs("lastname")

-                    .rm.rm_id = rs("mgr_id")

-                    .rm.Region = rs("region")

-                 End With

-                 

-                 rmcd(index) = tmp_rmcd

-                 index = index + 1

-                 rs.MoveNext

-             Loop

-        End If

-    End If

-    

-End Function

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Public Const STDBAR_NAME = "Worksheet Menu Bar"

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Import data"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmDataImport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-             With .Add(msoControlPopup)

-                .Caption = "&Report"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&New Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 18

-                        .OnAction = "cmNewReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Open Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmOpenReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Close && Save"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseReport"

-                    End With

-                End With

-            End With

-           With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Exit && Restore Excel"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 548

-                        .OnAction = "cmExitRestore"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-        End With

-    End With

-End Sub

-

-Sub CreateExtCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom extendet commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Import data"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmDataImport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-             With .Add(msoControlPopup)

-                .Caption = "&Report"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&New Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 18

-                        .OnAction = "cmNewReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Open Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmOpenReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Close && Save"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseReport"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Add New Slide"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 280

-                .OnAction = "cmAddSlide"

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(flag As Boolean)

-    If flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars(STDBAR_NAME)

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmExport()

-    dbExport

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    Dim dlg As dlgAbout

-    Set dlg = New dlgAbout

-    

-    dlg.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlg.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlg.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlg.Show

-End Sub

-

-Sub cmMail2Support()

-    Dim err_description As String

-    Dim dlg_msg As dlg_Mail

-    Set dlg_msg = New dlg_Mail

-    With dlg_msg

-        .Show

-        If .Tag = vbOK Then

-            ThisWorkbook.Worksheets(VAR_SHEET).Range("ERR_MESSAGE") _

-                = .tbMessage.Text

-            ThisWorkbook.Save

-            ThisWorkbook.SendMail Recipients:="infra@i-rs.ru", Subject:=PROGRAM_NAME & " ver.:" & PROGRAM_VERSION

-            MsgBox "Сообщение об ошибке отправлено. Перезагрузите программу.", vbOKOnly, PROGRAM_NAME

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-    End With

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-'        helppath = "hh.exe " & .Path & "\Telfast.chm"

-'        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub set_work_mode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-End Sub

-

-Sub cmSetStandaloneMode()

-    set_work_mode

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    Dim dlg As dlgGetPwd

-    rp = common_pwd

-    

-    Set dlg = New dlgGetPwd

-    dlg.edPwd = ""

-    dlg.Show

-    

-    If dlg.edPwd = rp Then

-        Application.ScreenUpdating = False

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-        xlRestoreView

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-        Application.ScreenUpdating = True

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmNewReport()

-    ppReport.CreateReport

-    MsgBox "Новый отчет создан", vbInformation + vbOKOnly, PROGRAM_NAME

-    CreateExtCommandBar theApp:=ThisWorkbook.Application

-End Sub

-

-Sub cmOpenReport()

-    Dim fileToOpen

-    Dim s As String

-    fileToOpen = Application _

-        .GetOpenFileName("Report Files (*.ppt), *.ppt", title:="Report OPen", MultiSelect:=False)

-    If fileToOpen <> False Then

-        s = fileToOpen

-        ppReport.OpenReport s

-        CreateExtCommandBar theApp:=ThisWorkbook.Application

-    End If

-End Sub

-

-Sub cmCloseReport()

-    On Error Resume Next

-    ppReport.SaveReport

-    CreateCommandBar theApp:=ThisWorkbook.Application

-End Sub

-

-Sub cmAddSlide()

-    ThisWorkbook.ActiveSheet.PrintCopy

-    ppReport.InsertSlide

-End Sub

-

-Sub cmHomePage()

-    ThisWorkbook.Worksheets("PRJ_QTR").Select

-End Sub

-

-Sub cmExitRestore()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = True

-    Application.Quit

-End Sub

-

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    Dim dlg_prn As dlgPrint

-    

-    Set dlg_prn = New dlgPrint

-    

-    With dlg_prn

-        .cbMainReport = True

-        .cbMainBudget = False

-        .cbSrcData = False

-        .cbAllSheets = False

-    

-        .Show

-    

-        If .Tag = vbCancel Then

-            Exit Sub

-        End If

-    End With

-    

-    Dim PrnIdx As Integer

-    

-    With dlg_prn

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("REP_QTR", "budget", "Final")

-    Case 1111

-        plist = Array("REP_QTR", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("REP_QTR")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Clexane bar"

-Public Const common_pwd As String = "crdjhxtyjr"

-

-

-Sub SetEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    With Application

-        .Caption = PROGRAM_NAME

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .GetState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = False

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Unprotect

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    If cWindow.Type = xlWorkbook Then

-                        cWindow.DisplayHeadings = True

-                    End If

-                Next

-            End If

-        Next

-        If DesignMode Then

-            SetupDesignMenu True

-        End If

-        With mobjAppState

-            .RestoreState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Option Explicit

-

-Sub UpdateHWRecords(objHW() As Long)

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    dbUpdateHWRecords dbConnection, objHW

-    dbCloseConnection dbConnection

-End Sub

-

-Function GetHWRecords(objHW() As Long) As Integer

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    GetHWRecords = dbGetHWRecords(dbConnection, objHW)

-    dbCloseConnection dbConnection

-End Function

-

-Sub HWReset()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbInsertHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    

-    Dim dbRecordset As Object

-    Dim i As Long

-    

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "hw", dbConnection, 2, 2

-    

-    For i = 1 To UBound(objHW)

-        dbRecordset.addnew

-        dbRecordset("num") = objHW(i)

-        dbRecordset.Update

-    Next i

-    

-End Sub

-

-Sub dbUpdateHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    dbDeleteHWRecord dbConnection

-    dbInsertHWRecords dbConnection, objHW

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-dbHir
->>>>>>
-Attribute VB_Name = "dbHir"

-Option Explicit

-

-Public Type tHIRURGIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    operations_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_ambulator_clexan_40mg As Integer

-    patients_ambulator_clexan_20mg As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-    patients_stationar_clexan_40mg As Integer

-    patients_stationar_clexan_20mg As Integer

-End Type

-

-' if objHir.ID <> 0 then updatre else insert

-Sub Insert_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objHir.id <> 0 Then

-        dbUpdate_Hir_Record dbConnection, objHir

-    Else

-        dbInsert_Hir_Record dbConnection, objHir

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Hir_RecordsByLPU_ID(ByRef allHir() As tHIRURGIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Hir_RecordsByLPU_ID = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, allHir, lpu_id, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Hir_Record dbConnection, objHir

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objHir.ID <> 0 then updatre else insert

-

-Sub dbInsert_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_hir", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objHir

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("operations_per_quarter") = .operations_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_ambulator_clexan_20mg") = .patients_ambulator_clexan_20mg

-        dbRecordset("patients_ambulator_clexan_40mg") = .patients_ambulator_clexan_40mg

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-        dbRecordset("patients_stationar_clexan_20mg") = .patients_stationar_clexan_20mg

-        dbRecordset("patients_stationar_clexan_40mg") = .patients_stationar_clexan_40mg

-        

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objHir.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim UpdateSQL As String

-    

-    With objHir

-        UpdateSQL = "UPDATE lpu_hir SET " & _

-            "entry_date='" & objHir.entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "operations_per_quarter=" & .operations_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_ambulator_clexan_20mg=" & .patients_ambulator_clexan_20mg & "," & _

-            "patients_ambulator_clexan_40mg=" & .patients_ambulator_clexan_40mg & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & "," & _

-            "patients_stationar_clexan_20mg=" & .patients_stationar_clexan_20mg & "," & _

-            "patients_stationar_clexan_40mg=" & .patients_stationar_clexan_40mg & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_Hir_RecordsbyLPU_ID(dbConnection As Object, allHir() As tHIRURGIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_Hir_SQL As String

-    Dim getAll_Hir_SQL As String

-    Dim Hir_Count As Long

-    Hir_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    Else

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Hir_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Hir_Count = dbRecordset("HIR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Hir_RecordsbyLPU_ID = Hir_Count

-    

-    If Hir_Count > 0 Then

-        'we have records

-        ReDim allHir(1 To Hir_Count)

-        Dim index As Integer

-        index = 1

-        dbRecordset.Open getAll_Hir_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpHir As tHIRURGIA

-                 With tmpHir

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .operations_per_quarter = dbRecordset("operations_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_ambulator_clexan_20mg = dbRecordset("patients_ambulator_clexan_20mg")

-                    .patients_ambulator_clexan_40mg = dbRecordset("patients_ambulator_clexan_40mg")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                    .patients_stationar_clexan_20mg = dbRecordset("patients_stationar_clexan_20mg")

-                    .patients_stationar_clexan_40mg = dbRecordset("patients_stationar_clexan_40mg")

-                 End With

-                 

-                 allHir(index) = tmpHir

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE ID=" & objHir.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Hir_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbTer
->>>>>>
-Attribute VB_Name = "dbTer"

-Option Explicit

-

-Public Type tTERAPIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objTer.ID <> 0 then updatre else insert

-Sub Insert_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objTer.id <> 0 Then

-        dbUpdate_Ter_Record dbConnection, objTer

-    Else

-        dbInsert_Ter_Record dbConnection, objTer

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Ter_RecordsByLPU_ID(ByRef allTer() As tTERAPIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Ter_RecordsByLPU_ID = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, allTer, lpu_id, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Ter_Record dbConnection, objTer

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objTer.ID <> 0 then updatre else insert

-

-Sub dbInsert_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_ter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objTer

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objTer.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim Update_SQL As String

-    

-    With objTer

-        Update_SQL = "UPDATE lpu_ter SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_Ter_RecordsbyLPU_ID(dbConnection As Object, allTer() As tTERAPIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_Ter_SQL As String

-    Dim getAll_Ter_SQL As String

-    Dim Ter_Count As Long

-    Ter_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    Else

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Ter_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Ter_Count = dbRecordset("TER_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Ter_RecordsbyLPU_ID = Ter_Count

-    

-    If Ter_Count > 0 Then

-        'we have records

-        ReDim allTer(1 To Ter_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_Ter_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpTer As tTERAPIA

-                 With tmpTer

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 allTer(index) = tmpTer

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE ID=" & objTer.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Ter_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-mLPU_LIST
->>>>>>
-Attribute VB_Name = "mLPU_LIST"

-Option Explicit

-

-Public Const CINP_AREA As String = "B12"

-Public Const CLPU_NAME As Integer = 0

-Public Const CLPU_NAME1 As Integer = 1

-Public Const CLPU_NAME2 As Integer = 2

-Public Const CLPU_ID As Integer = 3

-Public Const CLPU_BEDS As Integer = 4

-Public Const CLPU_NFG As Integer = 5

-Public Const CLPU_NMG As Integer = 6

-Public Const CLPU_HIR As Integer = 7

-Public Const CLPU_TER As Integer = 8

-Public Const CLPU_CAR As Integer = 9

-Public Const CLPU_FACT As Integer = 10

-Public Const CLPU_PLAN As Integer = 11

-Public Const CLPU_PAT_LPU As Integer = 16

-Public Const CLPU_BDGT As Integer = 17

-Public Const CLPU_PAT_ALL As Integer = 16

-

-Sub EditLPU(cLPU As tLPU, ent_date As String)

-    NoFunc

-End Sub

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("LPU_LIST")

-        s = .Range("C4") & " " & .Range("C3") & ", " & .Range("G4") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_LPU_BBL").Range("title") = MakeChartTitle

-End Sub

-

-Sub Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PIE").Range("title") = MakeChartTitle

-End Sub

-

-Sub Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU_A").Range("title") = MakeChartTitle

-End Sub

-

-Sub btLPU_DEL_IT()

-'    Dim cLPU As tLPU

-'    Dim ent_date As String

-'    Dim delete_all As Integer

-'    Dim dlg_del As dlg_LPU_delete

-'

-'    With Worksheets("LPU_LIST")

-'        ent_date = .Range("ent_date")

-'        cLPU.id = .getCurrentLPU_ID()

-'    End With

-'

-'    If cLPU.id = 0 Then

-'        MsgBox "Укажите удаляемый объект", vbOKOnly, PROGRAM_NAME

-'        Exit Sub

-'    End If

-'    cLPU = Get_LPU_Record(cLPU.id)

-'

-'    Set dlg_del = New dlg_LPU_delete

-'    With dlg_del

-'        .chbDeleteQTR.Value = True

-'        .chbDeleteAll.Value = False

-'        .lComment = ent_date & ": Удаление ЛПУ '" _

-'        & cLPU.Name & "', расположенного по адресу:" _

-'        & cLPU.address & " не разрешено."

-'        .Show

-'    End With

-End Sub

-

-Sub btLPU_RET_IT()

-    With Worksheets("LPU_LIST")

-        .setEnt_date ("")

-        .Range("LAST_FOCUS") = ""

-        

-        Wks_select .Range("ret_addr")

-    End With

-

-End Sub

-

-

-Sub btLPU_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim lpu_id As Long

-

-    i = Worksheets(VAR_SHEET).Range("QTR_ACTION").Value

-    With Worksheets("LPU_LIST")

-        ent_date = .getEnt_date()

-

-

-        lpu_id = .getCurrentLPU_ID

-        If lpu_id = 0 And i <> 6 Then

-            i = 1

-        End If

-        Select Case i

-            Case 1

-                .SelectLPU_NAME lpu_id, ent_date

-                .Range("JUMP") = "LPU_BDGT"

-            Case 2

-                .SelectLPU_BDGT lpu_id, ent_date

-                .Range("JUMP") = "LPU_BDGT"

-            Case 3

-                .SelectLPU_HIR lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_HIR"

-

-            Case 4

-                .SelectLPU_TER lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_TER"

-

-            Case 5

-                .SelectLPU_C_ACS lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        End Select

-    End With

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-dbQTR
->>>>>>
-Attribute VB_Name = "dbQTR"

-Option Explicit

-

-Public Type tQTR

-    id As Long

-    entry_date As String

-    rep_id As Long

-    rm_id As Long

-    sale_PLAN As Long

-    ClxnH20mg As Long

-    ClxnH40mg As Long

-    ClxnT40mg As Long

-    ClxnC_IM As Long

-    ClxnC_ACS As Long

-End Type

-

-Function Get_QTR_Record(ByVal QTR_ID As Long, rm_id As Long) As tQTR

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_QTR_Record = dbGet_QTR_Record(dbConnection, QTR_ID, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_Record(dbConnection As Object, ByVal QTR_ID As Long, rm_id As Long) As tQTR

-    

-    Dim sql As String

-    Dim objQTR As tQTR

-    

-    With objQTR

-        .ClxnC_ACS = 0

-        .ClxnC_IM = 0

-        .ClxnH20mg = 0

-        .ClxnH40mg = 0

-        .ClxnT40mg = 0

-        .entry_date = ""

-        .id = QTR_ID

-        .rm_id = rm_id

-    End With

-    

-    sql = "SELECT * FROM quarter WHERE id=" & QTR_ID & " AND rm_id=" & rm_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objQTR.entry_date = dbRecordset("entry_date")

-        objQTR.rep_id = dbRecordset("rep_id")

-        objQTR.rm_id = dbRecordset("rm_id")

-        objQTR.sale_PLAN = dbRecordset("sale_plan")

-        objQTR.ClxnH20mg = dbRecordset("ClxnH20mg")

-        objQTR.ClxnH40mg = dbRecordset("ClxnH40mg")

-        objQTR.ClxnT40mg = dbRecordset("ClxnT40mg")

-        objQTR.ClxnC_IM = dbRecordset("ClxnC_IM")

-        objQTR.ClxnC_ACS = dbRecordset("ClxnC_ACS")

-        objQTR.id = dbRecordset("id")

-    End If

-    

-    dbGet_QTR_Record = objQTR

-

-End Function

-

-

-Function Get_QTR_Record_by_REP(ent_date As String, rep_id As Long, rm_id As Long) As tQTR

-    Dim dbConnection As Object

-    Dim allQTR() As tQTR

-    Dim i As Long

-

-    dbOpenConnection dbConnection

-

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id, rm_id)

-    If i <> 0 Then

-        Get_QTR_Record_by_REP = allQTR(1)

-    End If

-

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTR_Records_by_REP(ByRef all_QTR() As tQTR, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-

-    GetAll_QTR_Records_by_REP = dbGetAll_QTR_Records_By_REP(dbConnection, all_QTR, ent_date, rep_id, rm_id)

-

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGetAll_QTR_Records_By_REP(dbConnection As Object, all_QTR() As tQTR, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-

-    Dim getCount_QTR_SQL As String

-    Dim getAll_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    Dim rep_sql As String

-    Dim rm_sql As String

-    

-    rep_sql = ""

-    rm_sql = ""

-    

-    If rep_id <> 0 Then

-        rep_sql = " AND rep_id=" & rep_id

-    End If

-    

-    If rm_id <> 0 Then

-        rm_sql = " AND rm_id=" & rm_id

-    End If

-    

-    

-        getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter " & _

-        "WHERE entry_date like '" & ent_date & "' " & rep_sql & rm_sql

-        getAll_QTR_SQL = "SELECT * FROM quarter " & _

-        "WHERE entry_date like '" & ent_date & "' " & rep_sql & rm_sql & " ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-

-    dbRecordset.Close

-

-    dbGetAll_QTR_Records_By_REP = QTR_Count

-

-    If QTR_Count > 0 Then

-        'we have records

-        ReDim all_QTR(1 To QTR_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTR_SQL, dbConnection

-

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTR As tQTR

-                 With tmp_QTR

-                    .entry_date = dbRecordset("entry_date")

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .ClxnH20mg = dbRecordset("ClxnH20mg")

-                    .ClxnH40mg = dbRecordset("ClxnH40mg")

-                    .ClxnT40mg = dbRecordset("ClxnT40mg")

-                    .ClxnC_IM = dbRecordset("ClxnC_IM")

-                    .ClxnC_ACS = dbRecordset("ClxnC_ACS")

-                    .id = dbRecordset("id")

-                 End With

-

-                 all_QTR(index) = tmp_QTR

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-cdbQTR
->>>>>>
-Attribute VB_Name = "cdbQTR"

-Option Explicit

-

-Public Type tQTR_COMMON

-    qtr As tQTR

-    i_lcd As Long           ' число ЛПУ в СПИСКЕ

-    lcd() As tLPU_COMMON    ' список ЛПУ

-    c_beds As Long          ' сумма коек

-    c_bdgt_NFG As Long      ' общий бюджет на НФГ

-    c_bdgt_NMG As Long      ' общий бюджет на НМГ

-    c_bdgt_LPU As Long      ' общий бюджет на гепарины

-    c_sale_PLAN As Long     ' план продаж репа

-    c_sale_ALL As Long      ' продажи

-    c_sale_HIR As Long      ' в хирургии

-    c_sale_TER  As Long     ' в терапии

-    c_sale_CRD  As Long     ' в кардиологии

-    c_pat_HIR   As Long     ' пациенты

-    c_pat_TER   As Long     '

-    c_pat_CRD   As Long     '

-    c_pat_ALL   As Long     '

-    c_pat_LPU   As Long     ' Всего операций

-End Type

-

-Function Get_QTR_CommonList_by_REP(ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long, rm_id As Long) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_QTR_CommonList_by_REP = dbGet_QTR_CommonList_by_REP(dbConnection, qcd, ent_date, rep_id, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_CommonList_by_REP(dbConnection As Object, ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long, rm_id As Long) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim allQTR() As tQTR

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id, rm_id)

-    dbGet_QTR_CommonList_by_REP = i

-    If i > 0 Then

-        ReDim qcd(i)

-        For i = 1 To UBound(allQTR)

-            With qcd(i)

-                .qtr = allQTR(i)

-                .c_beds = 0

-                .c_bdgt_NFG = 0

-                .c_bdgt_NMG = 0

-                .c_bdgt_LPU = 0

-                .c_sale_PLAN = 0

-                .c_pat_HIR = 0

-                .c_pat_TER = 0

-                .c_pat_CRD = 0

-                .c_pat_ALL = 0

-                .c_sale_HIR = 0

-                .c_sale_TER = 0

-                .c_sale_CRD = 0

-                .c_sale_ALL = 0

-                .c_pat_LPU = 0

-                

-                j = dbGet_LPU_CommonQTR(dbConnection, .lcd, .qtr)

-                .i_lcd = j

-                If j > 0 Then

-                    For j = 1 To UBound(.lcd)

-                        .c_beds = .c_beds + .lcd(j).lpu.beds

-                        .c_bdgt_NFG = .c_bdgt_NFG + .lcd(j).bdgt.bdgt_NFG

-                        .c_bdgt_NMG = .c_bdgt_NMG + .lcd(j).bdgt.bdgt_NMG

-                        .c_bdgt_LPU = .c_bdgt_LPU + .lcd(j).bdgt_LPU

-                        .c_sale_PLAN = .c_sale_PLAN + .lcd(j).bdgt.sale_PLAN

-                        .c_pat_HIR = .c_pat_HIR + .lcd(j).pat_HIR

-                        .c_pat_TER = .c_pat_TER + .lcd(j).pat_TER

-                        .c_pat_CRD = .c_pat_CRD + .lcd(j).pat_CRD

-                        .c_pat_ALL = .c_pat_ALL + .lcd(j).pat_ALL

-                        .c_sale_HIR = .c_sale_HIR + .lcd(j).sale_HIR

-                        .c_sale_TER = .c_sale_TER + .lcd(j).sale_TER

-                        .c_sale_CRD = .c_sale_CRD + .lcd(j).sale_CRD

-                        .c_sale_ALL = .c_sale_ALL + .lcd(j).sale_ALL

-                        .c_pat_LPU = .c_pat_LPU + .lcd(j).pat_LPU

-                    Next j

-                    

-                End If

-            End With

-        Next i

-    End If

-End Function

-

-Function GetLastQtr() As String

-    Dim s As String

-    Dim r As Range

-    Set r = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Do While r.Cells(1, 1) <> ""

-        s = r.Cells(1, 1)

-        Set r = r.Cells.Offset(1, 0)

-    Loop

-    GetLastQtr = s

-End Function

-

-Function GetNextQTR(ent_date As String) As String

-    Dim rd As Range

-    Dim idx As Integer

-    Dim b As Variant

-    Dim dlg As dlg_newQTR

-    Set dlg = New dlg_newQTR

-    

-    If ent_date = "" Then

-        Dim ir As Variant

-        idx = 0

-        dlg.Show

-        b = dlg.Tag

-            

-        If IsNumeric(b) Then

-            GetNextQTR = dlg.cbQTR

-        Else

-            GetNextQTR = ""

-        End If

-    Else

-        Set rd = Worksheets(VAR_SHEET).Range("Date_Lst")

-        idx = WorksheetFunction.Match(ent_date, rd, 0)

-        GetNextQTR = WorksheetFunction.index(rd, idx + 1, 1)

-    End If

-End Function

-<<<<<<
-======================
-mRestView
->>>>>>
-Attribute VB_Name = "mRestView"

-Option Explicit

-

-Sub xlRestoreView()

-Attribute xlRestoreView.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute xlRestoreView.VB_ProcData.VB_Invoke_Func = " \n14"

-    With Application

-        .CommandBars("Standard").Visible = True

-        .CommandBars("Formatting").Visible = True

-        .DisplayFormulaBar = True

-        .DisplayStatusBar = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = True

-    End With

-End Sub

-<<<<<<
-======================
-dlg_newQTR
->>>>>>
-Attribute VB_Name = "dlg_newQTR"

-Attribute VB_Base = "0{92648543-CB84-4B6B-BEB3-539AE7EF9D84}{7E20E3E3-027A-483B-A14D-AA9EA5398ACC}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mDec2TS
->>>>>>
-Attribute VB_Name = "mDec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-CHRT_LPU_BBL
->>>>>>
-Attribute VB_Name = "CHRT_LPU_BBL"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    Unprotect

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Потенциал рынка: " & Range("title")

-    Range("view_key") = False

-    ChangeLabels

-    Range("A1").Select

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Unprotect

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub BCLabelChng_Click()

-    Unprotect

-    If Range("view_key") Then

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать названия"

-    Else

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать объемы"

-    End If

-    Range("view_key") = Not Range("view_key")

-    ChangeLabels

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub ChangeLabels()

-    Dim i As Integer

-    Dim offset_text As Integer

-    Dim src As Range

-    Set src = Range("CHRT_BBL_DATA")

-    

-    offset_text = 3

-    If Range("view_key") Then

-        offset_text = 4

-    End If

-    

-    With ChartObjects(1).Chart

-        With .SeriesCollection(1)

-            For i = 1 To .Points.count

-                On Error GoTo ExitLabel

-                .Points(i).DataLabel.Characters.Text = Format(src.Cells(i, offset_text))

-            Next i

-        End With

-    End With

-ExitLabel:

-End Sub

-<<<<<<
-======================
-CHRT_PAT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PAT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Пациенты на Клексане(чел.): " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-<<<<<<
-======================
-CHRT_PAT_LPU
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Пациенты на Клексане(%): " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_nextQTR
->>>>>>
-Attribute VB_Name = "dlg_nextQTR"

-Attribute VB_Base = "0{067FED69-B41E-427D-AF59-5798B8E2E73A}{4C13CAB1-FDCC-4708-89EB-E92EDC125712}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-cdbLPU
->>>>>>
-Attribute VB_Name = "cdbLPU"

-Option Explicit

-

-Public Type tLPU_COMMON

-    lpu As tLPU

-    bdgt As tBUDGET

-    i_hir As Long

-    hir() As tHIRURGIA

-    i_ter As Long

-    ter() As tTERAPIA

-    i_ACS As Long

-    ACS() As tACS

-    bdgt_LPU As Long

-    sale_HIR As Long

-    sale_TER As Long

-    sale_CRD As Long

-    sale_ALL As Long

-    pat_HIR As Long

-    pat_TER As Long

-    pat_CRD As Long

-    pat_ALL As Long     ' Сумма всех пациентов на клексане

-    pat_LPU As Long     ' Число потенциальных пациентов для продаж клексана

-End Type

-

-Function Get_LPU_CommonQTR(ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    Get_LPU_CommonQTR = dbGet_LPU_CommonQTR(dbConnection, lcd, objQTR)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_CommonQTR(dbConnection As Object, ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    i = dbGetAll_LPU_byQTR(dbConnection, allLPU, objQTR.entry_date, objQTR.rep_id, objQTR.rm_id)

-    dbGet_LPU_CommonQTR = i

-    If i > 0 Then

-        ReDim lcd(i)

-        For i = 1 To UBound(allLPU)

-            dbGet_LPU_Common dbConnection, lcd(i), allLPU(i), objQTR

-        Next i

-    End If

-End Function

-

-Sub Get_LPU_Common(ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    dbGet_LPU_Common dbConnection, lcd, cLPU, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbGet_LPU_Common(dbConnection As Object, ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-

-    lcd.lpu = cLPU

-    lcd.bdgt = dbGet_BDGT_Record(dbConnection, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    lcd.i_hir = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, lcd.hir, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    lcd.i_ter = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, lcd.ter, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    lcd.i_ACS = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, lcd.ACS, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    With lcd

-        .bdgt_LPU = .bdgt.bdgt_NFG + .bdgt.bdgt_NMG

-        .pat_LPU = 0

-        If .i_hir > 0 Then

-            .pat_HIR = .hir(1).patients_ambulator_clexan + .hir(1).patients_stationar_clexan

-            .sale_HIR = objQTR.ClxnH20mg * (.hir(1).patients_ambulator_clexan_20mg + .hir(1).patients_stationar_clexan_20mg)

-            .sale_HIR = .sale_HIR + objQTR.ClxnH40mg * (.hir(1).patients_ambulator_clexan_40mg + .hir(1).patients_stationar_clexan_40mg)

-            .pat_LPU = .pat_LPU + .hir(1).operations_per_quarter

-        End If

-        If .i_ter > 0 Then

-            .pat_TER = .ter(1).patients_ambulator_clexan + .ter(1).patients_stationar_clexan

-            .sale_TER = .pat_TER * objQTR.ClxnT40mg

-            .pat_LPU = .pat_LPU + .ter(1).patients_per_quarter

-        End If

-        If .i_ACS > 0 Then

-            .pat_CRD = .ACS(1).patients_stationar_clexan

-            .sale_CRD = .pat_CRD * objQTR.ClxnC_ACS

-            .pat_LPU = .pat_LPU + .ACS(1).patients_per_quarter

-        End If

-        .pat_ALL = .pat_HIR + .pat_TER + .pat_CRD

-        .sale_ALL = .sale_HIR + .sale_TER + .sale_CRD

-    End With

-End Sub

-

-<<<<<<
-======================
-CHRT_PIE
->>>>>>
-Attribute VB_Name = "CHRT_PIE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Unprotect

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Доля продаж: " & Range("title")

-    

-    On Error Resume Next

-    Range("P5:Q24").Sort _

-        Key1:=Range("Q5"), _

-        Order1:=xlDescending, _

-        Header:=xlGuess, _

-        OrderCustom:=1, _

-        MatchCase:=False, _

-        Orientation:=xlTopToBottom

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PLN_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PLN_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Динамика продаж: " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_BDGT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_BDGT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Бюджеты ЛПУ: " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-dlg_LPU_delete
->>>>>>
-Attribute VB_Name = "dlg_LPU_delete"

-Attribute VB_Base = "0{9C81F4D2-4ECF-46F5-999B-9801D572A12F}{B382508B-7F3D-4747-8407-0F75F6F265F5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlg_Mail
->>>>>>
-Attribute VB_Name = "dlg_Mail"

-Attribute VB_Base = "0{EA8CE4CE-AC2E-45BC-BAF8-1429E6242097}{575F0762-04F4-4F86-B98A-8E87E3424B0D}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dbREP_id
->>>>>>
-Attribute VB_Name = "dbREP_id"

-Public Type tREPID

-    rep_id As Long

-    rm_id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function GetAll_REPID_Records_by_QTR(ByRef all_REPID() As tREPID, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_REPID_Records_by_QTR = dbGetAll_REPID_Records_by_QTR(dbConnection, all_REPID, ent_date, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function Get_REPID_Record(rep_id As Long, rm_id As Long) As tREPID

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REPID_Record = dbGet_REPID_Record(dbConnection, rep_id, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_REPID_Records(ByRef all_REPID() As tREPID) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_REPID_Records = dbGetAll_REPID_Records(dbConnection, all_REPID)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function dbGet_REPID_Record(dbConnection As Object, rep_id As Long, rm_id As Long) As tREPID

-    

-    Dim sql As String

-    Dim objREPID As tREPID

-    

-    objREPID.FirstName = ""

-    objREPID.LastName = ""

-    objREPID.Region = 0

-    objREPID.City = 0

-    sql = "SELECT * FROM " & _

-          "rep WHERE rep_id=" & rep_id & " AND rm_id=" & rm_id

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREPID.rep_id = dbRecordset("rep_id")

-        objREPID.rm_id = dbRecordset("rm_id")

-        objREPID.FirstName = dbRecordset("firstname")

-        objREPID.LastName = dbRecordset("lastname")

-        objREPID.Region = dbRecordset("region")

-        objREPID.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REPID_Record = objREPID

-        

-End Function

-

-Function dbGetAll_REPID_Records_by_QTR(dbConnection As Object, ByRef all_REPID() As tREPID, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    Dim Where As String

-    

-    REPID_Count = 0

-    

-    Where = " WHERE lpu_budget.entry_date like '" & ent_date & "' " & _

-        "AND rep.rep_id=lpu.rep_id AND lpu.id=lpu_budget.lpu_id"

-    If rm_id <> 0 Then

-        Where = Where & " AND rep.rm_id=" & rm_id

-    End If

-    

-    getAll_REPID_SQL = "SELECT distinct rep.* FROM rep, lpu, lpu_budget" & Where

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM (" & getAll_REPID_SQL & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records_by_QTR = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Function dbGetAll_REPID_Records(dbConnection As Object, ByRef all_REPID() As tREPID) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    REPID_Count = 0

-    

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM rep"

-    getAll_REPID_SQL = "SELECT * FROM rep"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-cdbExport
->>>>>>
-Attribute VB_Name = "cdbExport"

-Option Explicit

-

-Function GetDBSN() As String

-    Dim n As Long

-    Randomize Timer

-    n = Int((100000000 - 1000000 + 1) * Rnd + 1000000)

-    GetDBSN = Dec2ThirtySix(n)

-End Function

-

-Sub dbExport()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim old_file As String

-    

-    On Error GoTo ErrHandler

-    

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    old_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & "*.*"

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & GetDBSN() & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.DeleteFile old_file, True

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Данные экспортированы в файл:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для передачи", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-Exit Sub

-

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-<<<<<<
-======================
-mRegs
->>>>>>
-Attribute VB_Name = "mRegs"

-Option Explicit

-

-Function GetRegionName(idx As Integer) As String

-    GetRegionName = Worksheets(REGS_SHEET).Range("LST_REGIONS").Cells(idx + 1, 1).Text

-End Function

-

-Function GetCityName(idx_reg As Integer, idx_city As Integer) As String

-    GetCityName = Worksheets(REGS_SHEET).Range("CITY_TABLES").Offset(idx_city + 1, idx_reg * 2).Text

-End Function

-

-Sub testReg()

-    Dim r As Integer

-    Dim c As Integer

-    Dim s As String

-    

-    r = 3

-    c = 3

-    s = GetRegionName(r)

-    s = s & ", " & GetCityName(r, c)

-    MsgBox s

-End Sub

-

-<<<<<<
-======================
-RM_QTR
->>>>>>
-Attribute VB_Name = "RM_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CRGN_QT As Integer = 0

-Const CRGN_PLN As Integer = 2

-Const CRGN_FCT As Integer = 3

-Const CRGN_BDG As Integer = 4

-Const CRGN_LPU As Integer = 5

-Const CRGN_REP As Integer = 6

-Const CRGN_HIR As Integer = 7

-Const CRGN_TER As Integer = 8

-Const CRGN_CRD As Integer = 9

-Const CRGN_CLXN_BDG As Integer = 10

-Const CRGN_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Const LOCAL_ENT_DATE As String = "B11"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("RM_QTR")

-        s = .Range("D5") & " " & .Range("D4") & ", " & .Range("H4") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub update_history()

-    Dim objRGN() As tREGION

-    Dim i As Long

-    Dim r As Range

-    Dim cRMan As tREGMAN

-

-    cRMan = Get_REGMAN_Record(Range("RM_ID"))

-    

-    Range("D4") = cRMan.LastName

-    Range("D5") = cRMan.FirstName

-

-    Range("H4") = GetRegionName(cRMan.Region)

-    

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetRGN_COMM_DATA(objRGN, Range("RM_ID"))

-    

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objRGN)

-            r.Offset(i - 1, CRGN_QT) = objRGN(i).ent_date

-            r.Offset(i - 1, CRGN_FCT) = objRGN(i).total_SALE

-            r.Offset(i - 1, CRGN_PLN) = objRGN(i).sale_PLAN

-            r.Offset(i - 1, CRGN_BDG) = objRGN(i).total_BDGT

-            r.Offset(i - 1, CRGN_LPU) = objRGN(i).total_LPU

-            r.Offset(i - 1, CRGN_REP) = objRGN(i).total_REP

-            r.Offset(i - 1, CRGN_HIR) = objRGN(i).total_HIR

-            r.Offset(i - 1, CRGN_TER) = objRGN(i).total_TER

-            r.Offset(i - 1, CRGN_CRD) = objRGN(i).total_ACS

-            If objRGN(i).total_BDGT <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_BDG) = objRGN(i).total_SALE / objRGN(i).total_BDGT

-            End If

-            If objRGN(i).total_BDGT_NMG <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_NMG) = objRGN(i).total_SALE / objRGN(i).total_BDGT_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRGN_CRD + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-

-Sub Draw_PLN_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_FCT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PLN_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Draw_BDGT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_CLXN_NMG + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_BDGT_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Public Sub cbxRM_QtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR_RM

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR_RM

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR_RM

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = RM_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CRGN_QT + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    If r = "" Then

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = currRange.address

-    End If

-    Cancel = True

-    btRM_QTR_Do_IT

-End Sub

-

-<<<<<<
-======================
-dbREG_MAN
->>>>>>
-Attribute VB_Name = "dbREG_MAN"

-Option Explicit

-

-Public Type tREGMAN

-    rm_id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function Get_REGMAN_Record(rm_id As Long) As tREGMAN

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REGMAN_Record = dbGet_REGMAN_Record(dbConnection, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Sub Set_REGMAN_Record(cREGMAN As tREGMAN)

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbSet_REGMAN_Record dbConnection, cREGMAN

-'    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_REGMAN_Record(dbConnection As Object, rm_id As Long) As tREGMAN

-    

-    Dim sql As String

-    Dim objREGMAN As tREGMAN

-    

-    objREGMAN.FirstName = ""

-    objREGMAN.LastName = ""

-    objREGMAN.Region = 0

-    objREGMAN.City = 0

-    objREGMAN.rm_id = rm_id

-    sql = "SELECT * FROM " & _

-          "reg_man WHERE mgr_id=" & rm_id

-          

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREGMAN.FirstName = dbRecordset("firstname")

-        objREGMAN.LastName = dbRecordset("lastname")

-        objREGMAN.Region = dbRecordset("region")

-        objREGMAN.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REGMAN_Record = objREGMAN

-        

-End Function

-

-Public Sub dbSet_REGMAN_Record(dbConnection As Object, ByRef objREGMAN As tREGMAN)

-  

-'    Dim DeleteSQL As String

-'    Dim InsertSQL As String

-'

-'    DeleteSQL = "DELETE FROM reg_man"

-'    InsertSQL = "INSERT INTO reg_man (firstname, lastname, region, city) VALUES (" & _

-'    "'" & objREGMAN.FirstName & "', " & _

-'    "'" & objREGMAN.LastName & "', " & _

-'    objREGMAN.Region & ", " & _

-'    objREGMAN.City & ")"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-       

-End Sub

-

-

-

-<<<<<<
-======================
-dbDatabaseMerge
->>>>>>
-Attribute VB_Name = "dbDatabaseMerge"

-Option Explicit

-

-Public Type tDBFIELD

-    Name As String

-End Type

-

-Public Type tDBTABLE

-    Name As String

-    field() As tDBFIELD

-End Type

-

-

-Function dbGetConnection(dbAccessFileFullPath As String) As Object

-    Dim dbConnection As Object

-    Dim dbAccessFilePasswd As String

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFileFullPath & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    Set dbGetConnection = dbConnection

-End Function

-

-Sub dbCloseOpenedConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteOpenedSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-Function dbMergeREP(from_dbConnection As Object, to_dbConnection As Object) As Long

-

-    Dim getRecordset As Object

-    Dim getREPData_SQL As String

-    Dim REP_fn As String

-    Dim REP_ln As String

-    Dim REP_region As String

-    Dim REP_city As String

-

-

-    getREPData_SQL = "SELECT * FROM rep"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getREPData_SQL, from_dbConnection

-        

-        If Not getRecordset.BOF Then

-            REP_fn = getRecordset("firstname")

-            REP_ln = getRecordset("lastname")

-            REP_city = getRecordset("city")

-            REP_region = getRecordset("region")

-        Else

-            MsgBox "There is no information about rep! This database cannot be merged!!!"

-            dbMergeREP = -1

-            Exit Function

-        End If

-    

-    Dim insertRecordset As Object

-    Set insertRecordset = CreateObject("ADODB.Recordset")

-        

-    insertRecordset.Open "rep", to_dbConnection, 2, 2

-    insertRecordset.addnew

-        

-    insertRecordset("firstname") = REP_fn

-    insertRecordset("lastname") = REP_ln

-    insertRecordset("region") = REP_region

-    insertRecordset("city") = REP_city

-    insertRecordset.Update

-    insertRecordset.MoveLast

-    'new ID

-    

-    dbMergeREP = insertRecordset("rep_id")

-    

-End Function

-

-Sub dbMergeLPU(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getLPU_SQL As String

-    Dim getRecordset As Object

-    Dim idx As Long

-    idx = 1

-    

-    getLPU_SQL = "SELECT * FROM lpu"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getLPU_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            ReDim Preserve objLPU(1 To idx)

-            objLPU(idx).old_lpu_id = getRecordset("id")

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "lpu", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("name") = getRecordset("name")

-            insRS("address") = getRecordset("address")

-            insRS("beds") = getRecordset("beds")

-            insRS.Update

-            insRS.MoveLast

-            'new ID

-            

-            objLPU(idx).new_lpu_id = insRS("id")

-                        

-            idx = idx + 1

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about LPU! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-

-Sub dbMergeLPURelated(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object)

-

-    ' 6 tables to change

-    Dim tables(1 To 5) As tDBTABLE

-    

-    'lpu budget

-    tables(1).Name = "lpu_budget"

-    ReDim tables(1).field(1 To 4)

-    

-    tables(1).field(1).Name = "entry_date"

-    tables(1).field(2).Name = "bdgt_NMG"

-    tables(1).field(3).Name = "bdgt_NFG"

-    tables(1).field(4).Name = "sale_PLAN"

-    

-    'lpu hir

-    tables(2).Name = "lpu_hir"

-    ReDim tables(2).field(1 To 13)

-    

-    tables(2).field(1).Name = "entry_date"

-    tables(2).field(2).Name = "operations_per_quarter"

-    tables(2).field(3).Name = "risk_percent"

-    tables(2).field(4).Name = "patients_with_risk_ON"

-    tables(2).field(5).Name = "patients_ambulator"

-    tables(2).field(6).Name = "patients_ambulator_nmg"

-    tables(2).field(7).Name = "patients_ambulator_clexan"

-    tables(2).field(8).Name = "patients_ambulator_clexan_40mg"

-    tables(2).field(9).Name = "patients_ambulator_clexan_20mg"

-    tables(2).field(10).Name = "patients_stationar_nmg"

-    tables(2).field(11).Name = "patients_stationar_clexan"

-    tables(2).field(12).Name = "patients_stationar_clexan_40mg"

-    tables(2).field(13).Name = "patients_stationar_clexan_20mg"

-    

-    

-    'lpu acs

-    tables(3).Name = "lpu_acs"

-    ReDim tables(3).field(1 To 5)

-    

-    tables(3).field(1).Name = "entry_date"

-    tables(3).field(2).Name = "patients_with_geparins"

-    tables(3).field(3).Name = "patients_per_quarter"

-    tables(3).field(4).Name = "patients_stationar_nmg"

-    tables(3).field(5).Name = "patients_stationar_clexan"

-    

-    'lpu acs

-    tables(4).Name = "lpu_im"

-    ReDim tables(4).field(1 To 5)

-    

-    tables(4).field(1).Name = "entry_date"

-    tables(4).field(2).Name = "patients_with_geparins"

-    tables(4).field(3).Name = "patients_per_quarter"

-    tables(4).field(4).Name = "patients_stationar_nmg"

-    tables(4).field(5).Name = "patients_stationar_clexan"

-    

-    

-    'lpu acs

-    tables(5).Name = "lpu_ter"

-    ReDim tables(5).field(1 To 9)

-    

-    tables(5).field(1).Name = "entry_date"

-    tables(5).field(2).Name = "patients_per_quarter"

-    tables(5).field(3).Name = "risk_percent"

-    tables(5).field(4).Name = "patients_with_risk_ON"

-    tables(5).field(5).Name = "patients_ambulator"

-    tables(5).field(6).Name = "patients_ambulator_nmg"

-    tables(5).field(7).Name = "patients_ambulator_clexan"

-    tables(5).field(8).Name = "patients_stationar_nmg"

-    tables(5).field(9).Name = "patients_stationar_clexan"

-    

-    

-    

-    Dim tbl_idx As Integer

-    

-    For tbl_idx = 1 To UBound(tables)

-        

-        Dim getSQL As String

-        Dim getRS As Object

-        

-        

-        

-        Set getRS = CreateObject("ADODB.Recordset")

-        

-        getSQL = "SELECT * FROM " & tables(tbl_idx).Name

-        getRS.Open getSQL, from_db

-        

-        If Not getRS.BOF Then

-            Do While Not getRS.EOF

-                Dim insRS As Object

-                Set insRS = CreateObject("ADODB.Recordset")

-                

-                insRS.Open tables(tbl_idx).Name, to_db, 2, 2

-                insRS.addnew

-                Dim fld_idx As Integer

-    

-                    For fld_idx = 1 To UBound(tables(tbl_idx).field)

-                        insRS(tables(tbl_idx).field(fld_idx).Name) = getRS(tables(tbl_idx).field(fld_idx).Name)

-                        insRS("lpu_id") = findNewLPU_IDByOld(objLPU, getRS("lpu_id"))

-                    Next fld_idx

-                    

-                insRS.Update

-                insRS.MoveLast

-                getRS.MoveNext

-            Loop

-        End If

-        

-        

-    Next tbl_idx

-

-End Sub

-

-Function findNewLPU_IDByOld(objLPU() As tLPUCONVERTION, old_id As Long)

-

-Dim i As Integer

-For i = 1 To UBound(objLPU)

-    If objLPU(i).old_lpu_id = old_id Then

-        findNewLPU_IDByOld = objLPU(i).new_lpu_id

-        Exit Function

-    End If

-Next i

-

-findNewLPU_IDByOld = -1

-End Function

-

-

-

-

-

-Sub dbMergeQTR(from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getQTR_SQL As String

-    Dim getRecordset As Object

-    

-    getQTR_SQL = "SELECT * FROM quarter"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getQTR_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "quarter", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("entry_date") = getRecordset("entry_date")

-            insRS("sale_plan") = getRecordset("sale_plan")

-            insRS("ClxnH20mg") = getRecordset("ClxnH20mg")

-            insRS("ClxnH40mg") = getRecordset("ClxnH40mg")

-            insRS("ClxnT40mg") = getRecordset("ClxnT40mg")

-            insRS("ClxnC_IM") = getRecordset("ClxnC_IM")

-            insRS("ClxnC_ACS") = getRecordset("ClxnC_ACS")

-            

-            

-            insRS.Update

-            

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about quarter budget! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-dbMerge
->>>>>>
-Attribute VB_Name = "dbMerge"

-Option Explicit

-

-Public Type tLPUCONVERTION

-    old_lpu_id As Long

-    new_lpu_id As Long

-End Type

-

-Sub Merge_BackUp_All_Data()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim time_stump As String

-    

-    On Error GoTo ErrHandler

-    

-    time_stump = Format(Date, "yy-mm-dd_") & Format(Time, "hh-mm")

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_BACKUPNAME & time_stump & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Старые данные сохранены в файле:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для восстанеовления данных в случае утери", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-    Exit Sub

-    

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-

-Sub Merge_Clear_All_Data(access_file_full_path As String)

-    

-    Dim db As Object

-    Dim tables_to_clear() As String

-    On Error GoTo ErrHandler

-    

-    ReDim tables_to_clear(1 To 10)

-    tables_to_clear(1) = "rep"

-    tables_to_clear(2) = "lpu"

-    tables_to_clear(3) = "lpu_budget"

-    tables_to_clear(4) = "lpu_hir"

-    tables_to_clear(5) = "lpu_ter"

-    tables_to_clear(6) = "lpu_acs"

-    tables_to_clear(7) = "lpu_im"

-    tables_to_clear(8) = "quarter"

-    tables_to_clear(9) = "quarter_rm"

-    tables_to_clear(10) = "reg_man"

-    

-    Set db = dbGetConnection(access_file_full_path)

-

-    Dim i As Integer

-    

-    For i = 1 To UBound(tables_to_clear)

-        

-        If tables_to_clear(i) <> "" Then

-            Dim Clear_SQL As String

-            Clear_SQL = "DELETE FROM " & tables_to_clear(i)

-            dbExecuteOpenedSQL db, Clear_SQL

-        Else

-            'do nothing or show message

-        End If

-    Next i

-    

-    dbCloseOpenedConnection db

-    Set db = Nothing

-    

-Exit Sub

-

-ErrHandler:

-    MsgBox "something wrong: " & err.Description

-    Resume Next

-    

-End Sub

-

-Function MergeREP(from_file As String, to_file As String) As Long

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    Dim new_rep_id As Long

-

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    MergeREP = dbMergeREP(db1, db2)

-    'MsgBox "new rep ID is " & new_rep_id

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Function

-

-Sub MergeQTR(from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeQTR db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-

-Sub MergeLPU(objLPU() As tLPUCONVERTION, from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeLPU objLPU, db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-Sub MergeLPURelated(objLPU() As tLPUCONVERTION, from_file As String, to_file As String)

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    dbMergeLPURelated objLPU, db1, db2

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-

-End Sub

-

-Sub MergeGlobal(rep_files() As String, rm_file As String)

-

-    Dim i As Integer

-    'clear output file content

-    Merge_Clear_All_Data rm_file

-    

-    For i = 1 To UBound(rep_files)

-        

-        Dim rep_file As String

-        'setup input and output files

-        rep_file = rep_files(i)

-        

-        Dim new_rep_id As Long

-        ' insert REP data and get new rep_id

-        new_rep_id = MergeREP(rep_file, rm_file)

-        

-        Dim objLPU() As tLPUCONVERTION

-        'insert all LPU using new generated rep_id

-        'and populate objLPU old->new relation object

-        

-        MergeLPU objLPU, rep_file, rm_file, new_rep_id

-        'insert quarter data using new rep_id

-        MergeQTR rep_file, rm_file, new_rep_id

-        

-        

-        ' and.... insert all another data (5 tables excl version and hw)

-        'using objLPU old->new relation object

-        MergeLPURelated objLPU, rep_file, rm_file

-    

-    

-    Next i

-    

-End Sub

-

-Function GetDBList(MyPath() As String, ByRef dblist() As String) As Integer

-    Dim i As Integer

-    Dim MyName, MyMask

-    MyMask = MyPath(0) & MyPath(1) & PROGRAM_DATAEXT

-    i = 0

-    MyName = Dir(MyMask)      ' Retrieve the first entry.

-    Do While MyName <> ""    ' Start the loop.

-        ' Ignore the current directory and the encompassing directory.

-        If MyName <> "." And MyName <> ".." Then

-            ' Use bitwise comparison to make sure MyName is a directory.

-            i = i + 1

-            ReDim Preserve dblist(i)

-            dblist(i) = MyPath(0) & MyName

-        End If

-        MyName = Dir    ' Get next entry.

-    Loop

-    GetDBList = i

-End Function

-

-<<<<<<
-======================
-cdbPRJ
->>>>>>
-Attribute VB_Name = "cdbPRJ"

-Option Explicit

-

-Type tPROJECT

-    total_SALE  As Long ' общий объем продаж

-    total_BDGT  As Long ' бюджет всех ЛПУ

-    total_BDGT_NMG As Long ' бюджет всех ЛПУ на НМГ

-    total_LPU   As Long ' число ЛПУ

-    total_REP   As Long ' число репов

-    total_RM    As Long ' число репов

-    total_BEDS  As Long ' общее число коек

-    total_HIR   As Long '  общее число пациентов на клексане в хирургии

-    total_TER   As Long '  общее число пациентов на клексане в терапии

-    total_ACS   As Long '  общее число пациентов на клексане в кардиологии

-    sale_PLAN   As Long '  план продаж Авентиса

-    objRGN() As tREGION

-End Type

-

-Function GetPRJ_COMM_DATA(ByRef prj_data As tPROJECT) As Integer

-    Dim i As Integer

-    i = GetRGN_COMM_DATA(prj_data.objRGN, 0)

-    GetPRJ_COMM_DATA = i

-    If i > 0 Then

-        With prj_data

-            .sale_PLAN = 0

-            .total_ACS = 0

-            .total_BDGT = 0

-            .total_BDGT_NMG = 0

-            .total_BEDS = 0

-            .total_HIR = 0

-            .total_LPU = 0

-            .total_REP = 0

-            .total_RM = 0

-            .total_SALE = 0

-            .total_TER = 0

-            For i = 1 To UBound(prj_data.objRGN)

-                

-            Next i

-        End With

-    End If

-

-End Function

-

-<<<<<<
-======================
-dbQTR_RM
->>>>>>
-Attribute VB_Name = "dbQTR_RM"

-Option Explicit

-

-Public Type tQTRRM

-    id As Long

-    entry_date As String

-    rm_id As Long

-    sale_PLAN As Long

-End Type

-

-

-Sub Insert_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objQTRRM.id <> 0 Then

-        dbUpdate_QTRRM_Record dbConnection, objQTRRM

-    Else

-        dbInsert_QTRRM_Record dbConnection, objQTRRM

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-Function Get_QTRRM_Record(ent_date As String) As tQTRRM

-    Dim dbConnection As Object

-    Dim allQTRRM() As tQTRRM

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    i = dbGetAll_QTRRM_Records(dbConnection, allQTRRM, ent_date)

-    If i <> 0 Then

-        Get_QTRRM_Record = allQTRRM(1)

-    End If

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTRRM_Records(ByRef all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_QTRRM_Records = dbGetAll_QTRRM_Records(dbConnection, all_QTRRM, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_QTRRM_Record dbConnection, objQTRRM

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objQTRRM.ID <> 0 then updatre else insert

-Sub dbInsert_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "quarter_rm", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objQTRRM

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("sale_plan") = .sale_PLAN

-        dbRecordset("rm_id") = .rm_id

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objQTRRM.id = dbRecordset("id")

-

-End Sub

-

-Sub dbUpdate_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim Update_SQL As String

-    

-    With objQTRRM

-        Update_SQL = "UPDATE quarter_rm SET " & _

-            "entry_date='" & .entry_date & "'" & "," & _

-            "rm_id=" & .rm_id & "," & _

-            "sale_plan=" & .sale_PLAN & "," & _

-            " WHERE id=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if ent_date = % then all_records

-Function dbGetAll_QTRRM_Records(dbConnection As Object, all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    

-    Dim getCount_QTRRM_SQL As String

-    Dim getAll_QTRRM_SQL As String

-    Dim QTRRM_Count As Long

-    QTRRM_Count = 0

-    

-    getCount_QTRRM_SQL = "SELECT COUNT(*) AS QTRRM_TOTAL FROM quarter_rm WHERE entry_date like '" & ent_date & "'"

-    getAll_QTRRM_SQL = "SELECT * FROM quarter_rm WHERE entry_date like '" & ent_date & "' ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTRRM_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTRRM_Count = dbRecordset("QTRRM_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_QTRRM_Records = QTRRM_Count

-    

-    If QTRRM_Count > 0 Then

-        'we have records

-        ReDim all_QTRRM(1 To QTRRM_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTRRM_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTRRM As tQTRRM

-                 With tmp_QTRRM

-                    .entry_date = dbRecordset("entry_date")

-                    .rm_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .id = dbRecordset("id")

-                 End With

-                 

-                 all_QTRRM(index) = tmp_QTRRM

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM quarter_rm " & _

-    "WHERE id=" & objQTRRM.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-    

-    'delete related budget entries

-    MsgBox "remember delete related"

-'    dbDelete_BDGT_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Hir_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Ter_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_ACS_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-       

-End Sub

-

-

-<<<<<<
-======================
-REP_LIST
->>>>>>
-Attribute VB_Name = "REP_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Const LOCAL_ENT_DATE As String = "C10"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-

-Public Function getCurrentREP_ID() As Long

-    Dim r As Range

-

-    With Worksheets("REP_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CREP_ID)

-    End With

-

-    getCurrentREP_ID = r

-End Function

-

-Public Sub REP_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Rep_Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Rep_Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Rep_Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Rep_Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectREP_LPU(rep_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    Range("JUMP") = "LPU_LIST"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-        .Range("RM_ID") = rm_id

-        .setEnt_date (getEnt_date())

-    End With

-End Sub

-

-Public Sub SelectREP_QTR(rep_id As Long)

-    Dim vo As Boolean

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    Range("JUMP") = "REP_QTR"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("REP_QTR")

-        .Range("VIEW_ONLY") = vo

-        .Range("RM_ID") = rm_id

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateREPList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim rep_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CREP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CREP_AREA).row, CREP_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    rep_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CREP_AREA).Column

-    

-    If i < 4 Then

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 1

-    Else

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 2

-    End If

-    

-    If rep_id = 0 Then

-        Range("LAST_FOCUS") = Range(CREP_AREA).address

-    End If

-

-    If rep_id = 0 Then

-        i = CREP_NAME

-        Range("JUMP") = ""

-    Else

-        btREP_LIST_DO_IT

-    End If

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateREPList()

-    Dim rcd() As tREPID_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-

-    ent_date = getEnt_date

-

-    Dim rm_struc As tREGMAN

-    

-    i = Range("RM_ID")

-    rm_struc = Get_REGMAN_Record(i)

-    

-    Range("C4") = rm_struc.LastName

-    Range("C5") = rm_struc.FirstName

-

-    Range("G5") = GetRegionName(rm_struc.Region)

-    

-    i = Get_REP_CommonList_by_QTR(rcd, ent_date, Range("RM_ID"))

-

-    

-    With ThisWorkbook.Worksheets("REP_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(rcd)

-            r.Offset(i - 1, CREP_NAME) = rcd(i).rep.FirstName & " " & rcd(i).rep.LastName

-            r.Offset(i - 1, CREP_ID) = rcd(i).rep.rep_id

-            r.Offset(i - 1, CREP_BEDS) = rcd(i).qtrs(1).c_beds

-

-            r.Offset(i - 1, CREP_NFG) = rcd(i).qtrs(1).c_bdgt_NFG

-            r.Offset(i - 1, CREP_NMG) = rcd(i).qtrs(1).c_bdgt_NMG

-

-            r.Offset(i - 1, CREP_PLAN) = rcd(i).qtrs(1).qtr.sale_PLAN

-

-            r.Offset(i - 1, CREP_HIR) = rcd(i).qtrs(1).c_pat_HIR

-            r.Offset(i - 1, CREP_TER) = rcd(i).qtrs(1).c_pat_TER

-            r.Offset(i - 1, CREP_CAR) = rcd(i).qtrs(1).c_pat_CRD

-            r.Offset(i - 1, CREP_FACT) = rcd(i).qtrs(1).c_sale_ALL

-            r.Offset(i - 1, CREP_PAT_LPU) = rcd(i).qtrs(1).c_pat_LPU

-            r.Offset(i - 1, CREP_BDGT) = rcd(i).qtrs(1).c_bdgt_LPU

-            If rcd(i).qtrs(1).c_bdgt_LPU > 0 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = rcd(i).qtrs(1).c_sale_ALL / rcd(i).qtrs(1).c_bdgt_LPU

-            End If

-            If r.Offset(i - 1, CREP_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-

-

-<<<<<<
-======================
-mREP_LIST
->>>>>>
-Attribute VB_Name = "mREP_LIST"

-Option Explicit

-

-Public Const CREP_AREA As String = "B12"

-Public Const CREP_NAME As Integer = 0

-Public Const CREP_NAME1 As Integer = 1

-Public Const CREP_NAME2 As Integer = 2

-Public Const CREP_ID As Integer = 3

-Public Const CREP_BEDS As Integer = 4

-Public Const CREP_NFG As Integer = 5

-Public Const CREP_NMG As Integer = 6

-Public Const CREP_HIR As Integer = 7

-Public Const CREP_TER As Integer = 8

-Public Const CREP_CAR As Integer = 9

-Public Const CREP_FACT As Integer = 10

-Public Const CREP_PLAN As Integer = 11

-Public Const CREP_PAT_LPU As Integer = 16

-Public Const CREP_BDGT As Integer = 17

-

-

-Const LOCAL_ENT_DATE As String = "C10"

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Sub EditREP(cRep As tREPID, ent_date As String)

-    NoFunc

-End Sub

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("REP_LIST")

-        s = .Range("C5") & " " & .Range("C4") & ", " & .Range("G5") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub Rep_Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_LPU_BBL").Range("title") = MakeChartTitle

-End Sub

-

-Sub Rep_Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CREP_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CREP_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CREP_FACT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PIE").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rep_Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CREP_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CREP_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CREP_HIR + 1)

-            psum = psum + src.Cells(i, CREP_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CREP_TER + 1)

-            psum = psum + src.Cells(i, CREP_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CREP_CAR + 1)

-            psum = psum + src.Cells(i, CREP_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CREP_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rep_Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CREP_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CREP_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CREP_HIR + 1)

-            psum = psum + src.Cells(i, CREP_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CREP_TER + 1)

-            psum = psum + src.Cells(i, CREP_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CREP_CAR + 1)

-            psum = psum + src.Cells(i, CREP_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CREP_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU_A").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub btREP_RET_IT()

-    With Worksheets("REP_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = "RM_QTR"

-    End With

-    Dim str As String

-    str = Range("ret_addr")

-    ThisWorkbook.Worksheets(str).Activate

-End Sub

-

-

-Sub btREP_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim rep_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("REP_LST_DETALS")

-    With Worksheets("REP_LIST")

-        rep_id = .getCurrentREP_ID

-        

-        Select Case i

-            Case 1:

-                .SelectREP_QTR rep_id

-            Case 2:

-                ent_date = .getEnt_date()

-                .SelectREP_LPU rep_id, ent_date

-        End Select

-    End With

-    

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-

-

-

-<<<<<<
-======================
-cdbREP
->>>>>>
-Attribute VB_Name = "cdbREP"

-Option Explicit

-

-Public Type tREPID_COMMON

-    rep As tREPID

-    i_qtrs As Integer

-    qtrs() As tQTR_COMMON

-End Type

-

-Function Get_REP_CommonList_by_QTR(ByRef rcd() As tREPID_COMMON, ent_date As String, rm_id As Long) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_REP_CommonList_by_QTR = dbGet_REP_CommonList_by_QTR(dbConnection, rcd, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_REP_CommonList_by_QTR(dbConnection As Object, ByRef rcd() As tREPID_COMMON, ent_date As String, rm_id As Long) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim k As Long

-    Dim allREPID() As tREPID

-    

-    i = dbGetAll_REPID_Records_by_QTR(dbConnection, allREPID, ent_date, rm_id)

-    dbGet_REP_CommonList_by_QTR = i

-    If i > 0 Then

-        ReDim rcd(i)

-        For i = 1 To UBound(allREPID)

-            rcd(i).rep = allREPID(i)

-            rcd(i).i_qtrs = Get_QTR_CommonList_by_REP(rcd(i).qtrs, ent_date, allREPID(i).rep_id, allREPID(i).rm_id)

-        Next i

-    End If

-End Function

-

-

-

-<<<<<<
-======================
-CHRT_PAT_LPU_A
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU_A"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Пациенты на Клексане(чел.): " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-cdbRegion
->>>>>>
-Attribute VB_Name = "cdbRegion"

-Option Explicit

-

-Type tREGION

-    ent_date As String

-    rm_id As Long

-    total_SALE As Long ' общий объем продаж

-    total_BDGT As Long ' бюджет всех ЛПУ

-    total_BDGT_NMG As Long ' бюджет всех ЛПУ на НМГ

-    total_LPU As Long ' число ЛПУ

-    total_REP   As Long ' число репов

-    total_BEDS As Long ' общее число коек

-    total_HIR As Long '  общее число пациентов на клексане в хирургии

-    total_TER As Long '  общее число пациентов на клексане в терапии

-    total_ACS As Long '  общее число пациентов на клексане в кардиологии

-    sale_PLAN As Long '  план продаж Авентиса

-End Type

-

-Function GetRGN_COMM_DATA(ByRef reg_data() As tREGION, rm_id As Long) As Integer

-    Dim q_date() As String

-    Dim q_count As Integer, i As Integer

-    

-    q_count = getAllQTRNames(q_date, rm_id)

-    If q_count > 0 Then

-        ReDim reg_data(q_count)

-        For i = 1 To q_count

-            Dim current_REP_count As Integer

-            reg_data(i).rm_id = rm_id

-            reg_data(i).ent_date = q_date(i)

-            current_REP_count = getREGION_by_QTR(q_date(i), reg_data(i), rm_id)

-        Next i

-    End If

-    

-    GetRGN_COMM_DATA = q_count

-End Function

-

-' if rm_id = 0 then gets all records

-Function getAllQTRNames(ByRef qtr_lst() As String, rm_id As Long) As Integer

-    

-    Dim sql As String

-    Dim i As Integer

-    Dim db As Object, rs As Object

-    

-    sql = "SELECT DISTINCT entry_date FROM lpu_budget"

-    

-    If rm_id <> 0 Then

-        sql = sql & " WHERE rm_id=" & rm_id

-    End If

-    

-    i = 0

-    

-    dbOpenConnection db

-    Set rs = CreateObject("ADODB.Recordset")

-    

-    rs.Open sql, db

-        

-        If Not rs.BOF Then

-            Do While Not rs.EOF

-                i = i + 1

-                ReDim Preserve qtr_lst(i)

-                qtr_lst(i) = rs("entry_date")

-                rs.MoveNext

-            Loop

-        Else

-            getAllQTRNames = 0

-            Exit Function

-        End If

-    getAllQTRNames = i

-    dbCloseConnection db

-End Function

-

-Function getREGION_by_QTR(ent_date As String, treg As tREGION, rm_id As Long) As Integer

-    Dim rep_count As Integer

-    rep_count = 0

-    

-    Dim reps() As tQTR_COMMON

-    rep_count = Get_QTR_CommonList_by_REP(reps, ent_date, 0, rm_id)

-    

-    treg.ent_date = ent_date

-    treg.total_BDGT = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.total_BDGT_NMG = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.sale_PLAN = 0 ' quarter.sale_plan

-    treg.total_SALE = 0 'summ of

-    ' hir = (amb40+st40)*pr40 + (amb20+st20)*pr20

-    'ter (amb_clx+stat_clx)*price

-    ' acs xxx

-    'price per rep

-    treg.total_HIR = 0 'patiens clxn

-    treg.total_TER = 0 'patiens clxn

-    treg.total_ACS = 0 'patiens clxn

-    treg.total_LPU = 0 'lpu

-    treg.total_BEDS = 0 'lpu.beds

-    treg.total_REP = 0 '

-    

-    If rep_count > 0 Then

-        Dim i As Integer

-        

-        For i = 1 To UBound(reps)

-            ' current rep is reps(i)

-            With reps(i)

-                treg.total_BDGT = treg.total_BDGT + .c_bdgt_NFG + .c_bdgt_NMG

-                treg.total_BDGT_NMG = treg.total_BDGT_NMG + .c_bdgt_NMG

-                treg.sale_PLAN = treg.sale_PLAN + .qtr.sale_PLAN

-                treg.total_SALE = treg.total_SALE + .c_sale_ALL

-                treg.total_HIR = treg.total_HIR + .c_pat_HIR

-                treg.total_TER = treg.total_TER + .c_pat_TER

-                treg.total_ACS = treg.total_ACS + .c_pat_CRD

-                treg.total_LPU = treg.total_LPU + .i_lcd

-                treg.total_BEDS = treg.total_BEDS + .c_beds

-                treg.total_REP = treg.total_REP + 1

-            End With

-            

-        Next i

-        

-    End If

-    

-    getREGION_by_QTR = treg.total_REP

-End Function

-

-<<<<<<
-======================
-mRM_QTR
->>>>>>
-Attribute VB_Name = "mRM_QTR"

-Option Explicit

-

-Sub btRM_QTR_Do_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    Dim i As Integer

-    Dim def_dir As String

-    Dim flist() As String

-    

-    idx = Worksheets(VAR_SHEET).Range("RM_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-'            def_dir = GetWBPath(ThisWorkbook.FullName)

-'            If GetImportDirectory(def_dir, flist) Then

-'                Dim db_list() As String

-'                i = GetDBList(flist, db_list)

-'                If i > 0 Then

-'                    ImportFromRegionalManagers db_list, GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-'                End If

-'            End If

-'            Worksheets(RM_QTR_SHEET).update_history

-        Case 2

-            Worksheets("REP_LIST").Range("ret_addr") = "RM_QTR"

-            Worksheets("REP_LIST").setEnt_date (Worksheets(RM_QTR_SHEET).getEnt_date())

-            Worksheets("REP_LIST").Range("RM_ID") = Worksheets(RM_QTR_SHEET).Range("RM_ID")

-            Worksheets("REP_LIST").Range("VIEW_ONLY") = True

-

-            Worksheets("REP_LIST").Select

-        Case 3

-            MsgBox "Функция не доступна", vbOKOnly, PROGRAM_NAME

-    End Select

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-End Sub

-

-Sub btRM_QTR_RET_IT()

-    Dim str As String

-    str = Range("ret_addr")

-    ThisWorkbook.Worksheets(str).Activate

-End Sub

-

-<<<<<<
-======================
-mImport
->>>>>>
-Attribute VB_Name = "mImport"

-    Option Explicit

-

-Const OFN_ALLOWMULTISELECT As Long = 512

-Const OFN_EXPLORER As Long = 524288

-Const OFN_HIDEREADONLY As Long = 4

-Const OFN_NONETWORKBUTTON As Long = 131072

-Const OFN_READONLY As Long = 1

-       

-Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _

-    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

-

-Private Type OPENFILENAME

-    lStructSize As Long

-    hWndOwner As Long

-    hInstance As Long

-    lpstrFilter As String

-    lpstrCustomFilter As String

-    nMaxCustFilter As Long

-    nFilterIndex As Long

-    lpstrFile As String

-    nMaxFile As Long

-    lpstrFileTitle As String

-    nMaxFileTitle As Long

-    lpstrInitialDir As String

-    lpstrTitle As String

-    flags As Long

-    nFileOffset As Integer

-    nFileExtension As Integer

-    lpstrDefExt As String

-    lCustData As Long

-    lpfnHook As Long

-    lpTemplateName As String

-End Type

-

-Function GetImportDirectory(DB_dir As String, flist() As String) As Boolean

-    Dim OpenFile As OPENFILENAME

-    Dim lReturn As Long

-    Dim sFilter As String

-    

-    OpenFile.lStructSize = Len(OpenFile)

-    '         OpenFile.hwndOwner = Form1.hWnd

-    '         OpenFile.hInstance = App.hInstance

-    sFilter = "Clexane Data Files" & Chr(0) & PROGRAM_IMPORTNAME & PROGRAM_DATAEXT & Chr(0)

-    OpenFile.lpstrFilter = sFilter

-    OpenFile.nFilterIndex = 1

-    OpenFile.lpstrFile = String(257, 0)

-    OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1

-    OpenFile.lpstrFileTitle = OpenFile.lpstrFile

-    OpenFile.nMaxFileTitle = OpenFile.nMaxFile

-    OpenFile.lpstrInitialDir = DB_dir

-    OpenFile.lpstrTitle = "Импорт данных"

-    OpenFile.flags = OFN_HIDEREADONLY + OFN_EXPLORER

-    lReturn = GetOpenFileName(OpenFile)

-    If lReturn = 0 Then

-        GetImportDirectory = False

-    Else

-        GetImportDirectory = True

- 

-        flist = Split(OpenFile.lpstrFile, Chr(0), Compare:=vbBinaryCompare)

-        Dim i As Integer

-        i = 0

-        Do While flist(i) <> ""

-            i = i + 1

-        Loop

-        If i = 1 Then

-            flist(1) = flist(0)

-            flist(0) = GetWBPath(flist(1))

-            flist(1) = GetWBName(flist(1))

-        Else

-            flist(0) = flist(0) & "\"

-        End If

-    End If

-End Function

-<<<<<<
-======================
-cPPReport
->>>>>>
-Attribute VB_Name = "cPPReport"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Const PPR_NON As Integer = 0

-Const PPR_NEW As Integer = 1

-Const PPR_OLD As Integer = 2

-

-Dim ReportApp As PowerPoint.Application

-Dim ReportDoc As PowerPoint.Presentation

-Dim ReportState As Integer

-Dim PowerPointPath As String

-

-Private Sub Class_Initialize()

-    Set ReportApp = CreateObject("PowerPoint.Application")

-    PowerPointPath = ReportApp.Path & "\PowerPNT.EXE"

-    ReportState = PPR_NON

-End Sub

-

-Sub OpenReport(FileName As String)

-    If ReportState <> PPR_NON Then

-        SaveReport

-    End If

-    Set ReportDoc = GetObject(FileName)

-    ReportState = PPR_OLD

-End Sub

-

-Sub CreateReport()

-    If ReportState <> PPR_NON Then

-        SaveReport

-    End If

-    Set ReportDoc = ReportApp.Presentations.Add

-    ReportState = PPR_NEW

-End Sub

-

-Sub SaveReport()

-    Select Case ReportState

-        Case PPR_NEW

-            ReportDoc.SaveAs GetWBPath(ThisWorkbook.FullName) + PROGRAM_FILENAME

-        Case PPR_OLD

-            ReportDoc.Save

-    End Select

-    ReportState = PPR_NON

-End Sub

-

-Sub ReportView()

-    Dim CmdName As String

-    CmdName = GetWBPath(ThisWorkbook.FullName) + PROGRAM_FILENAME + ".PPT"

-    CmdName = PowerPointPath & " " & CmdName

-    Shell CmdName, 1

-End Sub

-

-Sub InsertSlide()

-    Dim ReportPage As PowerPoint.Slide

-    Set ReportPage = ReportDoc.Slides.Add(ReportDoc.Slides.count + 1, ppLayoutBlank)

-    

-    ReportPage.Shapes.Paste

-    ReportPage.Shapes.AddLabel(msoTextOrientationHorizontal, 20, 20, 640, 40) _

-      .TextFrame.TextRange.Text = "Slide #" & Format(ReportDoc.Slides.count)

-End Sub

-

-

-Private Sub Class_Terminate()

-    SaveReport

-    ReportApp.Quit

-End Sub

-<<<<<<
-======================
-dlgImprtDB
->>>>>>
-Attribute VB_Name = "dlgImprtDB"

-Attribute VB_Base = "0{36355920-F7A4-44A8-96EF-5D79CF26137D}{F852BDF2-AB3E-468E-89DF-EC5DC0C7C88B}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Private Sub btSelAll_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = True

-    Next i

-End Sub

-

-Private Sub btUnselect_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = False

-    Next i

-End Sub

-<<<<<<
-======================
-rmImport
->>>>>>
-Attribute VB_Name = "rmImport"

-Option Explicit

-

-Public Type dbDESCRIPTION

-    Name As String

-    Fields() As String

-End Type

-

-Sub ImportFromRegionalManagers(rm_files() As String, fm_file As String)

-    Dim db(9) As dbDESCRIPTION

-    

-    '''''data

-    db(1).Name = "rep"

-    

-    db(2).Name = "lpu"

-    db(3).Name = "lpu_acs"

-    db(4).Name = "lpu_budget"

-    db(5).Name = "lpu_hir"

-    db(6).Name = "lpu_im"

-    db(7).Name = "lpu_ter"

-    db(8).Name = "quarter"

-    db(9).Name = "quarter_rm"

-    

-    ReDim db(1).Fields(5)

-    With db(1)

-        .Fields(1) = "rep_id"

-        .Fields(2) = "firstname"

-        .Fields(3) = "lastname"

-        .Fields(4) = "region"

-        .Fields(5) = "city"

-    End With

-    

-    ReDim db(2).Fields(5)

-    With db(2)

-        .Fields(1) = "id"

-        .Fields(2) = "rep_id"

-        .Fields(3) = "name"

-        .Fields(4) = "address"

-        .Fields(5) = "beds"

-    End With

-    

-    ReDim db(3).Fields(7)

-    With db(3)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "patients_with_geparins"

-        .Fields(5) = "patients_per_quarter"

-        .Fields(6) = "patients_stationar_nmg"

-        .Fields(7) = "patients_stationar_clexan"

-    End With

-    

-    ReDim db(4).Fields(6)

-    With db(4)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "bdgt_NMG"

-        .Fields(5) = "bdgt_NFG"

-        .Fields(6) = "sale_PLAN"

-    End With

-    

-    ReDim db(5).Fields(15)

-    With db(5)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "operations_per_quarter"

-        .Fields(5) = "risk_percent"

-        .Fields(6) = "patients_with_risk_ON"

-        .Fields(7) = "patients_ambulator"

-        .Fields(8) = "patients_ambulator_nmg"

-        .Fields(9) = "patients_ambulator_clexan"

-        .Fields(10) = "patients_ambulator_clexan_40mg"

-        .Fields(11) = "patients_ambulator_clexan_20mg"

-        .Fields(12) = "patients_stationar_nmg"

-        .Fields(13) = "patients_stationar_clexan"

-        .Fields(14) = "patients_stationar_clexan_40mg"

-        .Fields(15) = "patients_stationar_clexan_20mg"

-    End With

-    

-    

-    ReDim db(6).Fields(7)

-    With db(6)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "patients_with_geparins"

-        .Fields(5) = "patients_per_quarter"

-        .Fields(6) = "patients_stationar_nmg"

-        .Fields(7) = "patients_stationar_clexan"

-    End With

-    

-    ReDim db(7).Fields(11)

-    With db(7)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "patients_per_quarter"

-        .Fields(5) = "risk_percent"

-        .Fields(6) = "patients_with_risk_ON"

-        .Fields(7) = "patients_ambulator"

-        .Fields(8) = "patients_ambulator_nmg"

-        .Fields(9) = "patients_ambulator_clexan"

-        .Fields(10) = "patients_stationar_nmg"

-        .Fields(11) = "patients_stationar_clexan"

-    End With

-    

-    ReDim db(8).Fields(9)

-    With db(8)

-        .Fields(1) = "ID"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "rep_id"

-        .Fields(4) = "sale_plan"

-        .Fields(5) = "ClxnH20mg"

-        .Fields(6) = "ClxnH40mg"

-        .Fields(7) = "ClxnT40mg"

-        .Fields(8) = "ClxnC_IM"

-        .Fields(9) = "ClxnC_ACS"

-    End With

-    

-    ReDim db(9).Fields(3)

-    With db(9)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "sale_plan"

-    End With

-    

-    Dim rm_idx As Integer

-    Dim to_db As Object

-    'back uo

-    Merge_BackUp_All_Data

-    

-    'clean up

-    Merge_Clear_All_Data fm_file

-    

-    Set to_db = dbGetConnection(fm_file)

-    

-    For rm_idx = 1 To UBound(rm_files)

-        Dim from_db As Object

-        

-        Set from_db = dbGetConnection(rm_files(rm_idx))

-        

-        Dim new_rm_id As Long

-        new_rm_id = dbMergeRM(from_db, to_db)

-

-        Dim i As Integer

-

-        For i = 1 To UBound(db)

-            Dim get_sql As String

-            Dim getRS As Object

-            Dim insRS As Object

-            Dim field_idx As Integer

-                        

-            get_sql = "SELECT * FROM " & db(i).Name

-            Set getRS = CreateObject("ADODB.Recordset")

-            Set insRS = CreateObject("ADODB.Recordset")

-            insRS.Open db(i).Name, to_db, 2, 2

-

-            getRS.Open get_sql, from_db

-            

-            If Not getRS.BOF Then

-                Do While Not getRS.EOF

-                    insRS.addnew

-                    Dim fld_name As String

-                    

-                    For field_idx = 1 To UBound(db(i).Fields)

-                        fld_name = db(i).Fields(field_idx)

-                        insRS(fld_name) = getRS(fld_name)

-                    Next field_idx

-                    

-                    insRS("rm_id") = new_rm_id

-                    insRS.Update

-                    getRS.MoveNext

-                Loop

-            

-            Else

-                'empty table

-                ' do nothing

-            End If

-            

-            

-        Next i

-        

-        dbCloseOpenedConnection from_db

-    Next rm_idx

-    

-    dbCloseOpenedConnection to_db

-End Sub

-

-Function dbMergeRM(from_dbConnection As Object, to_dbConnection As Object) As Long

-

-    Dim getRecordset As Object

-    Dim getREPData_SQL As String

-    Dim REP_fn As String

-    Dim REP_ln As String

-    Dim REP_region As String

-    Dim REP_city As String

-

-

-    getREPData_SQL = "SELECT * FROM reg_man"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getREPData_SQL, from_dbConnection

-        

-        If Not getRecordset.BOF Then

-            REP_fn = getRecordset("firstname")

-            REP_ln = getRecordset("lastname")

-            REP_city = getRecordset("city")

-            REP_region = getRecordset("region")

-        Else

-            MsgBox "There is no information about Regional Manager! This database cannot be merged!!!"

-            dbMergeRM = -1

-            Exit Function

-        End If

-    

-    Dim insertRecordset As Object

-    Set insertRecordset = CreateObject("ADODB.Recordset")

-        

-    insertRecordset.Open "reg_man", to_dbConnection, 2, 2

-    insertRecordset.addnew

-        

-    insertRecordset("firstname") = REP_fn

-    insertRecordset("lastname") = REP_ln

-    insertRecordset("region") = REP_region

-    insertRecordset("city") = REP_city

-    insertRecordset.Update

-    insertRecordset.MoveLast

-    'new ID

-    dbMergeRM = insertRecordset("mgr_id")

-    

-End Function

-

-Sub cmDataImport()

-    Dim def_dir As String

-    Dim flist() As String

-    Dim i As Integer

-

-    def_dir = GetWBPath(ThisWorkbook.FullName)

-    If GetImportDirectory(def_dir, flist) Then

-        Dim ImpMask() As String

-        ImpMask = Split(flist(1), Chr(95), Compare:=vbBinaryCompare)

-        flist(1) = ImpMask(0) & "*"

-        Dim db_list() As String

-        i = GetDBList(flist(), db_list)

-        

-        If i > 0 Then

-            ImportFromRegionalManagers db_list, GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-        End If

-    End If

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).Select

-End Sub

-

-

-<<<<<<
-======================
-PRJ_QTR
->>>>>>
-Attribute VB_Name = "PRJ_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CPRJ_QT As Integer = 0

-Const CPRJ_ID As Integer = 1

-Const CPRJ_PLN As Integer = 2

-Const CPRJ_FCT As Integer = 3

-Const CPRJ_BDG As Integer = 4

-Const CPRJ_CNT As Integer = 5

-Const CPRJ_BEDS As Integer = 6

-Const CPRJ_HIR As Integer = 7

-Const CPRJ_TER As Integer = 8

-Const CPRJ_CRD As Integer = 9

-Const CPRJ_CLXN_BDG As Integer = 10

-Const CPRJ_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Const LOCAL_ENT_DATE As String = "B11"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("PRJ_QTR")

-        s = "Все регионы, " & .getEnt_date()

-    End With

-    

-    MakeChartTitle = s

-End Function

-

-Sub update_history()

-    Dim objQTR() As tREGION

-    Dim i As Long

-    Dim r As Range

-

-

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetRGN_COMM_DATA(objQTR(), 0)

-    

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CPRJ_QT) = objQTR(i).ent_date

-            r.Offset(i - 1, CPRJ_ID) = ""

-            r.Offset(i - 1, CPRJ_PLN) = objQTR(i).sale_PLAN

-            r.Offset(i - 1, CPRJ_FCT) = objQTR(i).total_SALE

-            r.Offset(i - 1, CPRJ_BDG) = objQTR(i).total_BDGT

-            r.Offset(i - 1, CPRJ_CNT) = objQTR(i).total_LPU

-            r.Offset(i - 1, CPRJ_BEDS) = objQTR(i).total_REP

-            r.Offset(i - 1, CPRJ_HIR) = objQTR(i).total_HIR

-            r.Offset(i - 1, CPRJ_TER) = objQTR(i).total_TER

-            r.Offset(i - 1, CPRJ_CRD) = objQTR(i).total_ACS

-            If objQTR(i).total_BDGT <> 0 Then

-                r.Offset(i - 1, CPRJ_CLXN_BDG) = objQTR(i).total_SALE / objQTR(i).total_BDGT

-            End If

-            If objQTR(i).total_BDGT_NMG <> 0 Then

-                r.Offset(i - 1, CPRJ_CLXN_NMG) = objQTR(i).total_SALE / objQTR(i).total_BDGT_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR_PRJ()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(PRJ_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CPRJ_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CPRJ_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CPRJ_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CPRJ_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CPRJ_CRD + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-

-Sub Draw_PLN_QTR_PRJ()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(PRJ_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CPRJ_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CPRJ_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CPRJ_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CPRJ_FCT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PLN_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Draw_BDGT_QTR_PRJ()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(PRJ_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CPRJ_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CPRJ_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CPRJ_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CPRJ_CLXN_NMG + 1)

-        End If

-    Next i

-    Worksheets("CHRT_BDGT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-Public Sub cbxPRJ_QtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR_PRJ

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR_PRJ

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR_PRJ

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = PRJ_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    Protect UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CPRJ_QT + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    If r = "" Then

-        Worksheets(VAR_SHEET).Range("PRJ_ACTION") = 2

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        Worksheets(VAR_SHEET).Range("PRJ_ACTION") = 2

-        Range("LAST_FOCUS") = currRange.address

-        With Worksheets("REP_LIST")

-            .Range("ret_addr") = "PRJ_QTR"

-            .Range("ent_date") = r

-            .Range("VIEW_ONLY") = True

-        End With

-    End If

-    Cancel = True

-    btPRJ_QTR_Do_IT ' old btRM_OTR_DO_IT

-End Sub

-

-<<<<<<
-======================
-RM_LIST
->>>>>>
-Attribute VB_Name = "RM_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Const LOCAL_ENT_DATE As String = "C10"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-

-Public Function getCurrentRM_ID() As Long

-    Dim r As Range

-

-    With Worksheets("RM_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CRM_ID)

-    End With

-

-    getCurrentRM_ID = r

-End Function

-

-Public Sub RM_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("PM_CHR_IDX")

-        Case 1

-            Rm_Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Rm_Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Rm_Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-

-        Case 4

-            Rm_Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectRM_QTR(rm_id As Long)

-    Dim vo As Boolean

-

-    Range("JUMP") = "RM_QTR"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("RM_QTR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "RM_LIST"

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Public Sub SelectREP_LIST(rm_id As Long)

-    Dim vo As Boolean

-

-    Range("JUMP") = "REP_LIST"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("REP_LIST")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "RM_LIST"

-        .setEnt_date (getEnt_date())

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateRMList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Sub UpdateRMList()

-    Dim rmcd() As tRMID_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-

-    ent_date = getEnt_date

-

-    i = Get_RM_CommonList_by_QTR(rmcd(), ent_date)

-

-    With ThisWorkbook.Worksheets("RM_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(rmcd)

-            r.Offset(i - 1, CRM_NAME) = GetRegionName(rmcd(i).rm.Region)

-            r.Offset(i - 1, CRM_ID) = rmcd(i).rm.rm_id

-            r.Offset(i - 1, CRM_BEDS) = rmcd(i).rgcd(1).total_BEDS

-            r.Offset(i - 1, CRM_BDGT) = rmcd(i).rgcd(1).total_BDGT

-            r.Offset(i - 1, CRM_NMG) = rmcd(i).rgcd(1).total_BDGT_NMG

-            r.Offset(i - 1, CRM_HIR) = rmcd(i).rgcd(1).total_HIR

-            r.Offset(i - 1, CRM_TER) = rmcd(i).rgcd(1).total_TER

-            r.Offset(i - 1, CRM_CAR) = rmcd(i).rgcd(1).total_ACS

-            r.Offset(i - 1, CRM_FACT) = rmcd(i).rgcd(1).total_SALE

-            r.Offset(i - 1, CRM_PLAN) = rmcd(i).rgcd(1).sale_PLAN

-            

-            With rmcd(i).rgcd(1)

-                r.Offset(i - 1, CRM_PAT_LPU) = .total_HIR + .total_TER + .total_ACS

-            End With

-            

-            r.Offset(i - 1, CRM_BDGT_1) = rmcd(i).rgcd(1).total_BDGT

-            If rmcd(i).rgcd(1).total_BDGT > 0 Then

-                r.Offset(i - 1, CRM_BDGT_1 + 1) = rmcd(i).rgcd(1).total_SALE / rmcd(i).rgcd(1).total_BDGT

-            End If

-            If r.Offset(i - 1, CRM_BDGT_1 + 1) > 1 Then

-                r.Offset(i - 1, CRM_BDGT_1 + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim rep_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CRM_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CRM_AREA).row, CRM_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    rep_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CRM_AREA).Column

-

-    If i < 4 Then

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 1

-    Else

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 2

-    End If

-

-    If rep_id = 0 Then

-        Range("LAST_FOCUS") = Range(CRM_AREA).address

-    End If

-

-    If rep_id = 0 Then

-        i = CRM_NAME

-        Range("JUMP") = ""

-    Else

-        btRM_LIST_DO_IT

-    End If

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-<<<<<<
-======================
-mPRJ_QTR
->>>>>>
-Attribute VB_Name = "mPRJ_QTR"

-Sub btPRJ_QTR_Do_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    

-    idx = Worksheets(VAR_SHEET).Range("PRJ_ACTION")

-    ent_date = Worksheets(PRJ_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            cmDataImport

-        Case 2

-            Worksheets("RM_LIST").setEnt_date (Worksheets("PRJ_QTR").getEnt_date())

-            Worksheets("RM_LIST").Range("ret_addr") = "PRJ_QTR"

-            Worksheets("RM_LIST").Select

-        Case 3

-            cmNewReport

-    End Select

-    Worksheets(VAR_SHEET).Range("PRJ_ACTION") = 2

-End Sub

-

-

-<<<<<<
-======================
-mRM_LIST
->>>>>>
-Attribute VB_Name = "mRM_LIST"

-Option Explicit

-

-Public Const CRM_AREA As String = "B12"

-Public Const CRM_NAME As Integer = 0

-Public Const CRM_NAME1 As Integer = 1

-Public Const CRM_NAME2 As Integer = 2

-Public Const CRM_ID As Integer = 3

-Public Const CRM_BEDS As Integer = 4

-Public Const CRM_BDGT As Integer = 5

-Public Const CRM_NMG As Integer = 6

-Public Const CRM_HIR As Integer = 7

-Public Const CRM_TER As Integer = 8

-Public Const CRM_CAR As Integer = 9

-Public Const CRM_FACT As Integer = 10

-Public Const CRM_PLAN As Integer = 11

-Public Const CRM_PAT_LPU As Integer = 16

-Public Const CRM_BDGT_1 As Integer = 17

-

-

-Const LOCAL_ENT_DATE As String = "C10"

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Sub EditREP(CRM As tREPID, ent_date As String)

-    NoFunc

-End Sub

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("RM_LIST")

-        s = "Регионы, " & .getEnt_date()

-    End With

-    

-    MakeChartTitle = s

-End Function

-

-Sub Rm_Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_LPU_BBL").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rm_Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRM_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRM_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRM_FACT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PIE").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rm_Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CRM_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRM_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRM_HIR + 1)

-            psum = psum + src.Cells(i, CRM_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRM_TER + 1)

-            psum = psum + src.Cells(i, CRM_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRM_CAR + 1)

-            psum = psum + src.Cells(i, CRM_CAR + 1)

-            dst.Cells(i, 5) = psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU").Range("title") = MakeChartTitle

-    

-End Sub

-

-Sub Rm_Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CRM_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRM_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRM_HIR + 1)

-            psum = psum + src.Cells(i, CRM_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRM_TER + 1)

-            psum = psum + src.Cells(i, CRM_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRM_CAR + 1)

-            psum = psum + src.Cells(i, CRM_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CRM_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU_A").Range("title") = MakeChartTitle

-    

-End Sub

-

-Sub btRM_LIST_RET_IT()

-    With Worksheets("RM_LIST")

-        .setEnt_date ("")

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = "PRJ_QTR"

-    End With

-    ThisWorkbook.Worksheets("PRJ_QTR").Activate

-End Sub

-

-

-Sub btRM_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim rm_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("RM_LIST_ACTION")

-    With Worksheets("RM_LIST")

-        rm_id = .getCurrentRM_ID()

-        

-        Select Case i

-            Case 1:

-                .SelectRM_QTR rm_id

-            Case 2:

-                .SelectREP_LIST rm_id

-            End Select

-    End With

-    

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-

-

-

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mImport2
->>>>>>
-Attribute VB_Name = "mImport2"

-Option Explicit

-

-Sub FOpen()

-    Dim flist As String

-    Dim fileToOpen, s

-    flist = ""

-    fileToOpen = Application _

-        .GetOpenFileName("Data Files (*.mdb), mr*.mdb", Title:="Импорт данных", MultiSelect:=True)

-    If fileToOpen <> False Then

-        For Each s In fileToOpen

-            flist = flist & s & "; "

-        Next s

-        MsgBox "Open " & flist

-    End If

-End Sub

-

-Sub t2()

-Dim d As ImprtDB

-Set d = New ImprtDB

-d.Show

-

-End Sub

-

-<<<<<<
-======================
-ImprtDB
->>>>>>
-Attribute VB_Name = "ImprtDB"

-Attribute VB_Base = "0{67FA6A28-8370-4981-8F01-1A9079245761}{ECFCB43F-B241-4CD9-9CB3-2A981933173D}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btSelAll_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = True

-    Next i

-End Sub

-

-Private Sub btUnselect_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = False

-    Next i

-End Sub

-<<<<<<
-======================
-mImport
->>>>>>
-Attribute VB_Name = "mImport"

-    Option Explicit

-

-Const OFN_ALLOWMULTISELECT As Long = 512

-Const OFN_EXPLORER As Long = 524288

-Const OFN_HIDEREADONLY As Long = 4

-Const OFN_NONETWORKBUTTON As Long = 131072

-Const OFN_READONLY As Long = 1

-       

-Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _

-  "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

-

-Private Type OPENFILENAME

-  lStructSize As Long

-  hWndOwner As Long

-  hInstance As Long

-  lpstrFilter As String

-  lpstrCustomFilter As String

-  nMaxCustFilter As Long

-  nFilterIndex As Long

-  lpstrFile As String

-  nMaxFile As Long

-  lpstrFileTitle As String

-  nMaxFileTitle As Long

-  lpstrInitialDir As String

-  lpstrTitle As String

-  flags As Long

-  nFileOffset As Integer

-  nFileExtension As Integer

-  lpstrDefExt As String

-  lCustData As Long

-  lpfnHook As Long

-  lpTemplateName As String

-End Type

-

-Private Sub Command1_Click()

-  Dim OpenFile As OPENFILENAME

-  Dim lReturn As Long

-  Dim sFilter As String

-  OpenFile.lStructSize = Len(OpenFile)

-'         OpenFile.hwndOwner = Form1.hWnd

-'         OpenFile.hInstance = App.hInstance

-  sFilter = "Clexane Data Files" & Chr(0) & "mr*.mdb" & Chr(0)

-  OpenFile.lpstrFilter = sFilter

-  OpenFile.nFilterIndex = 1

-  OpenFile.lpstrFile = String(257, 0)

-  OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1

-  OpenFile.lpstrFileTitle = OpenFile.lpstrFile

-  OpenFile.nMaxFileTitle = OpenFile.nMaxFile

-' OpenFile.lpstrInitialDir = "C:\"

-  OpenFile.lpstrTitle = "Импорт данных"

-  OpenFile.flags = OFN_HIDEREADONLY + OFN_ALLOWMULTISELECT + OFN_EXPLORER

-  lReturn = GetOpenFileName(OpenFile)

-  If lReturn = 0 Then

-     MsgBox "The User pressed the Cancel Button"

-  Else

-     MsgBox "The user Chose " & Trim(OpenFile.lpstrFile)

-  End If

-End Sub

-

-<<<<<<
-Project Name : 'ClexaneRM'
-Quirk - duff tag length======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    ThisWorkbook.Worksheets(RM_QTR_SHEET).ClearRMName

-    

-    Application.EnableEvents = True

-    Set MyAppEvents.app = Application

-    

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    

-    MyAppEvents.CheckWorkBooksArround ThisWorkbook

-    

-    cmSetStandaloneMode

-    

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-    

-    Application.ScreenUpdating = True

-    

-    If CheckUser Then

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).update_history

-        Application.Calculate

-    End If

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    

-    Dim RestMode As Boolean

-    RestMode = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE")

-    

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-'        If RestMode Then

-            ThisWorkbook.Saved = True

-'        Else

-'            ThisWorkbook.Save

-'        End If

-    End If

-    Application.Caption = Empty

-    Application.CommandBars(STDBAR_NAME).Reset

-    If RestMode Then

-        xlRestoreView

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    End If

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-    Dim MaxX, MaxY As Integer

-    With ThisWorkbook.Worksheets(TITLE_SHEET)

-        MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-        MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-    End With

-

-    With ThisWorkbook.Application

-        .ScreenUpdating = False

-        .WindowState = xlNormal

-        .Height = MaxY

-        .Width = MaxX

-    End With

-End Sub

-

-

-

-

-

-<<<<<<
-======================
-REP_QTR
->>>>>>
-Attribute VB_Name = "REP_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CQTR_QT As Integer = 0

-Const CQTR_ID As Integer = 1

-Const CQTR_PLN As Integer = 2

-Const CQTR_FCT As Integer = 3

-Const CQTR_BDG As Integer = 4

-Const CQTR_CNT As Integer = 5

-Const CQTR_BEDS As Integer = 6

-Const CQTR_HIR As Integer = 7

-Const CQTR_TER As Integer = 8

-Const CQTR_CRD As Integer = 9

-Const CQTR_CLXN_BDG As Integer = 10

-Const CQTR_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub update_history()

-    Dim objQTR() As tQTR

-    Dim i As Long

-    Dim r As Range

-    Dim cRep As tREPID

-

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    Range("D4") = cRep.LastName

-    Range("D5") = cRep.FirstName

-

-    Range("H4") = GetRegionName(cRep.Region)

-    Range("H5") = GetCityName(cRep.Region, cRep.City)

-

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetAll_QTR_Records_by_REP(objQTR, "%", cRep.rep_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CQTR_QT) = objQTR(i).entry_date

-        Next i

-    End If

-    Dim qcd() As tQTR_COMMON

-    i = Get_QTR_CommonList_by_REP(qcd, "%", cRep.rep_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(qcd)

-            r.Offset(i - 1, CQTR_QT) = qcd(i).qtr.entry_date

-            r.Offset(i - 1, CQTR_ID) = qcd(i).qtr.id

-            r.Offset(i - 1, CQTR_PLN) = qcd(i).qtr.sale_PLAN

-            r.Offset(i - 1, CQTR_FCT) = qcd(i).c_sale_ALL

-            r.Offset(i - 1, CQTR_BDG) = qcd(i).c_bdgt_LPU

-            r.Offset(i - 1, CQTR_CNT) = qcd(i).i_lcd

-            r.Offset(i - 1, CQTR_BEDS) = qcd(i).c_beds

-            r.Offset(i - 1, CQTR_HIR) = qcd(i).c_pat_HIR

-            r.Offset(i - 1, CQTR_TER) = qcd(i).c_pat_TER

-            r.Offset(i - 1, CQTR_CRD) = qcd(i).c_pat_CRD

-            If qcd(i).c_bdgt_LPU <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_BDG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_LPU

-            End If

-            If qcd(i).c_bdgt_NMG <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_NMG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CQTR_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRepQtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect UserInterfaceOnly:=True

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CQTR_ID + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    i = currRange.Column - Range(CINP_AREA).Column

-

-    QTR_ID = r

-

-    If QTR_ID = 0 Then

-        Worksheets(VAR_SHEET).Range("USER_ACTION") = 1

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        If i > CQTR_FCT Then

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-            Range("LAST_FOCUS") = currRange.address

-        Else

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 3

-            Range("LAST_FOCUS") = currRange.address

-        End If

-    End If

-    Cancel = True

-    btHomeDo_IT

-End Sub

-

-<<<<<<
-======================
-mRep_QTR
->>>>>>
-Attribute VB_Name = "mRep_QTR"

-Option Explicit

-

-Sub NoFunc()

-    MsgBox "Функция не доступна", vbOKOnly, PROGRAM_NAME

-End Sub

-

-Sub DO_Price_qtr(ent_date As String)

-    Dim qtr As tQTR

-    Dim res As Integer

-    Dim cRep As tREPID

-

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    qtr = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-

-    If qtr.id = 0 Then

-        qtr.entry_date = ent_date

-

-        With Worksheets(VAR_SHEET)

-            qtr.ClxnH20mg = .Range("ClxnH20mg")

-            qtr.ClxnH40mg = .Range("ClxnH40mg")

-            qtr.ClxnT40mg = .Range("ClxnT40mg")

-            qtr.ClxnC_ACS = .Range("ClxnC_ACS")

-            qtr.ClxnC_IM = .Range("ClxnC_IM")

-        End With

-    End If

-

-    Dim dlg_nq As dlg_nextQTR

-    Set dlg_nq = New dlg_nextQTR

-

-    With dlg_nq

-        .tb_qtr_name = qtr.entry_date

-        .tb_bdgt_avts = qtr.sale_PLAN

-        .tb_qtr_name = qtr.entry_date

-        .tb_ClxnH20mg = qtr.ClxnH20mg

-        .tb_ClxnH40mg = qtr.ClxnH40mg

-        .tb_ClxnT40mg = qtr.ClxnT40mg

-        .tb_ClxnC_ACS = qtr.ClxnC_ACS

-        .tb_ClxnC_IM = qtr.ClxnC_IM

-    End With

-

-    dlg_nq.Show

-End Sub

-

-Sub DO_Edit_qtr(ent_date As String)

-    If ent_date = "" Then

-        NoFunc

-    Else

-        Dim rep_id As Long

-        rep_id = Worksheets(REP_QTR_SHEET).Range("REP_ID")

-        With ThisWorkbook.Worksheets("LPU_LIST")

-            .Range("VIEW_ONLY") = True

-            .Range("ent_date") = ent_date

-            .Range("REP_ID") = rep_id

-            .Select

-        End With

-    End If

-End Sub

-

-Sub DO_Delete_qtr(ent_date As String)

-    If ent_date <> "" Then

-        MsgBox "Удалить данные за период [" & ent_date & "] нельзя ", vbOKOnly, PROGRAM_NAME

-    End If

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-

-Sub btHomeDo_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    idx = Worksheets(VAR_SHEET).Range("USER_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            NoFunc

-            ' Обновляем экран

-        Case 2

-            DO_Edit_qtr ent_date

-        Case 3

-            DO_Price_qtr ent_date

-        Case 4

-            NoFunc

-    End Select

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-Sub Delete_qtr()

-'    Dim ent_date As String

-'    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-'    DO_Delete_qtr ent_date

-End Sub

-

-Sub btREP_QTR_RET_IT()

-    Dim s As String

-    With Worksheets("REP_QTR")

-        .Range("LAST_FOCUS") = ""

-        s = .Range("ret_addr")

-        .Range("ret_addr") = ""

-    End With

-    If s <> "" Then

-        ThisWorkbook.Worksheets(s).Select

-    Else

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane[RM]"

-Public Const PROGRAM_VERSION As String = "version 1.3"

-Public Const PROGRAM_FILENAME As String = "clexane-rm"

-Public Const PROGRAM_BACKUPNAME As String = "rm-backup-"

-Public Const PROGRAM_EXPORTNAME As String = "rm-ex-"

-Public Const PROGRAM_IMPORTNAME As String = "mr-ex-*"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20030329

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "O40"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-Public Const RM_QTR_SHEET As String = "RM_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-

-End Sub

-

-Function Double2Str(ByVal d As Double, ByVal precision As Integer, Optional Delim As String = ".") As String

-    Dim s As String

-    If Not precision > 0 Then

-        s = Round(d)

-    Else

-        Dim i As Integer

-        i = Fix(d)

-        s = i & Delim

-        d = Abs(d - i)

-        Do

-            precision = precision - 1

-            d = d * 10

-            If precision > 0 Then

-                i = Fix(d)

-            Else

-                i = Round(d)

-            End If

-            If i < 1 Then

-                s = s & "0"

-            Else

-                s = s & i

-                d = d - i

-            End If

-        Loop While precision > 0

-    End If

-    Double2Str = s

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetWBName(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBName = Right(FullName, s_len - pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.name = VAR_SHEET Or sh.name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-<<<<<<
-======================
-Var
->>>>>>
-Attribute VB_Name = "Var"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-title
->>>>>>
-Attribute VB_Name = "title"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LPU_LIST
->>>>>>
-Attribute VB_Name = "LPU_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentLPU_ID() As Long

-    Dim r As Range

-

-    With Worksheets("LPU_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CLPU_ID)

-    End With

-

-    getCurrentLPU_ID = r

-End Function

-

-Public Sub LPU_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectLPU_NAME(lpu_id As Long, ent_date As String)

-    If Range("VIEW_ONLY") = True Then

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    Dim cLPU As tLPU

-    If lpu_id = 0 Then

-        cLPU.id = 0

-        cLPU.rep_id = 0

-        cLPU.address = ""

-        cLPU.name = ""

-    Else

-        cLPU = Get_LPU_Record(lpu_id)

-    End If

-    EditLPU cLPU, getEnt_date

-    Worksheet_Activate

-End Sub

-

-Sub SelectLPU_BDGT(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    vo = Range("VIEW_ONLY")

-    If lpu_id = 0 Then

-        SelectLPU_NAME lpu_id, ent_date

-    Else

-        With ThisWorkbook.Worksheets("LPU_BDGT")

-            .Range("VIEW_ONLY") = vo

-            .Range("ret_addr") = "LPU_LIST"

-            .Range("REP_ID") = r_id

-            .Range("ent_date") = ent_date

-            .Range("lpu_id") = lpu_id

-        End With

-    End If

-End Sub

-

-Sub SelectLPU_HIR(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_HIR")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Sub SelectLPU_TER(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_TER")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Sub SelectLPU_C_ACS(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_C_ACS")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect UserInterfaceOnly:=True

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateLPUList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim lpu_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CINP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CINP_AREA).row, CLPU_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    lpu_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CINP_AREA).Column

-

-    If lpu_id = 0 Then

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    End If

-

-    If lpu_id = 0 Then

-        i = CLPU_NAME

-        Range("JUMP") = ""

-    End If

-    Select Case i

-        Case CLPU_NAME, CLPU_NAME1, CLPU_NAME2, CLPU_BEDS

-            SelectLPU_NAME lpu_id, ent_date

-            Range("JUMP") = ""

-

-        Case CLPU_NMG, CLPU_NFG, CLPU_PLAN, CLPU_FACT

-            SelectLPU_BDGT lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-

-        Case CLPU_HIR

-            SelectLPU_HIR lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_HIR"

-

-        Case CLPU_TER

-            SelectLPU_TER lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_TER"

-

-        Case CLPU_CAR

-            SelectLPU_C_ACS lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        Case Else

-            Range("JUMP") = ""

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateLPUList()

-    Dim lcd() As tLPU_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-    Dim objQTR As tQTR

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    ent_date = getEnt_date

-

-'     ent_date = "%" ' % - all records

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-    i = Get_LPU_CommonQTR(lcd, objQTR)

-

-'     стираем ФИО

-    Range("C3:C4").ClearContents

-

-    Range("C3") = cRep.LastName

-    Range("C4") = cRep.FirstName

-    Range("G3") = GetRegionName(cRep.Region)

-    Range("G4") = GetCityName(cRep.Region, cRep.City)

-    Range("G5") = objQTR.sale_PLAN

-

-

-

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(lcd)

-            r.Offset(i - 1, CLPU_NAME) = lcd(i).lpu.name

-            r.Offset(i - 1, CLPU_ID) = lcd(i).lpu.id

-            r.Offset(i - 1, CLPU_BEDS) = lcd(i).lpu.beds

-

-

-            r.Offset(i - 1, CLPU_NFG) = lcd(i).bdgt.bdgt_NFG

-            r.Offset(i - 1, CLPU_NMG) = lcd(i).bdgt.bdgt_NMG

-            r.Offset(i - 1, CLPU_PLAN) = lcd(i).bdgt.sale_PLAN

-

-            r.Offset(i - 1, CLPU_HIR) = lcd(i).pat_HIR

-            r.Offset(i - 1, CLPU_TER) = lcd(i).pat_TER

-            r.Offset(i - 1, CLPU_CAR) = lcd(i).pat_CRD

-            r.Offset(i - 1, CLPU_FACT) = lcd(i).sale_ALL

-            r.Offset(i - 1, CLPU_PAT_LPU) = lcd(i).pat_LPU

-            r.Offset(i - 1, CLPU_BDGT) = lcd(i).bdgt_LPU

-            If lcd(i).bdgt_LPU > 0 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = lcd(i).sale_ALL / lcd(i).bdgt_LPU

-            End If

-            If r.Offset(i - 1, CLPU_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{F2A5159C-AEB6-4066-B85F-339184DAFECD}{712D78F6-CCB6-499E-9674-B992A7482317}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-dbACS
->>>>>>
-Attribute VB_Name = "dbACS"

-Option Explicit

-

-Public Type tACS

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    patients_with_geparins As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objACS.ID <> 0 then updatre else insert

-Sub Insert_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objACS.id <> 0 Then

-        dbUpdate_ACS_Record dbConnection, objACS

-    Else

-        dbInsert_ACS_Record dbConnection, objACS

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_ACS_RecordsByLPU_ID(ByRef all_ACS_() As tACS, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_ACS_RecordsByLPU_ID = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, all_ACS_, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_ACS_Record dbConnection, objACS

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub dbInsert_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_acs", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objACS

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("patients_with_geparins") = .patients_with_geparins

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objACS.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim Update_SQL As String

-    

-    With objACS

-        Update_SQL = "UPDATE lpu_acs SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "patients_with_geparins=" & .patients_with_geparins & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_ACS_RecordsbyLPU_ID(dbConnection As Object, all_ACS() As tACS, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_ACS_SQL As String

-    Dim getAll_ACS_SQL As String

-    Dim ACS_Count As Long

-    ACS_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_ACS_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        ACS_Count = dbRecordset("ACS_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_ACS_RecordsbyLPU_ID = ACS_Count

-    

-    If ACS_Count > 0 Then

-        'we have records

-        ReDim all_ACS(1 To ACS_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_ACS_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_ACS As tACS

-                 With tmp_ACS

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .patients_with_geparins = dbRecordset("patients_with_geparins")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 all_ACS(index) = tmp_ACS

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE ID=" & objACS.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_ACS_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_HIR
->>>>>>
-Attribute VB_Name = "LPU_CLSN_HIR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-

-        Dim objHir As tHIRURGIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objHir

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .operations_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L9")

-                .patients_ambulator_clexan_20mg = Range("L10")

-                .patients_ambulator_clexan_40mg = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L19")

-                .patients_stationar_clexan_20mg = Range("L20")

-                .patients_stationar_clexan_40mg = Range("L21")

-            End With

-            Insert_Hir_Record objHir

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objHir.id = Range("rec_id")

-                    If objHir.id <> 0 Then

-                        Delete_Hir_Record objHir

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objHir As tHIRURGIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    With objHir

-        Range("rec_id") = .id

-        Range("F6") = .operations_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L9") = .patients_ambulator_clexan

-        Range("L10") = .patients_ambulator_clexan_20mg

-        Range("I21") = .patients_stationar_nmg

-        Range("L19") = .patients_stationar_clexan

-        Range("L20") = .patients_stationar_clexan_20mg

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id)

-

-        formula = "=" & qtr.ClxnH20mg & "*($L$10+$L$20)+" & qtr.ClxnH40mg & "*($L$11+$L$21)"

-        Range("F11").formula = formula

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objHir() As tHIRURGIA

-        Dim i As Integer

-        i = GetAll_Hir_RecordsByLPU_ID(objHir, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.3

-        Else

-            SetupData objHir(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-mSapes
->>>>>>
-Attribute VB_Name = "mSapes"

-Option Explicit

-

-Const SHAPE_COLOR As Integer = 1

-Const SHAPE_NAME As Integer = 2

-

-

-Sub ShapeView(r_sh_finite_state As Range)

-    Dim chk As Range

-    Dim s As String

-    Dim c, idx As Integer

-    For Each chk In r_sh_finite_state

-        idx = 0

-        If chk = "+" Then

-            c = chk.Offset(0, idx + SHAPE_COLOR)

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While c <> 0

-                ShapeFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s)), c

-                idx = idx + 2

-                c = chk.Offset(0, idx + SHAPE_COLOR)

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        Else

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While s <> ""

-                ShapeUnFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s))

-                idx = idx + 2

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        End If

-    Next chk

-End Sub

-

-Sub ShapeFill(sh As ShapeRange, ByVal color As Integer)

-    sh.Fill.Visible = msoTrue

-    sh.Fill.Solid

-    sh.Fill.ForeColor.SchemeColor = color

-    sh.Fill.Transparency = 0#

-End Sub

-

-Sub ShapeUnFill(sh As ShapeRange)

-    sh.Fill.Visible = msoFalse

-    sh.Fill.Transparency = 0#

-End Sub

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Public Const INPUT_NO = 0

-Public Const INPUT_NUMBER = 1

-Public Const INPUT_PERCENT = 2

-Public Const INPUT_STRING = 3

-Public Const INPUT_CHECK = 4

-

-Public Const INP_IDX_TYPE = 1

-Public Const INP_IDX_NEXT = 2

-Public Const INP_IDX_MIN = 3

-Public Const INP_IDX_MAX = 4

-Public Const INP_IDX_DEP = 5

-Public Const INP_IDX_ALT = 7

-

-

-Public Type tInputSet

-    vType As Integer

-    vMin As Long

-    vMax As Long

-    rChk As String

-End Type

-

-Function is_input_cell(ByVal Target As Range, inputs As Range) As tInputSet

-    Dim t As Range

-    Dim iset As tInputSet

-    Dim test As Range

-    iset.vType = INPUT_NO

-    iset.vMin = 0

-    iset.vMax = 0

-    iset.rChk = ""

-    is_input_cell = iset

-

-' Закоментировать следующую сточку для работы

-'  Exit Function

-

-    Set test = Target.Cells(1, 1)

-    For Each t In inputs

-        If Range(t).Column = test.Column And Range(t).row = test.row Then

-            iset.vType = t.Offset(0, INP_IDX_TYPE).Value

-            Select Case iset.vType

-                Case INPUT_CHECK

-                    iset.rChk = t.Offset(0, INP_IDX_ALT)

-                Case INPUT_NUMBER, INPUT_PERCENT

-                    iset.vMin = t.Offset(0, INP_IDX_MIN).Value

-                    iset.vMax = t.Offset(0, INP_IDX_MAX).Value

-            End Select

-            is_input_cell = iset

-            Exit Function

-        End If

-    Next t

-End Function

-

-Function GetFocusAddress(ByVal r As Range, f_next As Range) As String

-    Dim chk, t As Range

-    

-    For Each chk In f_next

-        For Each t In r

-            If t.address = chk Then

-                GetFocusAddress = chk

-                Exit Function

-            End If

-            If Range(chk).Column = t.Column - 1 And Range(chk).row = t.row _

-            Or Range(chk).Column = t.Column And Range(chk).row = t.row - 1 _

-            Then

-                If Range(chk) <> "" Then

-                    If Range(chk) = 0 Then

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_ALT)).address

-                    Else

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_NEXT)).address

-                    End If

-                Else

-                    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-                End If

-                Exit Function

-            End If

-        Next t

-    Next chk

-    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-End Function

-

-Sub SetDependet(r As Range, inputs As Range)

-    Dim chk As Range

-    Dim s, serr As String

-    Dim idx As Integer

-    Dim iset As tInputSet

-    Dim err_found As Boolean

-    

-    If r.count > 1 Then

-        Exit Sub

-    End If

-    

-    err_found = False

-    For Each chk In inputs

-        idx = INP_IDX_DEP

-        

-        

-        iset.vType = chk.Offset(0, INP_IDX_TYPE).Value

-        Select Case iset.vType

-            Case INPUT_NUMBER, INPUT_PERCENT

-                iset.vMin = chk.Offset(0, INP_IDX_MIN).Value

-                iset.vMax = chk.Offset(0, INP_IDX_MAX).Value

-                

-                If Range(chk) > iset.vMax Then

-                    err_found = True

-                    Range(chk) = iset.vMax

-                    serr = "Выход за дозволенный диапазон [" & iset.vMin & ".." & iset.vMax & "]! Данные скорректированы."

-                End If

-                

-                If Range(chk) = "" Then

-                    s = chk.Offset(0, idx)

-                    Do While s <> ""

-                        Range(s) = ""

-                        idx = idx + 1

-                        s = chk.Offset(0, idx)

-                    Loop

-                End If

-        End Select

-    Next chk

-    If err_found Then

-        MsgBox serr, vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Function CheckInputData(inputs As Range) As Boolean

-    Dim r As Range

-    

-    CheckInputData = True

-    For Each r In inputs

-        If Range(r) = "" Then

-            CheckInputData = False

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100.", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Sub Check_Int_Number(Target As Range, Def_Val As Long)

-    Dim err As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    err = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                err = True

-            End If

-        End If

-    Next r

-    If err Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_TER
->>>>>>
-Attribute VB_Name = "LPU_CLSN_TER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim objTer As tTERAPIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objTer

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .patients_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L20")

-            End With

-            Insert_Ter_Record objTer

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objTer.id = Range("rec_id")

-                    If objTer.id <> 0 Then

-                        Delete_Ter_Record objTer

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objTer As tTERAPIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    With objTer

-        Range("rec_id") = .id

-        Range("F6") = .patients_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L11") = .patients_ambulator_clexan

-        Range("I21") = .patients_stationar_nmg

-        Range("L20") = .patients_stationar_clexan

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id)

-        formula = "=" & qtr.ClxnT40mg & "*($L$12+$L$20)"

-        Range("F11").formula = formula

-

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objTer() As tTERAPIA

-        Dim i As Integer

-        i = GetAll_Ter_RecordsByLPU_ID(objTer, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.25

-        Else

-            SetupData objTer(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{5D2CB2D2-3E5E-4B6E-9E0C-2EEBA5E10E17}{C891C133-B6B4-43D3-B411-B4A821905C23}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-LPU_BDGT
->>>>>>
-Attribute VB_Name = "LPU_BDGT"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub SetDefFocus()

-    Range(Range("DEF_FOCUS")).Select

-End Sub

-

-Public Sub ClearData()

-    ClearSheetData

-End Sub

-

-Sub ClearSheetData()

-    If Range("F10") = 0 And Range("F13") = 0 Then

-        Range("F11:F18") = ""

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("F11:F13") = ""

-    End If

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim bdgt As tBUDGET

-        Dim test As Boolean

-        Dim sum As Long

-        With bdgt

-            .lpu_id = Range("lpu_id")

-            .id = Range("rec_id")

-            .entry_date = Range("ent_date")

-            .bdgt_NMG = Round(Range("F11").Value, 0)

-            .bdgt_NFG = Round(Range("F12").Value, 0)

-            .sale_PLAN = Round(Range("F13").Value, 0)

-

-            sum = .bdgt_NFG + .bdgt_NMG - .sale_PLAN

-            test = .bdgt_NFG <> 0 Or .bdgt_NMG <> 0 Or .sale_PLAN <> 0

-        End With

-        If test Then

-            If sum < 0 Then

-                MsgBox _

-                    "Ваш план превышает выделенный на гепарины бюджет. Сохранить данные?", _

-                    vbOKOnly, PROGRAM_NAME

-            End If

-            If test Then

-                Insert_BDGT_Record bdgt

-            End If

-        Else

-            If bdgt.id <> 0 Then

-                If vbYes = MsgBox("Удалить данные из базы!", vbYesNo, PROGRAM_NAME) Then

-                    Delete_BDGT_Record bdgt

-                End If

-                ret_back Range("DEF_FOCUS").Worksheet

-                Exit Sub

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-    End If

-

-   ClearData

-   ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(cLPU As tLPU_COMMON)

-    Dim t_sum As Long

-    t_sum = 0

-' Setup budget data

-    Range("F11") = cLPU.bdgt.bdgt_NMG

-    Range("F12") = cLPU.bdgt.bdgt_NFG

-    Range("F13") = cLPU.bdgt.sale_PLAN

-

-    With cLPU

-        Range("F14") = .pat_ALL

-        Range("F15") = .pat_HIR

-        Range("F16") = .pat_TER

-        Range("F17") = .pat_CRD

-        Range("F18") = .sale_ALL

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-    ws_activate

-End Sub

-

-

-Sub ws_activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Dim cLPU As tLPU_COMMON

-    Dim objQTR As tQTR

-    Dim objLPU As tLPU

-    Dim ent_date As String

-    Dim id As Long

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    id = Range("lpu_id").Value

-    ent_date = Range("ent_date")

-    

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-

-    objLPU = Get_LPU_Record(id)

-    Get_LPU_Common cLPU, objLPU, objQTR

-

-    If cLPU.lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = cLPU.lpu.beds

-        Range("lpu_name") = cLPU.lpu.name

-        Range("lpu_addr") = cLPU.lpu.address

-        Range("rec_id") = cLPU.bdgt.id

-

-        SetupData cLPU

-

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-'    MsgBox Target.address

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case INPUT_CHECK

-

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{BB60E38F-A4AB-4AB4-91D0-40AA798D9F5C}{BE9A54D9-F093-4755-9E17-0B47BB5E2546}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mSheets
->>>>>>
-Attribute VB_Name = "mSheets"

-Option Explicit

-

-Function am_load_now() As Boolean

-    am_load_now = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE")

-End Function

-

-Sub Wks_select(RetSheet As String)

-    Dim sheet As Worksheet

-    For Each sheet In ThisWorkbook.Worksheets

-        If sheet.name = RetSheet Then

-            ThisWorkbook.Worksheets(RetSheet).Select

-            Exit Sub

-        End If

-    Next sheet

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub ret_back(sh As Worksheet)

-    Dim RetSheet As String

-    RetSheet = sh.Range("ret_addr")

-    sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    sh.Range("ret_addr") = ""

-    sh.Range("rec_id") = ""

-    sh.Range("lpu_id") = ""

-    sh.Range("ent_date") = ""

-    sh.Range("lpu_name") = ""

-    sh.Range("lpu_addr") = ""

-    sh.Range("lpu_beds") = ""

-    Wks_select RetSheet

-End Sub

-

-Sub ClearSheetData(r_start As Range)

-    If r_start <> "" Then

-        r_start.Worksheet.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        r_start = ""

-    Else

-        ret_back r_start.Worksheet

-    End If

-End Sub

-

-Sub wks_sel_chng(iset As tInputSet, ByVal Target As Range, sh As Worksheet)

-    Dim DebugMode As Boolean

-    Dim in_range As Range

-    

-    DebugMode = Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-

-    If DebugMode Then

-        sh.Unprotect

-    Else

-        sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    End If

-

-    If iset.vType = INPUT_CHECK Then

-        Set in_range = Target.Worksheet.Range(iset.rChk)

-    Else

-        Set in_range = Target

-    End If

-    

-    Dim str As String

-    str = GetFocusAddress(in_range, sh.Range("h_inputs"))

-

-'    MsgBox Target.Address & "; " & str

-    If str <> Target.address Then

-        sh.Range(str).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-Dlg_lpu_card
->>>>>>
-Attribute VB_Name = "Dlg_lpu_card"

-Attribute VB_Base = "0{2C69E842-8DA9-4240-A0A8-F6B0141DC246}{75AAB28C-ADCF-4D1B-9D5A-AF89E80A810C}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbLPU_List_Change()

-    Dim src As Range

-    Dim idx_src As Integer

-    

-    Set src = Worksheets(VAR_SHEET).Range(Me.cbLPU_List.RowSource)

-    idx_src = Me.cbLPU_List.ListIndex + 1

-    Me.tb_lpu_name.Text = src.Cells(idx_src, 1)

-    Me.tb_lpu_address.Text = src.Cells(idx_src, 2)

-    Me.tbBedsCount.Text = src.Cells(idx_src, 3)

-End Sub

-

-

-Private Sub cbxLPU_List_Enable_Click()

-    

-    If Me.cbxLPU_List_Enable Then

-        

-        Me.tb_lpu_name.Text = ""

-        Me.tb_lpu_name.Enabled = False

-        

-        Me.tb_lpu_address.Text = ""

-        Me.tb_lpu_address.Enabled = False

-        

-        Me.tbBedsCount.Text = ""

-        Me.tbBedsCount.Enabled = False

-        

-        Me.cbLPU_List.Enabled = True

-        cbLPU_List_Change

-    Else

-        Me.tb_lpu_name.Enabled = True

-        Me.tb_lpu_name.Text = ""

-        

-        Me.tb_lpu_address.Enabled = True

-        Me.tb_lpu_address.Text = ""

-        

-        Me.tbBedsCount.Enabled = True

-        Me.tbBedsCount.Text = ""

-        

-        Me.cbLPU_List.Enabled = False

-    End If

-End Sub

-

-<<<<<<
-======================
-UserInfo
->>>>>>
-Attribute VB_Name = "UserInfo"

-Attribute VB_Base = "0{BA873669-5C2D-400A-8A8B-572ACD8CCE4C}{D11400A0-9912-4240-A78C-44C33731216A}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Tag = vbOK

-End Sub

-

-Private Sub cbCity_Change()

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_CITY") = Me.cbCity.ListIndex

-        .Calculate

-    End With

-End Sub

-

-Private Sub cbRegion_Change()

-    Dim LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        NewRangeOffsetCol = cbRegion.Value * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).address

-        NewSumRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).address

-        .Calculate

-        .Range("IDX_CITY") = 0

-        cbCity.RowSource = NewCbxRange

-

-    End With

-    cbCity.ListIndex = 0

-End Sub

-

-<<<<<<
-======================
-mREGMAN
->>>>>>
-Attribute VB_Name = "mREGMAN"

-Option Explicit

-

-Sub hwnew()

-    Dim rs As Range

-    Dim re As Object

-    

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    HWReset

-    ReSet_REGMAN_Record

-    With Worksheets("RM_QTR")

-        .ClearRMName

-        .Range("REP_QTR_INPUT_DATA").ClearContents ' Это не ошибка, названия совпадают

-'        .Range("A1").Select

-    End With

-    Worksheets(TITLE_SHEET).Select

-    With Application

-        .DisplayAlerts = False

-        .ThisWorkbook.Save

-        .Quit

-    End With

-End Sub

-

-Function CheckUser() As Boolean

-    Dim objHW() As Long

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    

-    GetHWInfo objHW()

-    i = GetHWRecords(objHW_DB)

-    

-    If i = 0 Then ' First time

-        StoreHWInfo objHW()

-    End If

-    If CheckHWInfo(objHW()) <> True Then

-        CheckUser = False

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    Else

-        CheckUser = SetupUser

-    End If

-End Function

-

-Function SetupUser() As Boolean

-    Dim cREGMAN As tREGMAN

-    Dim idx As Integer

-    Dim dlg_ui As UserInfo

-    

-    Set dlg_ui = New UserInfo

-    

-    cREGMAN = Get_REGMAN_Record()

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_REGION") = cREGMAN.Region

-        .Range("IDX_CITY") = cREGMAN.City

-    End With

-        

-    With dlg_ui

-        .cbRegion = cREGMAN.Region

-        .cbCity = cREGMAN.City

-        .tbFName = cREGMAN.FirstName

-        .tbLName = cREGMAN.LastName

-    End With

-    

-    Worksheets(REGS_SHEET).Calculate

-    

-    Dim test_Ok As Boolean

-    test_Ok = False

-    

-    On Error GoTo l1

-    

-    Do

-        dlg_ui.Show

-        If dlg_ui.Tag = vbOK Then

-            test_Ok = dlg_ui.tbFName.Value <> "" And dlg_ui.tbLName <> ""

-            If test_Ok Then

-                Exit Do

-            Else

-                MsgBox "Введите имя и фамилию", vbOKOnly, PROGRAM_NAME

-            End If

-        Else

-            Exit Do

-        End If

-    Loop Until False

-l1:

-    If test_Ok Then

-        With cREGMAN

-            .Region = dlg_ui.cbRegion.Value

-            .City = dlg_ui.cbCity.Value

-            .FirstName = dlg_ui.tbFName.Value

-            .LastName = dlg_ui.tbLName.Value

-        End With

-        Set_REGMAN_Record cREGMAN

-    Else

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .ThisWorkbook.Saved = True

-            .Quit

-        End With

-    End If

-    SetupUser = test_Ok

-End Function

-

-Sub GetHWInfo(objHW() As Long)

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    i = 1

-    For Each d In dc

-        If d.drivetype = 2 Then ' 2 - HardDisk

-            ReDim Preserve objHW(i)

-            objHW(i) = d.SerialNumber

-            i = i + 1

-        End If

-    Next

-    SortHW objHW

-End Sub

-

-Sub StoreHWInfo(objHW() As Long)

-    UpdateHWRecords objHW

-End Sub

-

-Sub SortHW(objHW() As Long)

-    Dim r As Range

-    Dim rs As Range

-    Dim re As Object

-    Dim i As Integer

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    For i = 1 To UBound(objHW)

-        r = objHW(i)

-        Set r = r.Offset(1, 0)

-    Next i

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).Sort _

-            Key1:=.Range("HW_Number"), _

-            Order1:=xlDescending, _

-            Header:=xlGuess, _

-            OrderCustom:=1, _

-            MatchCase:=False, _

-            Orientation:=xlTopToBottom

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    i = 1

-    Do While r <> ""

-        objHW(i) = r

-        Set r = r.Offset(1, 0)

-        i = i + 1

-    Loop

-End Sub

-

-Function CheckHWInfo(objHW() As Long)

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    CheckHWInfo = False

-        

-    i = GetHWRecords(objHW_DB)

-    If i > 0 Then

-        SortHW objHW_DB

-    End If

-    If UBound(objHW) = UBound(objHW_DB) Then

-        For i = 1 To UBound(objHW)

-            If objHW(i) <> objHW_DB(i) Then

-                Exit Function

-            End If

-        Next i

-        CheckHWInfo = True

-    End If

-End Function

-

-

-<<<<<<
-======================
-dbBudget
->>>>>>
-Attribute VB_Name = "dbBudget"

-Option Explicit

-

-Public Type tBUDGET

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    bdgt_NMG As Long

-    bdgt_NFG As Long

-    sale_PLAN As Long

-End Type

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function GetAll_BDGT_RecordsByLPU_ID(ByRef allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_BDGT_RecordsByLPU_ID = dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection, allBDGT, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function Get_BDGT_Record(ByVal lpu_id As Long, ByVal ent_date As String) As tBUDGET

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    Get_BDGT_Record = dbGet_BDGT_Record(dbConnection, lpu_id, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objBDGT.ID <> 0 then updatre else insert

-Public Sub Insert_BDGT_Record(objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    If objBDGT.id <> 0 Then

-        dbUpdate_BDGT_Record dbConnection, objBDGT

-    Else

-        dbInsert_BDGT_Record dbConnection, objBDGT

-    End If

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Public Sub Delete_BDGT_Record(ByRef objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    dbDelete_BDGT_Record dbConnection, objBDGT

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_BDGT_Record(dbConnection As Object, ByVal lpu_id As Long, ent_date As String) As tBUDGET

-    

-    Dim sql As String

-    Dim objBDGT As tBUDGET

-    

-    With objBDGT

-        .id = 0

-        .lpu_id = lpu_id

-        .entry_date = ent_date

-        .bdgt_NMG = 0

-        .bdgt_NFG = 0

-        .sale_PLAN = 0

-    End With

-        

-    

-    sql = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        With objBDGT

-            .entry_date = dbRecordset("entry_date")

-            .id = dbRecordset("id")

-            .lpu_id = dbRecordset("lpu_id")

-            .bdgt_NFG = dbRecordset("bdgt_NFG")

-            .bdgt_NMG = dbRecordset("bdgt_NMG")

-            .sale_PLAN = dbRecordset("sale_PLAN")

-        End With

-    End If

-    

-    dbGet_BDGT_Record = objBDGT

-End Function

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection As Object, allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_BDGT_SQL As String

-    Dim getAll_BDGT_SQL As String

-    Dim BDGT_Count As Long

-    BDGT_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_BDGT_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        BDGT_Count = dbRecordset("BDGT_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_BDGT_RecordsbyLPU_ID = BDGT_Count

-    

-    If BDGT_Count > 0 Then

-        'we have records

-        ReDim allBDGT(1 To BDGT_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_BDGT_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpBDGT As tBUDGET

-                 With tmpBDGT

-                    .entry_date = dbRecordset("entry_date")

-                    .id = dbRecordset("id")

-                    .lpu_id = dbRecordset("lpu_id")

-                    .bdgt_NFG = dbRecordset("bdgt_NFG")

-                    .bdgt_NMG = dbRecordset("bdgt_NMG")

-                    .sale_PLAN = dbRecordset("sale_PLAN")

-                 End With

-                 

-                 allBDGT(index) = tmpBDGT

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbInsert_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "lpu_budget", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    dbRecordset("entry_date") = objBDGT.entry_date

-    dbRecordset("lpu_id") = objBDGT.lpu_id

-    dbRecordset("bdgt_NMG") = objBDGT.bdgt_NMG

-    dbRecordset("bdgt_NFG") = objBDGT.bdgt_NFG

-    dbRecordset("sale_PLAN") = objBDGT.sale_PLAN

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objBDGT.id = dbRecordset("id")

-  

-End Sub

-

-Public Sub dbUpdate_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu_budget SET " & _

-    "entry_date='" & objBDGT.entry_date & "'," & _

-    "lpu_id=" & objBDGT.lpu_id & "," & _

-    "bdgt_NMG=" & objBDGT.bdgt_NMG & "," & _

-    "bdgt_NFG=" & objBDGT.bdgt_NFG & "," & _

-    "sale_PLAN=" & objBDGT.sale_PLAN & _

-    " WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-Public Sub dbDelete_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_BDGT_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbDatabase
->>>>>>
-Attribute VB_Name = "dbDatabase"

-Option Explicit

-

-

-Sub dbOpenConnection(dbConnection As Object)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-<<<<<<
-======================
-dbLPU
->>>>>>
-Attribute VB_Name = "dbLPU"

-Option Explicit

-

-Public Type tLPU

-    id As Long

-    rep_id As Long

-    name As String

-    address As String

-    beds As Integer

-End Type

-

-Function Get_LPU_Record(ByVal lpu_id As Long) As tLPU

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_LPU_Record = dbGet_LPU_Record(dbConnection, lpu_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_LPU_byQTR(allLPU() As tLPU, ent_date As String, rep_id As Long) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_LPU_byQTR = dbGetAll_LPU_byQTR(dbConnection, allLPU, ent_date, rep_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_Record(dbConnection As Object, ByVal lpu_id As Long) As tLPU

-    

-    Dim sql As String

-    Dim objLPU As tLPU

-    

-    objLPU.id = lpu_id

-    objLPU.name = ""

-    objLPU.address = ""

-    

-    sql = "SELECT * FROM lpu WHERE id=" & lpu_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objLPU.name = dbRecordset("name")

-        objLPU.address = dbRecordset("address")

-        objLPU.rep_id = dbRecordset("rep_id")

-        objLPU.beds = dbRecordset("beds")

-    End If

-    

-    dbGet_LPU_Record = objLPU

-

-End Function

-

-Function dbGetAll_LPU_byQTR(dbConnection As Object, allLPU() As tLPU, ent_date As String, rep_id As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    Dim Where As String

-    Where = "WHERE lpu_budget.entry_date like '" & ent_date & "'" & " AND lpu.id=lpu_budget.lpu_id AND lpu.rep_id=" & rep_id

-

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu_budget, lpu " & Where

-    

-    getAll_LPU_SQL = "SELECT lpu.id as id, lpu.rep_id as rep_id, lpu.name as name, lpu.address as address, lpu.beds AS beds " & _

-    "FROM lpu, lpu_budget " & Where

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_LPU_byQTR = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-dbREP
->>>>>>
-Attribute VB_Name = "dbREP"

-'Option Explicit

-'

-'Public Type tREP

-'    FirstName As String

-'    LastName As String

-'    Region As Integer

-'    City As Integer

-'End Type

-'

-'Function GetREPRecord() As tREP

-'    Dim dbConnection As Object

-'

-'    dbOpenConnection dbConnection

-'    GetREPRecord = dbGetREPRecord(dbConnection)

-'    dbCloseConnection dbConnection

-'End Function

-'

-'Sub SetREPRecord(cUser As tREP)

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbSetREPRecord dbConnection, cUser

-'    dbCloseConnection dbConnection

-'End Sub

-'

-'Sub ReSetREPRecord()

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbReSetREPRecord dbConnection

-'    dbCloseConnection dbConnection

-'End Sub

-'

-'Public Function dbGetREPRecord(dbConnection As Object) As tREP

-'

-'    Dim SQL As String

-'    Dim objREP As tREP

-'

-'    objREP.FirstName = ""

-'    objREP.LastName = ""

-'    objREP.Region = 0

-'    objREP.City = 0

-'    SQL = "SELECT firstname, lastname, region, city FROM " & _

-'          "rep"

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open SQL, dbConnection

-'    ', 3, 3

-'    If Not dbRecordset.BOF Then

-'

-'        objREP.FirstName = dbRecordset("firstname")

-'        objREP.LastName = dbRecordset("lastname")

-'        objREP.Region = dbRecordset("region")

-'        objREP.City = dbRecordset("city")

-'

-'    End If

-'

-'    dbGetREPRecord = objREP

-'

-'End Function

-'

-'Public Sub dbSetREPRecord(dbConnection As Object, ByRef objREP As tREP)

-'

-'    Dim DeleteSQL As String

-'    Dim InsertSQL As String

-'

-'    DeleteSQL = "DELETE FROM rep"

-'    InsertSQL = "INSERT INTO rep (firstname, lastname, region, city) VALUES (" & _

-'    "'" & objREP.FirstName & "', " & _

-'    "'" & objREP.LastName & "', " & _

-'    objREP.Region & ", " & _

-'    objREP.City & ")"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-'

-'End Sub

-'

-'Public Sub dbReSetREPRecord(dbConnection As Object)

-'

-'    Dim DeleteSQL As String

-'

-'    DeleteSQL = "DELETE FROM rep"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-'

-'End Sub

-'

-

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    CheckWorkBooksArround Wb

-End Sub

-

-

-Sub CheckWorkBooksArround(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If app.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKOnly, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-        Exit Sub

-    End If

-

-End Sub

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub SaveExcelState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-        ActiveWorkbook.DisplayDrawingObjects = xlDisplayShapes

-        

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars(STDBAR_NAME).Visible = False

-End Sub

-

-

-Public Sub RestoreExcelState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars(STDBAR_NAME).Visible = True

-End Sub

-

-

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Public Const STDBAR_NAME = "Worksheet Menu Bar"

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Import"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmImport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Export"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 620

-                        .OnAction = "cmExport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Exit && Restore Excel"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 548

-                        .OnAction = "cmExitRestore"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-       End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(flag As Boolean)

-    If flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars(STDBAR_NAME)

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmImport()

-    Worksheets(RM_QTR_SHEET).Select

-    ImportData

-End Sub

-

-Sub cmExport()

-    dbExport

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    Dim dlg As dlgAbout

-    Set dlg = New dlgAbout

-    

-    dlg.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlg.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlg.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlg.Show

-End Sub

-

-Sub cmMail2Support()

-    Dim err_description As String

-    Dim dlg_msg As dlg_Mail

-    Set dlg_msg = New dlg_Mail

-    With dlg_msg

-        .Show

-        If .Tag = vbOK Then

-            ThisWorkbook.Worksheets(VAR_SHEET).Range("ERR_MESSAGE") _

-                = .tbMessage.Text

-            ThisWorkbook.Save

-            ThisWorkbook.SendMail Recipients:="infra@i-rs.ru", Subject:=PROGRAM_NAME & " ver.:" & PROGRAM_VERSION

-            MsgBox "Сообщение об ошибке отправлено. Перезагрузите программу.", vbOKOnly, PROGRAM_NAME

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-    End With

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-'        helppath = "hh.exe " & .Path & "\Telfast.chm"

-'        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub set_work_mode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetupEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-End Sub

-

-Sub cmSetStandaloneMode()

-    set_work_mode

-    ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    Dim dlg As dlgGetPwd

-    rp = common_pwd

-    

-    Set dlg = New dlgGetPwd

-    dlg.edPwd = ""

-    dlg.Show

-    

-    If dlg.edPwd = rp Then

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmHomePage()

-    ThisWorkbook.Worksheets("RM_QTR").Select

-End Sub

-

-Sub cmExitRestore()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = True

-    Application.Quit

-End Sub

-

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    Dim dlg_prn As dlgPrint

-    

-    Set dlg_prn = New dlgPrint

-    

-    With dlg_prn

-        .cbMainReport = True

-        .cbMainBudget = False

-        .cbSrcData = False

-        .cbAllSheets = False

-    

-        .Show

-    

-        If .Tag = vbCancel Then

-            Exit Sub

-        End If

-    End With

-    

-    Dim PrnIdx As Integer

-    

-    With dlg_prn

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("REP_QTR", "budget", "Final")

-    Case 1111

-        plist = Array("REP_QTR", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("REP_QTR")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Clexane bar"

-Public Const common_pwd As String = "crdjhxtyjr"

-

-

-Sub SetupEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    Wb.Worksheets(TITLE_SHEET).Select

-    With Application

-        .Caption = PROGRAM_NAME & " " & PROGRAM_VERSION

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .SaveExcelState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = False

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Wb.Worksheets(TITLE_SHEET).Select

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    If cWindow.Type = xlWorkbook Then

-                        cWindow.DisplayHeadings = True

-                    End If

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu True

-        End If

-        With mobjAppState

-            .RestoreExcelState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Worksheets(TITLE_SHEET).Select

-'        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Option Explicit

-

-Sub UpdateHWRecords(objHW() As Long)

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    dbUpdateHWRecords dbConnection, objHW

-    dbCloseConnection dbConnection

-End Sub

-

-Function GetHWRecords(objHW() As Long) As Integer

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    GetHWRecords = dbGetHWRecords(dbConnection, objHW)

-    dbCloseConnection dbConnection

-End Function

-

-Sub HWReset()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbInsertHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    

-    Dim dbRecordset As Object

-    Dim i As Long

-    

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "hw", dbConnection, 2, 2

-    

-    For i = 1 To UBound(objHW)

-        dbRecordset.addnew

-        dbRecordset("num") = objHW(i)

-        dbRecordset.Update

-    Next i

-    

-End Sub

-

-Sub dbUpdateHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    dbDeleteHWRecord dbConnection

-    dbInsertHWRecords dbConnection, objHW

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-dbHir
->>>>>>
-Attribute VB_Name = "dbHir"

-Option Explicit

-

-Public Type tHIRURGIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    operations_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_ambulator_clexan_40mg As Integer

-    patients_ambulator_clexan_20mg As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-    patients_stationar_clexan_40mg As Integer

-    patients_stationar_clexan_20mg As Integer

-End Type

-

-' if objHir.ID <> 0 then updatre else insert

-Sub Insert_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objHir.id <> 0 Then

-        dbUpdate_Hir_Record dbConnection, objHir

-    Else

-        dbInsert_Hir_Record dbConnection, objHir

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Hir_RecordsByLPU_ID(ByRef allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Hir_RecordsByLPU_ID = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, allHir, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Hir_Record dbConnection, objHir

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objHir.ID <> 0 then updatre else insert

-

-Sub dbInsert_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_hir", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objHir

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("operations_per_quarter") = .operations_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_ambulator_clexan_20mg") = .patients_ambulator_clexan_20mg

-        dbRecordset("patients_ambulator_clexan_40mg") = .patients_ambulator_clexan_40mg

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-        dbRecordset("patients_stationar_clexan_20mg") = .patients_stationar_clexan_20mg

-        dbRecordset("patients_stationar_clexan_40mg") = .patients_stationar_clexan_40mg

-        

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objHir.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim UpdateSQL As String

-    

-    With objHir

-        UpdateSQL = "UPDATE lpu_hir SET " & _

-            "entry_date='" & objHir.entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "operations_per_quarter=" & .operations_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_ambulator_clexan_20mg=" & .patients_ambulator_clexan_20mg & "," & _

-            "patients_ambulator_clexan_40mg=" & .patients_ambulator_clexan_40mg & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & "," & _

-            "patients_stationar_clexan_20mg=" & .patients_stationar_clexan_20mg & "," & _

-            "patients_stationar_clexan_40mg=" & .patients_stationar_clexan_40mg & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_Hir_RecordsbyLPU_ID(dbConnection As Object, allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Hir_SQL As String

-    Dim getAll_Hir_SQL As String

-    Dim Hir_Count As Long

-    Hir_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Hir_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Hir_Count = dbRecordset("HIR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Hir_RecordsbyLPU_ID = Hir_Count

-    

-    If Hir_Count > 0 Then

-        'we have records

-        ReDim allHir(1 To Hir_Count)

-        Dim index As Integer

-        index = 1

-        dbRecordset.Open getAll_Hir_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpHir As tHIRURGIA

-                 With tmpHir

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .operations_per_quarter = dbRecordset("operations_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_ambulator_clexan_20mg = dbRecordset("patients_ambulator_clexan_20mg")

-                    .patients_ambulator_clexan_40mg = dbRecordset("patients_ambulator_clexan_40mg")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                    .patients_stationar_clexan_20mg = dbRecordset("patients_stationar_clexan_20mg")

-                    .patients_stationar_clexan_40mg = dbRecordset("patients_stationar_clexan_40mg")

-                 End With

-                 

-                 allHir(index) = tmpHir

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE ID=" & objHir.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Hir_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbTer
->>>>>>
-Attribute VB_Name = "dbTer"

-Option Explicit

-

-Public Type tTERAPIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objTer.ID <> 0 then updatre else insert

-Sub Insert_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objTer.id <> 0 Then

-        dbUpdate_Ter_Record dbConnection, objTer

-    Else

-        dbInsert_Ter_Record dbConnection, objTer

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Ter_RecordsByLPU_ID(ByRef allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Ter_RecordsByLPU_ID = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, allTer, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Ter_Record dbConnection, objTer

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objTer.ID <> 0 then updatre else insert

-

-Sub dbInsert_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_ter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objTer

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objTer.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim Update_SQL As String

-    

-    With objTer

-        Update_SQL = "UPDATE lpu_ter SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_Ter_RecordsbyLPU_ID(dbConnection As Object, allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Ter_SQL As String

-    Dim getAll_Ter_SQL As String

-    Dim Ter_Count As Long

-    Ter_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Ter_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Ter_Count = dbRecordset("TER_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Ter_RecordsbyLPU_ID = Ter_Count

-    

-    If Ter_Count > 0 Then

-        'we have records

-        ReDim allTer(1 To Ter_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_Ter_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpTer As tTERAPIA

-                 With tmpTer

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 allTer(index) = tmpTer

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE ID=" & objTer.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Ter_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-mLPU_LIST
->>>>>>
-Attribute VB_Name = "mLPU_LIST"

-Option Explicit

-

-Public Const CINP_AREA As String = "B12"

-Public Const CLPU_NAME As Integer = 0

-Public Const CLPU_NAME1 As Integer = 1

-Public Const CLPU_NAME2 As Integer = 2

-Public Const CLPU_ID As Integer = 3

-Public Const CLPU_BEDS As Integer = 4

-Public Const CLPU_NFG As Integer = 5

-Public Const CLPU_NMG As Integer = 6

-Public Const CLPU_HIR As Integer = 7

-Public Const CLPU_TER As Integer = 8

-Public Const CLPU_CAR As Integer = 9

-Public Const CLPU_FACT As Integer = 10

-Public Const CLPU_PLAN As Integer = 11

-Public Const CLPU_PAT_LPU As Integer = 16

-Public Const CLPU_BDGT As Integer = 17

-Public Const CLPU_PAT_ALL As Integer = 16

-

-

-

-Sub EditLPU(cLPU As tLPU, ent_date As String)

-    NoFunc

-End Sub

-

-Sub Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-

-End Sub

-

-Sub Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btLPU_DEL_IT()

-    Dim cLPU As tLPU

-    Dim ent_date As String

-    Dim delete_all As Integer

-    Dim dlg_del As dlg_LPU_delete

-

-    With Worksheets("LPU_LIST")

-        ent_date = .Range("ent_date")

-        cLPU.id = .getCurrentLPU_ID()

-    End With

-

-    If cLPU.id = 0 Then

-        MsgBox "Укажите удаляемый объект", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    cLPU = Get_LPU_Record(cLPU.id)

-

-    Set dlg_del = New dlg_LPU_delete

-    With dlg_del

-        .chbDeleteQTR.Value = True

-        .chbDeleteAll.Value = False

-        .lComment = ent_date & ": Удаление ЛПУ '" _

-        & cLPU.name & "', расположенного по адресу:" _

-        & cLPU.address & " не разрешено."

-        .Show

-    End With

-End Sub

-

-Sub btLPU_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        

-        Wks_select .Range("ret_addr")

-    End With

-

-End Sub

-

-

-Sub btLPU_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim lpu_id As Long

-

-    i = Worksheets(VAR_SHEET).Range("QTR_ACTION").Value

-    With Worksheets("LPU_LIST")

-        ent_date = .getEnt_date()

-

-

-        lpu_id = .getCurrentLPU_ID

-        If lpu_id = 0 And i <> 6 Then

-            i = 1

-        End If

-        Select Case i

-            Case 1

-                .SelectLPU_NAME lpu_id, ent_date

-                .Range("JUMP") = ""

-            Case 2

-                .SelectLPU_BDGT lpu_id, ent_date

-                .Range("JUMP") = "LPU_BDGT"

-            Case 3

-                .SelectLPU_HIR lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_HIR"

-

-            Case 4

-                .SelectLPU_TER lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_TER"

-

-            Case 5

-                .SelectLPU_C_ACS lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        End Select

-    End With

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-dbQTR
->>>>>>
-Attribute VB_Name = "dbQTR"

-Option Explicit

-

-Public Type tQTR

-    id As Long

-    entry_date As String

-    rep_id As Long

-    sale_PLAN As Long

-    ClxnH20mg As Long

-    ClxnH40mg As Long

-    ClxnT40mg As Long

-    ClxnC_IM As Long

-    ClxnC_ACS As Long

-End Type

-

-Function Get_QTR_Record(ByVal QTR_ID As Long) As tQTR

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_QTR_Record = dbGet_QTR_Record(dbConnection, QTR_ID)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_Record(dbConnection As Object, ByVal QTR_ID As Long) As tQTR

-    

-    Dim sql As String

-    Dim objQTR As tQTR

-    

-    With objQTR

-        .ClxnC_ACS = 0

-        .ClxnC_IM = 0

-        .ClxnH20mg = 0

-        .ClxnH40mg = 0

-        .ClxnT40mg = 0

-        .entry_date = ""

-        .id = QTR_ID

-    End With

-    

-    sql = "SELECT * FROM quarter WHERE id=" & QTR_ID

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objQTR.entry_date = dbRecordset("entry_date")

-        objQTR.rep_id = dbRecordset("rep_id")

-        objQTR.sale_PLAN = dbRecordset("sale_plan")

-        objQTR.ClxnH20mg = dbRecordset("ClxnH20mg")

-        objQTR.ClxnH40mg = dbRecordset("ClxnH40mg")

-        objQTR.ClxnT40mg = dbRecordset("ClxnT40mg")

-        objQTR.ClxnC_IM = dbRecordset("ClxnC_IM")

-        objQTR.ClxnC_ACS = dbRecordset("ClxnC_ACS")

-        objQTR.id = dbRecordset("id")

-    End If

-    

-    dbGet_QTR_Record = objQTR

-

-End Function

-

-

-Function Get_QTR_Record_by_REP(ent_date As String, rep_id As Long) As tQTR

-    Dim dbConnection As Object

-    Dim allQTR() As tQTR

-    Dim i As Long

-

-    dbOpenConnection dbConnection

-

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id)

-    If i <> 0 Then

-        Get_QTR_Record_by_REP = allQTR(1)

-    End If

-

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTR_Records_by_REP(ByRef all_QTR() As tQTR, ent_date As String, rep_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-

-    GetAll_QTR_Records_by_REP = dbGetAll_QTR_Records_By_REP(dbConnection, all_QTR, ent_date, rep_id)

-

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGetAll_QTR_Records_By_REP(dbConnection As Object, all_QTR() As tQTR, ent_date As String, rep_id As Long) As Integer

-

-    Dim getCount_QTR_SQL As String

-    Dim getAll_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter " & _

-    "WHERE entry_date like '" & ent_date & "' AND rep_id=" & rep_id

-    getAll_QTR_SQL = "SELECT * FROM quarter " & _

-    "WHERE entry_date like '" & ent_date & "' AND rep_id=" & rep_id & " ORDER BY entry_date"

-

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-

-    dbRecordset.Close

-

-    dbGetAll_QTR_Records_By_REP = QTR_Count

-

-    If QTR_Count > 0 Then

-        'we have records

-        ReDim all_QTR(1 To QTR_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTR_SQL, dbConnection

-

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTR As tQTR

-                 With tmp_QTR

-                    .entry_date = dbRecordset("entry_date")

-                    .rep_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .ClxnH20mg = dbRecordset("ClxnH20mg")

-                    .ClxnH40mg = dbRecordset("ClxnH40mg")

-                    .ClxnT40mg = dbRecordset("ClxnT40mg")

-                    .ClxnC_IM = dbRecordset("ClxnC_IM")

-                    .ClxnC_ACS = dbRecordset("ClxnC_ACS")

-                    .id = dbRecordset("id")

-                 End With

-

-                 all_QTR(index) = tmp_QTR

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-cdbQTR
->>>>>>
-Attribute VB_Name = "cdbQTR"

-Option Explicit

-

-Public Type tQTR_COMMON

-    qtr As tQTR

-    i_lcd As Long           ' число ЛПУ в СПИСКЕ

-    lcd() As tLPU_COMMON    ' список ЛПУ

-    c_beds As Long          ' сумма коек

-    c_bdgt_NFG As Long      ' общий бюджет на НФГ

-    c_bdgt_NMG As Long      ' общий бюджет на НМГ

-    c_bdgt_LPU As Long      ' общий бюджет на гепарины

-    c_sale_PLAN As Long     ' план продаж репа

-    c_sale_ALL As Long      ' продажи

-    c_sale_HIR As Long      ' в хирургии

-    c_sale_TER  As Long     ' в терапии

-    c_sale_CRD  As Long     ' в кардиологии

-    c_pat_HIR   As Long     ' пациенты

-    c_pat_TER   As Long     '

-    c_pat_CRD   As Long     '

-    c_pat_ALL   As Long     '

-    c_pat_LPU   As Long     ' Всего операций

-End Type

-

-Function GetLastQTR_fromDB() As String

-    Dim dbConnection As Object

-    Dim getCount_QTR_SQL As String

-    Dim getLast_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter"

-    getLast_QTR_SQL = "SELECT MAX(entry_date) as ent_date FROM quarter"

-    

-    dbOpenConnection dbConnection

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    If QTR_Count > 0 Then

-        'we have records

-        dbRecordset.Open getLast_QTR_SQL, dbConnection

-        getLast_QTR_SQL = dbRecordset("ent_date")

-    End If

-    GetLastQTR_fromDB = getLast_QTR_SQL

-    dbCloseConnection dbConnection

-End Function

-

-Function Get_QTR_CommonList_by_REP(ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_QTR_CommonList_by_REP = dbGet_QTR_CommonList_by_REP(dbConnection, qcd, ent_date, rep_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_CommonList_by_REP(dbConnection As Object, ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim allQTR() As tQTR

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id)

-    dbGet_QTR_CommonList_by_REP = i

-    If i > 0 Then

-        ReDim qcd(i)

-        For i = 1 To UBound(allQTR)

-            With qcd(i)

-                .qtr = allQTR(i)

-                .c_beds = 0

-                .c_bdgt_NFG = 0

-                .c_bdgt_NMG = 0

-                .c_bdgt_LPU = 0

-                .c_sale_PLAN = 0

-                .c_pat_HIR = 0

-                .c_pat_TER = 0

-                .c_pat_CRD = 0

-                .c_pat_ALL = 0

-                .c_sale_HIR = 0

-                .c_sale_TER = 0

-                .c_sale_CRD = 0

-                .c_sale_ALL = 0

-                .c_pat_LPU = 0

-                

-                j = dbGet_LPU_CommonQTR(dbConnection, .lcd, .qtr)

-                .i_lcd = j

-                If j > 0 Then

-                    For j = 1 To UBound(.lcd)

-                        .c_beds = .c_beds + .lcd(j).lpu.beds

-                        .c_bdgt_NFG = .c_bdgt_NFG + .lcd(j).bdgt.bdgt_NFG

-                        .c_bdgt_NMG = .c_bdgt_NMG + .lcd(j).bdgt.bdgt_NMG

-                        .c_bdgt_LPU = .c_bdgt_LPU + .lcd(j).bdgt_LPU

-                        .c_sale_PLAN = .c_sale_PLAN + .lcd(j).bdgt.sale_PLAN

-                        .c_pat_HIR = .c_pat_HIR + .lcd(j).pat_HIR

-                        .c_pat_TER = .c_pat_TER + .lcd(j).pat_TER

-                        .c_pat_CRD = .c_pat_CRD + .lcd(j).pat_CRD

-                        .c_pat_ALL = .c_pat_ALL + .lcd(j).pat_ALL

-                        .c_sale_HIR = .c_sale_HIR + .lcd(j).sale_HIR

-                        .c_sale_TER = .c_sale_TER + .lcd(j).sale_TER

-                        .c_sale_CRD = .c_sale_CRD + .lcd(j).sale_CRD

-                        .c_sale_ALL = .c_sale_ALL + .lcd(j).sale_ALL

-                        .c_pat_LPU = .c_pat_LPU + .lcd(j).pat_LPU

-                    Next j

-                    

-                End If

-            End With

-        Next i

-    End If

-End Function

-

-Function GetLastQtr() As String

-    Dim s As String

-    Dim r As Range

-    Set r = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Do While r.Cells(1, 1) <> ""

-        s = r.Cells(1, 1)

-        Set r = r.Cells.Offset(1, 0)

-    Loop

-    GetLastQtr = s

-End Function

-

-Function GetNextQTR(ent_date As String) As String

-    Dim rd As Range

-    Dim idx As Integer

-    Dim b As Variant

-    Dim dlg As dlg_newQTR

-    Set dlg = New dlg_newQTR

-    

-    If ent_date = "" Then

-        Dim ir As Variant

-        idx = 0

-        dlg.Show

-        b = dlg.Tag

-            

-        If IsNumeric(b) Then

-            GetNextQTR = dlg.cbQTR

-        Else

-            GetNextQTR = ""

-        End If

-    Else

-        Set rd = Worksheets(VAR_SHEET).Range("Date_Lst")

-        idx = WorksheetFunction.Match(ent_date, rd, 0)

-        GetNextQTR = WorksheetFunction.index(rd, idx + 1, 1)

-    End If

-End Function

-<<<<<<
-======================
-mRestView
->>>>>>
-Attribute VB_Name = "mRestView"

-Option Explicit

-

-Sub xlRestoreView()

-Attribute xlRestoreView.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute xlRestoreView.VB_ProcData.VB_Invoke_Func = " \n14"

-    With Application

-        .CommandBars("Standard").Visible = True

-        .CommandBars("Formatting").Visible = True

-        .DisplayFormulaBar = True

-        .DisplayStatusBar = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = True

-    End With

-End Sub

-<<<<<<
-======================
-dlg_newQTR
->>>>>>
-Attribute VB_Name = "dlg_newQTR"

-Attribute VB_Base = "0{3EA3C15A-5493-445F-9858-2F241E7D6CEA}{849C1FE1-631A-485D-BE54-A7B73124582C}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mDec2TS
->>>>>>
-Attribute VB_Name = "mDec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-CHRT_LPU_BBL
->>>>>>
-Attribute VB_Name = "CHRT_LPU_BBL"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Unprotect

-    Range("view_key") = True

-    On Error Resume Next

-    ChangeLabels

-    Range("A1").Select

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Unprotect

-    Dim s As String

-    s = Range("ret_addr")

-    Protect UserInterfaceOnly:=True

-    Wks_select (s)

-End Sub

-

-Sub BCLabelChng_Click()

-    Unprotect

-    If Range("view_key") Then

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать названия"

-    Else

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать объемы"

-    End If

-    Range("view_key") = Not Range("view_key")

-    ChangeLabels

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub ChangeLabels()

-    Dim i As Integer

-    Dim offset_text As Integer

-    Dim src As Range

-    Set src = Range("CHRT_BBL_DATA")

-    

-    offset_text = 3

-    If Range("view_key") Then

-        offset_text = 4

-    End If

-    

-    With ChartObjects(1).Chart

-        With .SeriesCollection(1)

-            For i = 1 To .Points.count

-                On Error GoTo ExitLabel

-                .Points(i).DataLabel.Characters.Text = Format(src.Cells(i, offset_text))

-            Next i

-        End With

-    End With

-ExitLabel:

-End Sub

-

-<<<<<<
-======================
-CHRT_PAT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PAT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-<<<<<<
-======================
-CHRT_PAT_LPU
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_nextQTR
->>>>>>
-Attribute VB_Name = "dlg_nextQTR"

-Attribute VB_Base = "0{B85FF7F1-50C0-4433-BC6F-8A0F2C9BDDDA}{EC2D2B9E-9ED2-4005-A1E9-EF0626D3B7E7}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-cdbLPU
->>>>>>
-Attribute VB_Name = "cdbLPU"

-Option Explicit

-

-Public Type tLPU_COMMON

-    lpu As tLPU

-    bdgt As tBUDGET

-    i_hir As Long

-    hir() As tHIRURGIA

-    i_ter As Long

-    ter() As tTERAPIA

-    i_ACS As Long

-    ACS() As tACS

-    bdgt_LPU As Long

-    sale_HIR As Long

-    sale_TER As Long

-    sale_CRD As Long

-    sale_ALL As Long

-    pat_HIR As Long

-    pat_TER As Long

-    pat_CRD As Long

-    pat_ALL As Long     ' Сумма всех пациентов на клексане

-    pat_LPU As Long     ' Число потенциальных пациентов для продаж клексана

-End Type

-

-Function Get_LPU_CommonQTR(ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    Get_LPU_CommonQTR = dbGet_LPU_CommonQTR(dbConnection, lcd, objQTR)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_CommonQTR(dbConnection As Object, ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    i = dbGetAll_LPU_byQTR(dbConnection, allLPU, objQTR.entry_date, objQTR.rep_id)

-    dbGet_LPU_CommonQTR = i

-    If i > 0 Then

-        ReDim lcd(i)

-        For i = 1 To UBound(allLPU)

-            dbGet_LPU_Common dbConnection, lcd(i), allLPU(i), objQTR

-        Next i

-    End If

-End Function

-

-Sub Get_LPU_Common(ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    dbGet_LPU_Common dbConnection, lcd, cLPU, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbGet_LPU_Common(dbConnection As Object, ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-

-    lcd.lpu = cLPU

-    lcd.bdgt = dbGet_BDGT_Record(dbConnection, cLPU.id, objQTR.entry_date)

-    lcd.i_hir = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, lcd.hir, cLPU.id, objQTR.entry_date)

-    lcd.i_ter = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, lcd.ter, cLPU.id, objQTR.entry_date)

-    lcd.i_ACS = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, lcd.ACS, cLPU.id, objQTR.entry_date)

-    With lcd

-        .bdgt_LPU = .bdgt.bdgt_NFG + .bdgt.bdgt_NMG

-        .pat_LPU = 0

-        If .i_hir > 0 Then

-            .pat_HIR = .hir(1).patients_ambulator_clexan + .hir(1).patients_stationar_clexan

-            .sale_HIR = objQTR.ClxnH20mg * (.hir(1).patients_ambulator_clexan_20mg + .hir(1).patients_stationar_clexan_20mg)

-            .sale_HIR = .sale_HIR + objQTR.ClxnH40mg * (.hir(1).patients_ambulator_clexan_40mg + .hir(1).patients_stationar_clexan_40mg)

-            .pat_LPU = .pat_LPU + .hir(1).operations_per_quarter

-        End If

-        If .i_ter > 0 Then

-            .pat_TER = .ter(1).patients_ambulator_clexan + .ter(1).patients_stationar_clexan

-            .sale_TER = .pat_TER * objQTR.ClxnT40mg

-            .pat_LPU = .pat_LPU + .ter(1).patients_per_quarter

-        End If

-        If .i_ACS > 0 Then

-            .pat_CRD = .ACS(1).patients_stationar_clexan

-            .sale_CRD = .pat_CRD * objQTR.ClxnC_ACS

-            .pat_LPU = .pat_LPU + .ACS(1).patients_per_quarter

-        End If

-        .pat_ALL = .pat_HIR + .pat_TER + .pat_CRD

-        .sale_ALL = .sale_HIR + .sale_TER + .sale_CRD

-    End With

-End Sub

-

-<<<<<<
-======================
-CHRT_PIE
->>>>>>
-Attribute VB_Name = "CHRT_PIE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    

-    Unprotect

-    

-    On Error Resume Next

-    

-    Range("P5:Q24").Sort _

-        Key1:=Range("Q5"), _

-        Order1:=xlDescending, _

-        Header:=xlGuess, _

-        OrderCustom:=1, _

-        MatchCase:=False, _

-        Orientation:=xlTopToBottom

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PLN_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PLN_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_BDGT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_BDGT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_LPU_delete
->>>>>>
-Attribute VB_Name = "dlg_LPU_delete"

-Attribute VB_Base = "0{EC96F2D1-337D-47DF-B0F1-A6DF3F8CD5CC}{7EB42A63-CBFC-45B0-AE4D-C3E3D8FE7420}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlg_Mail
->>>>>>
-Attribute VB_Name = "dlg_Mail"

-Attribute VB_Base = "0{7B669454-C2AA-4FDF-8311-7ADEDDEF3FF3}{D07A0A02-4923-46C8-8EE8-62769243087D}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dbREP_id
->>>>>>
-Attribute VB_Name = "dbREP_id"

-Public Type tREPID

-    rep_id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function GetAll_REPID_Records_by_QTR(ByRef all_REPID() As tREPID, ent_date As String) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_REPID_Records_by_QTR = dbGetAll_REPID_Records_by_QTR(dbConnection, all_REPID, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-Function Get_REPID_Record(id As Long) As tREPID

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REPID_Record = dbGet_REPID_Record(dbConnection, id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_REPID_Records(ByRef all_REPID() As tREPID) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_REPID_Records = dbGetAll_REPID_Records(dbConnection, all_REPID)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function dbGet_REPID_Record(dbConnection As Object, id As Long) As tREPID

-    

-    Dim sql As String

-    Dim objREPID As tREPID

-    

-    objREPID.FirstName = ""

-    objREPID.LastName = ""

-    objREPID.Region = 0

-    objREPID.City = 0

-    sql = "SELECT rep_id, firstname, lastname, region, city FROM " & _

-          "rep WHERE rep_id=" & id

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREPID.rep_id = dbRecordset("rep_id")

-        objREPID.FirstName = dbRecordset("firstname")

-        objREPID.LastName = dbRecordset("lastname")

-        objREPID.Region = dbRecordset("region")

-        objREPID.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REPID_Record = objREPID

-        

-End Function

-

-Function dbGetAll_REPID_Records_by_QTR(dbConnection As Object, ByRef all_REPID() As tREPID, ent_date As String) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    Dim Where As String

-    

-    REPID_Count = 0

-    Where = " WHERE lpu_budget.entry_date like '" & ent_date & "' " & _

-        "AND rep.rep_id=lpu.rep_id AND lpu.id=lpu_budget.lpu_id"

-    

-    

-    getAll_REPID_SQL = "SELECT distinct rep.* FROM rep, lpu, lpu_budget" & Where

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM (" & getAll_REPID_SQL & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records_by_QTR = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Function dbGetAll_REPID_Records(dbConnection As Object, ByRef all_REPID() As tREPID) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    REPID_Count = 0

-    

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM rep"

-    getAll_REPID_SQL = "SELECT * FROM rep"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-cdbExport
->>>>>>
-Attribute VB_Name = "cdbExport"

-Option Explicit

-

-Function GetDBSN() As String

-    Dim n As Long

-    Randomize Timer

-    n = Int((100000000 - 1000000 + 1) * Rnd + 1000000)

-    GetDBSN = Dec2ThirtySix(n)

-End Function

-

-Sub dbExport()

-    Dim src_file As String

-    Dim dst_file As String

-    

-    On Error GoTo ErrHandler

-    

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & GetLastQTR_fromDB & "_" & GetDBSN() & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Данные экспортированы в файл:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для передачи", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-Exit Sub

-

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-<<<<<<
-======================
-mRegs
->>>>>>
-Attribute VB_Name = "mRegs"

-Option Explicit

-

-Function GetRegionName(idx As Integer) As String

-    GetRegionName = Worksheets(REGS_SHEET).Range("LST_REGIONS").Cells(idx + 1, 1).Text

-End Function

-

-Function GetCityName(idx_reg As Integer, idx_city As Integer) As String

-    GetCityName = Worksheets(REGS_SHEET).Range("CITY_TABLES").Offset(idx_city + 1, idx_reg * 2).Text

-End Function

-

-Sub testReg()

-    Dim r As Integer

-    Dim c As Integer

-    Dim s As String

-    

-    r = 3

-    c = 3

-    s = GetRegionName(r)

-    s = s & ", " & GetCityName(r, c)

-    MsgBox s

-End Sub

-

-<<<<<<
-======================
-RM_QTR
->>>>>>
-Attribute VB_Name = "RM_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CRGN_QT As Integer = 0

-Const CRGN_PLN As Integer = 2

-Const CRGN_FCT As Integer = 3

-Const CRGN_BDG As Integer = 4

-Const CRGN_LPU As Integer = 5

-Const CRGN_REP As Integer = 6

-Const CRGN_HIR As Integer = 7

-Const CRGN_TER As Integer = 8

-Const CRGN_CRD As Integer = 9

-Const CRGN_CLXN_BDG As Integer = 10

-Const CRGN_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub ClearRMName()

-    Unprotect

-    Range("D4") = ""

-    Range("D5") = ""

-    Range("H4") = ""

-End Sub

-

-Sub update_history()

-    Dim objRGN() As tREGION

-    Dim i As Long

-    Dim r As Range

-    Dim cRMan As tREGMAN

-

-    cRMan = Get_REGMAN_Record

-    

-    Range("D4") = cRMan.LastName

-    Range("D5") = cRMan.FirstName

-

-    Range("H4") = GetRegionName(cRMan.Region)

-    

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetRGN_COMM_DATA(objRGN)

-    

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objRGN)

-            r.Offset(i - 1, CRGN_QT) = objRGN(i).ent_date

-            r.Offset(i - 1, CRGN_FCT) = objRGN(i).total_SALE

-            r.Offset(i - 1, CRGN_PLN) = objRGN(i).sale_PLAN

-            r.Offset(i - 1, CRGN_BDG) = objRGN(i).total_BDGT

-            r.Offset(i - 1, CRGN_LPU) = objRGN(i).total_LPU

-            r.Offset(i - 1, CRGN_REP) = objRGN(i).total_REP

-            r.Offset(i - 1, CRGN_HIR) = objRGN(i).total_HIR

-            r.Offset(i - 1, CRGN_TER) = objRGN(i).total_TER

-            r.Offset(i - 1, CRGN_CRD) = objRGN(i).total_ACS

-            If objRGN(i).total_BDGT <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_BDG) = objRGN(i).total_SALE / objRGN(i).total_BDGT

-            End If

-            If objRGN(i).total_BDGT_NMG <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_NMG) = objRGN(i).total_SALE / objRGN(i).total_BDGT_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRGN_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRM_QtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR_RM

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR_RM

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR_RM

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = RM_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect UserInterfaceOnly:=True

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CRGN_QT + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    If r = "" Then

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = currRange.address

-        With Worksheets("REP_LIST")

-            .Range("ret_addr") = "RM_QTR"

-            .Range("ent_date") = r

-            .Range("VIEW_ONLY") = True

-        End With

-    End If

-    Cancel = True

-    btRM_QTR_Do_IT

-End Sub

-

-<<<<<<
-======================
-dbREG_MAN
->>>>>>
-Attribute VB_Name = "dbREG_MAN"

-Option Explicit

-

-Public Type tREGMAN

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function Get_REGMAN_Record() As tREGMAN

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REGMAN_Record = dbGet_REGMAN_Record(dbConnection)

-    dbCloseConnection dbConnection

-End Function

-

-Sub Set_REGMAN_Record(cREGMAN As tREGMAN)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbSet_REGMAN_Record dbConnection, cREGMAN

-    dbCloseConnection dbConnection

-End Sub

-

-Sub ReSet_REGMAN_Record()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbReSet_REGMAN_Record dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_REGMAN_Record(dbConnection As Object) As tREGMAN

-    

-    Dim sql As String

-    Dim objREGMAN As tREGMAN

-    

-    objREGMAN.FirstName = ""

-    objREGMAN.LastName = ""

-    objREGMAN.Region = 0

-    objREGMAN.City = 0

-    sql = "SELECT firstname, lastname, region, city FROM " & _

-          "reg_man"

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREGMAN.FirstName = dbRecordset("firstname")

-        objREGMAN.LastName = dbRecordset("lastname")

-        objREGMAN.Region = dbRecordset("region")

-        objREGMAN.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REGMAN_Record = objREGMAN

-        

-End Function

-

-Public Sub dbSet_REGMAN_Record(dbConnection As Object, ByRef objREGMAN As tREGMAN)

-  

-    Dim DeleteSQL As String

-    Dim InsertSQL As String

-    

-    DeleteSQL = "DELETE FROM reg_man"

-    InsertSQL = "INSERT INTO reg_man (firstname, lastname, region, city) VALUES (" & _

-    "'" & objREGMAN.FirstName & "', " & _

-    "'" & objREGMAN.LastName & "', " & _

-    objREGMAN.Region & ", " & _

-    objREGMAN.City & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    dbRecordset.Open InsertSQL, dbConnection

-       

-End Sub

-

-Public Sub dbReSet_REGMAN_Record(dbConnection As Object)

-  

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM reg_man"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    

-End Sub

-

-

-<<<<<<
-======================
-dbDatabaseMerge
->>>>>>
-Attribute VB_Name = "dbDatabaseMerge"

-Option Explicit

-

-Public Type tDBFIELD

-    name As String

-End Type

-

-Public Type tDBTABLE

-    name As String

-    field() As tDBFIELD

-End Type

-

-

-Function dbGetConnection(dbAccessFileFullPath As String) As Object

-    Dim dbConnection As Object

-    Dim dbAccessFilePasswd As String

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFileFullPath & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    Set dbGetConnection = dbConnection

-End Function

-

-Sub dbCloseOpenedConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteOpenedSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-Function dbMergeREP(from_dbConnection As Object, to_dbConnection As Object) As Long

-

-    Dim getRecordset As Object

-    Dim getREPData_SQL As String

-    Dim REP_fn As String

-    Dim REP_ln As String

-    Dim REP_region As String

-    Dim REP_city As String

-

-

-    getREPData_SQL = "SELECT * FROM rep"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getREPData_SQL, from_dbConnection

-        

-        If Not getRecordset.BOF Then

-            REP_fn = getRecordset("firstname")

-            REP_ln = getRecordset("lastname")

-            REP_city = getRecordset("city")

-            REP_region = getRecordset("region")

-        Else

-            MsgBox "There is no information about rep! This database cannot be merged!!!"

-            dbMergeREP = -1

-            Exit Function

-        End If

-    

-    Dim insertRecordset As Object

-    Set insertRecordset = CreateObject("ADODB.Recordset")

-        

-    insertRecordset.Open "rep", to_dbConnection, 2, 2

-    insertRecordset.addnew

-        

-    insertRecordset("firstname") = REP_fn

-    insertRecordset("lastname") = REP_ln

-    insertRecordset("region") = REP_region

-    insertRecordset("city") = REP_city

-    insertRecordset.Update

-    insertRecordset.MoveLast

-    'new ID

-    

-    dbMergeREP = insertRecordset("rep_id")

-    

-End Function

-

-Sub dbMergeLPU(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getLPU_SQL As String

-    Dim getRecordset As Object

-    Dim idx As Long

-    idx = 1

-    

-    getLPU_SQL = "SELECT * FROM lpu"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getLPU_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            ReDim Preserve objLPU(1 To idx)

-            objLPU(idx).old_lpu_id = getRecordset("id")

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "lpu", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("name") = getRecordset("name")

-            insRS("address") = getRecordset("address")

-            insRS("beds") = getRecordset("beds")

-            insRS.Update

-            insRS.MoveLast

-            'new ID

-            

-            objLPU(idx).new_lpu_id = insRS("id")

-                        

-            idx = idx + 1

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about LPU! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-

-Sub dbMergeLPURelated(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object)

-

-    ' 6 tables to change

-    Dim tables(1 To 5) As tDBTABLE

-    

-    'lpu budget

-    tables(1).name = "lpu_budget"

-    ReDim tables(1).field(1 To 4)

-    

-    tables(1).field(1).name = "entry_date"

-    tables(1).field(2).name = "bdgt_NMG"

-    tables(1).field(3).name = "bdgt_NFG"

-    tables(1).field(4).name = "sale_PLAN"

-    

-    'lpu hir

-    tables(2).name = "lpu_hir"

-    ReDim tables(2).field(1 To 13)

-    

-    tables(2).field(1).name = "entry_date"

-    tables(2).field(2).name = "operations_per_quarter"

-    tables(2).field(3).name = "risk_percent"

-    tables(2).field(4).name = "patients_with_risk_ON"

-    tables(2).field(5).name = "patients_ambulator"

-    tables(2).field(6).name = "patients_ambulator_nmg"

-    tables(2).field(7).name = "patients_ambulator_clexan"

-    tables(2).field(8).name = "patients_ambulator_clexan_40mg"

-    tables(2).field(9).name = "patients_ambulator_clexan_20mg"

-    tables(2).field(10).name = "patients_stationar_nmg"

-    tables(2).field(11).name = "patients_stationar_clexan"

-    tables(2).field(12).name = "patients_stationar_clexan_40mg"

-    tables(2).field(13).name = "patients_stationar_clexan_20mg"

-    

-    

-    'lpu acs

-    tables(3).name = "lpu_acs"

-    ReDim tables(3).field(1 To 5)

-    

-    tables(3).field(1).name = "entry_date"

-    tables(3).field(2).name = "patients_with_geparins"

-    tables(3).field(3).name = "patients_per_quarter"

-    tables(3).field(4).name = "patients_stationar_nmg"

-    tables(3).field(5).name = "patients_stationar_clexan"

-    

-    'lpu acs

-    tables(4).name = "lpu_im"

-    ReDim tables(4).field(1 To 5)

-    

-    tables(4).field(1).name = "entry_date"

-    tables(4).field(2).name = "patients_with_geparins"

-    tables(4).field(3).name = "patients_per_quarter"

-    tables(4).field(4).name = "patients_stationar_nmg"

-    tables(4).field(5).name = "patients_stationar_clexan"

-    

-    

-    'lpu acs

-    tables(5).name = "lpu_ter"

-    ReDim tables(5).field(1 To 9)

-    

-    tables(5).field(1).name = "entry_date"

-    tables(5).field(2).name = "patients_per_quarter"

-    tables(5).field(3).name = "risk_percent"

-    tables(5).field(4).name = "patients_with_risk_ON"

-    tables(5).field(5).name = "patients_ambulator"

-    tables(5).field(6).name = "patients_ambulator_nmg"

-    tables(5).field(7).name = "patients_ambulator_clexan"

-    tables(5).field(8).name = "patients_stationar_nmg"

-    tables(5).field(9).name = "patients_stationar_clexan"

-    

-    

-    

-    Dim tbl_idx As Integer

-    

-    For tbl_idx = 1 To UBound(tables)

-        

-        Dim getSQL As String

-        Dim getRS As Object

-        

-        

-        

-        Set getRS = CreateObject("ADODB.Recordset")

-        

-        getSQL = "SELECT * FROM " & tables(tbl_idx).name

-        getRS.Open getSQL, from_db

-        

-        If Not getRS.BOF Then

-            Do While Not getRS.EOF

-                Dim insRS As Object

-                Set insRS = CreateObject("ADODB.Recordset")

-                

-                insRS.Open tables(tbl_idx).name, to_db, 2, 2

-                insRS.addnew

-                Dim fld_idx As Integer

-    

-                    For fld_idx = 1 To UBound(tables(tbl_idx).field)

-                        insRS(tables(tbl_idx).field(fld_idx).name) = getRS(tables(tbl_idx).field(fld_idx).name)

-                        insRS("lpu_id") = findNewLPU_IDByOld(objLPU, getRS("lpu_id"))

-                    Next fld_idx

-                    

-                insRS.Update

-                insRS.MoveLast

-                getRS.MoveNext

-            Loop

-        End If

-        

-        

-    Next tbl_idx

-

-End Sub

-

-Function findNewLPU_IDByOld(objLPU() As tLPUCONVERTION, old_id As Long)

-

-Dim i As Integer

-For i = 1 To UBound(objLPU)

-    If objLPU(i).old_lpu_id = old_id Then

-        findNewLPU_IDByOld = objLPU(i).new_lpu_id

-        Exit Function

-    End If

-Next i

-

-findNewLPU_IDByOld = -1

-End Function

-

-

-

-

-

-Sub dbMergeQTR(from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getQTR_SQL As String

-    Dim getRecordset As Object

-    

-    getQTR_SQL = "SELECT * FROM quarter"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getQTR_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "quarter", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("entry_date") = getRecordset("entry_date")

-            insRS("sale_plan") = getRecordset("sale_plan")

-            insRS("ClxnH20mg") = getRecordset("ClxnH20mg")

-            insRS("ClxnH40mg") = getRecordset("ClxnH40mg")

-            insRS("ClxnT40mg") = getRecordset("ClxnT40mg")

-            insRS("ClxnC_IM") = getRecordset("ClxnC_IM")

-            insRS("ClxnC_ACS") = getRecordset("ClxnC_ACS")

-            

-            

-            insRS.Update

-            

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about quarter budget! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-dbMerge
->>>>>>
-Attribute VB_Name = "dbMerge"

-Option Explicit

-

-Public Type tLPUCONVERTION

-    old_lpu_id As Long

-    new_lpu_id As Long

-End Type

-

-Sub Merge_BackUp_All_Data()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim time_stump As String

-    

-    On Error GoTo ErrHandler

-    

-    time_stump = Format(Date, "yy-mm-dd_") & Format(Time, "hh-mm")

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_BACKUPNAME & time_stump & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Старые данные сохранены в файле:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для восстановления данных в случае утери", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-    Exit Sub

-    

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-

-Sub Merge_Clear_All_Data(access_file_full_path As String)

-    

-    Dim db As Object

-    Dim tables_to_clear() As String

-    On Error GoTo ErrHandler

-    

-    ReDim tables_to_clear(1 To 8)

-    tables_to_clear(1) = "rep"

-    tables_to_clear(2) = "lpu"

-    tables_to_clear(3) = "lpu_budget"

-    tables_to_clear(4) = "lpu_hir"

-    tables_to_clear(5) = "lpu_ter"

-    tables_to_clear(6) = "lpu_acs"

-    tables_to_clear(7) = "lpu_im"

-    tables_to_clear(8) = "quarter"

-    

-    Set db = dbGetConnection(access_file_full_path)

-

-    Dim i As Integer

-    

-    For i = 1 To UBound(tables_to_clear)

-        

-        If tables_to_clear(i) <> "" Then

-            Dim Clear_SQL As String

-            Clear_SQL = "DELETE FROM " & tables_to_clear(i)

-            dbExecuteOpenedSQL db, Clear_SQL

-        Else

-            'do nothing or show message

-        End If

-    Next i

-    

-    dbCloseOpenedConnection db

-    Set db = Nothing

-    

-'    Dim Engine As Object

-'    Set Engine = CreateObject("JRO.JetEngine")

-'    Engine.CompactDatabase "Password=password;Data Source=" & access_file_full_path, _

-'    "Password=password;Data Source=c:\tmp\1.mdb"

-    

-Exit Sub

-

-ErrHandler:

-    MsgBox "something wrong: " & err.Description

-    Resume Next

-    

-End Sub

-

-Function MergeREP(from_file As String, to_file As String) As Long

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    Dim new_rep_id As Long

-

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    MergeREP = dbMergeREP(db1, db2)

-    'MsgBox "new rep ID is " & new_rep_id

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Function

-

-Sub MergeQTR(from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeQTR db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-

-Sub MergeLPU(objLPU() As tLPUCONVERTION, from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeLPU objLPU, db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-Sub MergeLPURelated(objLPU() As tLPUCONVERTION, from_file As String, to_file As String)

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    dbMergeLPURelated objLPU, db1, db2

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-

-End Sub

-

-Sub MergeGlobal(rep_files() As String, rm_file As String)

-

-    Dim i As Integer

-    'clear output file content

-    Merge_Clear_All_Data rm_file

-    

-    For i = 1 To UBound(rep_files)

-        

-        Dim rep_file As String

-        'setup input and output files

-        rep_file = rep_files(i)

-        

-        Dim new_rep_id As Long

-        ' insert REP data and get new rep_id

-        new_rep_id = MergeREP(rep_file, rm_file)

-        

-        Dim objLPU() As tLPUCONVERTION

-        'insert all LPU using new generated rep_id

-        'and populate objLPU old->new relation object

-        

-        MergeLPU objLPU, rep_file, rm_file, new_rep_id

-        'insert quarter data using new rep_id

-        MergeQTR rep_file, rm_file, new_rep_id

-        

-        

-        ' and.... insert all another data (5 tables excl version and hw)

-        'using objLPU old->new relation object

-        MergeLPURelated objLPU, rep_file, rm_file

-    

-    

-    Next i

-    

-End Sub

-

-Function GetDBList(MyPath() As String, ByRef dblist() As String) As Integer

-    Dim i As Integer

-    Dim MyName, MyMask

-    MyMask = MyPath(0) & MyPath(1) & PROGRAM_DATAEXT

-    i = 0

-    MyName = Dir(MyMask)      ' Retrieve the first entry.

-    Do While MyName <> ""    ' Start the loop.

-        ' Ignore the current directory and the encompassing directory.

-        If MyName <> "." And MyName <> ".." Then

-            ' Use bitwise comparison to make sure MyName is a directory.

-            i = i + 1

-            ReDim Preserve dblist(i)

-            dblist(i) = MyPath(0) & MyName

-        End If

-        MyName = Dir    ' Get next entry.

-    Loop

-    GetDBList = i

-End Function

-

-<<<<<<
-======================
-dlgImprtDB
->>>>>>
-Attribute VB_Name = "dlgImprtDB"

-Attribute VB_Base = "0{D5892870-2C88-40C8-A817-AC9B1CF37C2C}{9853EBEA-4E48-41F9-89C0-6F753EB6A0C2}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Private Sub btSelAll_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = True

-    Next i

-End Sub

-

-Private Sub btUnselect_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = False

-    Next i

-End Sub

-<<<<<<
-======================
-dbQTR_RM
->>>>>>
-Attribute VB_Name = "dbQTR_RM"

-Option Explicit

-

-Public Type tQTRRM

-    id As Long

-    entry_date As String

-    rm_id As Long

-    sale_PLAN As Long

-End Type

-

-

-Sub Insert_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objQTRRM.id <> 0 Then

-        dbUpdate_QTRRM_Record dbConnection, objQTRRM

-    Else

-        dbInsert_QTRRM_Record dbConnection, objQTRRM

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-Function Get_QTRRM_Record(ent_date As String) As tQTRRM

-    Dim dbConnection As Object

-    Dim allQTRRM() As tQTRRM

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    i = dbGetAll_QTRRM_Records(dbConnection, allQTRRM, ent_date)

-    If i <> 0 Then

-        Get_QTRRM_Record = allQTRRM(1)

-    End If

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTRRM_Records(ByRef all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_QTRRM_Records = dbGetAll_QTRRM_Records(dbConnection, all_QTRRM, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_QTRRM_Record dbConnection, objQTRRM

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objQTRRM.ID <> 0 then updatre else insert

-Sub dbInsert_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "quarter_rm", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objQTRRM

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("sale_plan") = .sale_PLAN

-        dbRecordset("rm_id") = .rm_id

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objQTRRM.id = dbRecordset("id")

-

-End Sub

-

-Sub dbUpdate_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim Update_SQL As String

-    

-    With objQTRRM

-        Update_SQL = "UPDATE quarter_rm SET " & _

-            "entry_date='" & .entry_date & "'" & "," & _

-            "rm_id=" & .rm_id & "," & _

-            "sale_plan=" & .sale_PLAN & "," & _

-            " WHERE id=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if ent_date = % then all_records

-Function dbGetAll_QTRRM_Records(dbConnection As Object, all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    

-    Dim getCount_QTRRM_SQL As String

-    Dim getAll_QTRRM_SQL As String

-    Dim QTRRM_Count As Long

-    QTRRM_Count = 0

-    

-    getCount_QTRRM_SQL = "SELECT COUNT(*) AS QTRRM_TOTAL FROM quarter_rm WHERE entry_date like '" & ent_date & "'"

-    getAll_QTRRM_SQL = "SELECT * FROM quarter_rm WHERE entry_date like '" & ent_date & "' ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTRRM_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTRRM_Count = dbRecordset("QTRRM_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_QTRRM_Records = QTRRM_Count

-    

-    If QTRRM_Count > 0 Then

-        'we have records

-        ReDim all_QTRRM(1 To QTRRM_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTRRM_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTRRM As tQTRRM

-                 With tmp_QTRRM

-                    .entry_date = dbRecordset("entry_date")

-                    .rm_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .id = dbRecordset("id")

-                 End With

-                 

-                 all_QTRRM(index) = tmp_QTRRM

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM quarter_rm " & _

-    "WHERE id=" & objQTRRM.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-    

-    'delete related budget entries

-    MsgBox "remember delete related"

-'    dbDelete_BDGT_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Hir_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Ter_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_ACS_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-       

-End Sub

-

-

-<<<<<<
-======================
-REP_LIST
->>>>>>
-Attribute VB_Name = "REP_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentREP_ID() As Long

-    Dim r As Range

-

-    With Worksheets("REP_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CREP_ID)

-    End With

-

-    getCurrentREP_ID = r

-End Function

-

-Public Sub REP_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Rep_Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Rep_Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Rep_Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Rep_Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectREP_LPU(rep_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim r_id As Long

-    

-    Range("JUMP") = "LPU_LIST"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-        .Range("ent_date") = ent_date

-    End With

-End Sub

-

-Public Sub SelectREP_QTR(rep_id As Long)

-    Dim vo As Boolean

-    Dim r_id As Long

-    

-    Range("JUMP") = "REP_QTR"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("REP_QTR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateREPList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim rep_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CREP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CREP_AREA).row, CREP_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    rep_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CREP_AREA).Column

-    

-    If i < 4 Then

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 1

-    Else

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 2

-    End If

-    

-    If rep_id = 0 Then

-        Range("LAST_FOCUS") = Range(CREP_AREA).address

-    End If

-

-    If rep_id = 0 Then

-        i = CREP_NAME

-        Range("JUMP") = ""

-    Else

-        btREP_LIST_DO_IT

-    End If

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateREPList()

-    Dim rcd() As tREPID_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-

-    ent_date = getEnt_date

-

-    i = Get_REP_CommonList_by_QTR(rcd, ent_date)

-

-    With ThisWorkbook.Worksheets("REP_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(rcd)

-            r.Offset(i - 1, CREP_NAME) = rcd(i).rep.FirstName & " " & rcd(i).rep.LastName

-            r.Offset(i - 1, CREP_ID) = rcd(i).rep.rep_id

-            r.Offset(i - 1, CREP_BEDS) = rcd(i).qtrs(1).c_beds

-

-            r.Offset(i - 1, CREP_NFG) = rcd(i).qtrs(1).c_bdgt_NFG

-            r.Offset(i - 1, CREP_NMG) = rcd(i).qtrs(1).c_bdgt_NMG

-

-            r.Offset(i - 1, CREP_PLAN) = rcd(i).qtrs(1).qtr.sale_PLAN

-

-            r.Offset(i - 1, CREP_HIR) = rcd(i).qtrs(1).c_pat_HIR

-            r.Offset(i - 1, CREP_TER) = rcd(i).qtrs(1).c_pat_TER

-            r.Offset(i - 1, CREP_CAR) = rcd(i).qtrs(1).c_pat_CRD

-            r.Offset(i - 1, CREP_FACT) = rcd(i).qtrs(1).c_sale_ALL

-            r.Offset(i - 1, CREP_PAT_LPU) = rcd(i).qtrs(1).c_pat_LPU

-            r.Offset(i - 1, CREP_BDGT) = rcd(i).qtrs(1).c_bdgt_LPU

-            If rcd(i).qtrs(1).c_bdgt_LPU > 0 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = rcd(i).qtrs(1).c_sale_ALL / rcd(i).qtrs(1).c_bdgt_LPU

-            End If

-            If r.Offset(i - 1, CREP_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-

-

-<<<<<<
-======================
-mREP_LIST
->>>>>>
-Attribute VB_Name = "mREP_LIST"

-Option Explicit

-

-Public Const CREP_AREA As String = "B12"

-Public Const CREP_NAME As Integer = 0

-Public Const CREP_NAME1 As Integer = 1

-Public Const CREP_NAME2 As Integer = 2

-Public Const CREP_ID As Integer = 3

-Public Const CREP_BEDS As Integer = 4

-Public Const CREP_NFG As Integer = 5

-Public Const CREP_NMG As Integer = 6

-Public Const CREP_HIR As Integer = 7

-Public Const CREP_TER As Integer = 8

-Public Const CREP_CAR As Integer = 9

-Public Const CREP_FACT As Integer = 10

-Public Const CREP_PLAN As Integer = 11

-Public Const CREP_PAT_LPU As Integer = 16

-Public Const CREP_BDGT As Integer = 17

-Public Const CREP_PAT_ALL As Integer = 16

-

-

-

-Sub EditREP(cRep As tREPID, ent_date As String)

-    NoFunc

-End Sub

-

-Sub Rep_Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btREP_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = "RM_QTR"

-    End With

-    ThisWorkbook.Worksheets("RM_QTR").Activate

-End Sub

-

-

-Sub btREP_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim rep_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("REP_LST_DETALS")

-    With Worksheets("REP_LIST")

-        rep_id = .getCurrentREP_ID

-        

-        Select Case i

-            Case 1:

-                .SelectREP_QTR rep_id

-            Case 2:

-                ent_date = .getEnt_date()

-                .SelectREP_LPU rep_id, ent_date

-        End Select

-    End With

-    

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-

-

-

-<<<<<<
-======================
-cdbREP
->>>>>>
-Attribute VB_Name = "cdbREP"

-Option Explicit

-

-Public Type tREPID_COMMON

-    rep As tREPID

-    i_qtrs As Integer

-    qtrs() As tQTR_COMMON

-End Type

-

-Function Get_REP_CommonList_by_QTR(ByRef rcd() As tREPID_COMMON, ent_date As String) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_REP_CommonList_by_QTR = dbGet_REP_CommonList_by_QTR(dbConnection, rcd, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_REP_CommonList_by_QTR(dbConnection As Object, ByRef rcd() As tREPID_COMMON, ent_date As String) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim k As Long

-    Dim allREPID() As tREPID

-    

-    i = dbGetAll_REPID_Records_by_QTR(dbConnection, allREPID, ent_date)

-    dbGet_REP_CommonList_by_QTR = i

-    If i > 0 Then

-        ReDim rcd(i)

-        For i = 1 To UBound(allREPID)

-            rcd(i).rep = allREPID(i)

-            rcd(i).i_qtrs = Get_QTR_CommonList_by_REP(rcd(i).qtrs, ent_date, allREPID(i).rep_id)

-        Next i

-    End If

-End Function

-

-

-

-<<<<<<
-======================
-CHRT_PAT_LPU_A
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU_A"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-cdbRegion
->>>>>>
-Attribute VB_Name = "cdbRegion"

-Option Explicit

-

-Type tREGION

-    ent_date As String

-    total_SALE As Long ' общий объем продаж

-    total_BDGT As Long ' бюджет всех ЛПУ

-    total_BDGT_NMG As Long ' бюджет всех ЛПУ на НМГ

-    total_LPU As Long ' число ЛПУ

-    total_REP   As Long ' число репов

-    total_BEDS As Long ' общее число коек

-    total_HIR As Long '  общее число пациентов на клексане в хирургии

-    total_TER As Long '  общее число пациентов на клексане в терапии

-    total_ACS As Long '  общее число пациентов на клексане в кардиологии

-    sale_PLAN As Long '  план продаж Авентиса

-End Type

-

-Function GetRGN_COMM_DATA(ByRef reg_data() As tREGION) As Integer

-    Dim q_date() As String

-    Dim q_count As Integer, i As Integer

-    

-    q_count = getAllQTRNames(q_date)

-    If q_count > 0 Then

-        ReDim reg_data(q_count)

-        For i = 1 To q_count

-            Dim current_rep_count As Integer

-            current_rep_count = getREGION_by_QTR(q_date(i), reg_data(i))

-        Next i

-    End If

-    

-    GetRGN_COMM_DATA = q_count

-End Function

-

-Function getAllQTRNames(ByRef qtr_lst() As String) As Integer

-    

-    Dim sql As String

-    Dim i As Integer

-    Dim db As Object, rs As Object

-    

-    

-    sql = "SELECT DISTINCT entry_date FROM lpu_budget"

-    i = 0

-    

-    dbOpenConnection db

-    Set rs = CreateObject("ADODB.Recordset")

-    

-    rs.Open sql, db

-        

-        If Not rs.BOF Then

-            Do While Not rs.EOF

-                i = i + 1

-                ReDim Preserve qtr_lst(i)

-                qtr_lst(i) = rs("entry_date")

-                rs.MoveNext

-            Loop

-        Else

-            getAllQTRNames = 0

-            Exit Function

-        End If

-    getAllQTRNames = i

-    dbCloseConnection db

-End Function

-

-Function getREGION_by_QTR(ent_date As String, treg As tREGION) As Integer

-    Dim rep_count As Integer

-    rep_count = 0

-    

-    Dim reps() As tREPID_COMMON

-    rep_count = Get_REP_CommonList_by_QTR(reps, ent_date)

-    

-    treg.ent_date = ent_date

-    treg.total_BDGT = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.total_BDGT_NMG = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.sale_PLAN = 0 ' quarter.sale_plan

-    treg.total_SALE = 0 'summ of

-    ' hir = (amb40+st40)*pr40 + (amb20+st20)*pr20

-    'ter (amb_clx+stat_clx)*price

-    ' acs xxx

-    'price per rep

-    treg.total_HIR = 0 'patiens clxn

-    treg.total_TER = 0 'patiens clxn

-    treg.total_ACS = 0 'patiens clxn

-    treg.total_LPU = 0 'lpu

-    treg.total_BEDS = 0 'lpu.beds

-    treg.total_REP = 0 '

-    

-    If rep_count > 0 Then

-        Dim i As Integer

-        

-        For i = 1 To UBound(reps)

-            ' current rep is reps(i)

-            With reps(i)

-                treg.total_BDGT = treg.total_BDGT + .qtrs(1).c_bdgt_NFG + .qtrs(1).c_bdgt_NMG

-                treg.total_BDGT_NMG = treg.total_BDGT_NMG + .qtrs(1).c_bdgt_NMG

-                treg.sale_PLAN = treg.sale_PLAN + .qtrs(1).c_sale_PLAN

-                treg.total_SALE = treg.total_SALE + .qtrs(1).c_sale_ALL

-                treg.total_HIR = treg.total_HIR + .qtrs(1).c_pat_HIR

-                treg.total_TER = treg.total_TER + .qtrs(1).c_pat_TER

-                treg.total_ACS = treg.total_ACS + .qtrs(1).c_pat_CRD

-                treg.total_LPU = treg.total_LPU + .qtrs(1).i_lcd

-                treg.total_BEDS = treg.total_BEDS + .qtrs(1).c_beds

-                treg.total_REP = treg.total_REP + 1

-            End With

-            

-        Next i

-        

-    End If

-    

-    getREGION_by_QTR = treg.total_REP

-End Function

-

-<<<<<<
-======================
-mRM_QTR
->>>>>>
-Attribute VB_Name = "mRM_QTR"

-Option Explicit

-

-Sub btRM_QTR_Do_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    

-    idx = Worksheets(VAR_SHEET).Range("RM_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            ImportData

-        Case 2

-            Worksheets("REP_LIST").Select

-        Case 3

-            cmExport

-    End Select

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-End Sub

-

-Sub ImportData()

-    Dim i As Integer

-    Dim def_dir As String

-    Dim flist() As String

-    

-    def_dir = GetWBPath(ThisWorkbook.FullName)

-    If GetImportDirectory(def_dir, flist) Then

-        Dim ImpMask() As String

-        ImpMask = Split(flist(1), Chr(95), Compare:=vbBinaryCompare)

-        flist(1) = ImpMask(0) & "*"

-        Dim db_list() As String

-        i = GetDBList(flist(), db_list)

-        If i > 0 Then

-            Merge_BackUp_All_Data

-            MergeGlobal db_list, GetWBPath(ThisWorkbook.FullName) & "clexane-rm.mdb"

-        End If

-    End If

-    Worksheets(RM_QTR_SHEET).update_history

-End Sub

-<<<<<<
-======================
-mImport
->>>>>>
-Attribute VB_Name = "mImport"

-    Option Explicit

-

-Const OFN_ALLOWMULTISELECT As Long = 512

-Const OFN_EXPLORER As Long = 524288

-Const OFN_HIDEREADONLY As Long = 4

-Const OFN_NONETWORKBUTTON As Long = 131072

-Const OFN_READONLY As Long = 1

-       

-Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _

-    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

-

-Private Type OPENFILENAME

-    lStructSize As Long

-    hWndOwner As Long

-    hInstance As Long

-    lpstrFilter As String

-    lpstrCustomFilter As String

-    nMaxCustFilter As Long

-    nFilterIndex As Long

-    lpstrFile As String

-    nMaxFile As Long

-    lpstrFileTitle As String

-    nMaxFileTitle As Long

-    lpstrInitialDir As String

-    lpstrTitle As String

-    flags As Long

-    nFileOffset As Integer

-    nFileExtension As Integer

-    lpstrDefExt As String

-    lCustData As Long

-    lpfnHook As Long

-    lpTemplateName As String

-End Type

-

-Function GetImportDirectory(DB_dir As String, flist() As String) As Boolean

-    Dim OpenFile As OPENFILENAME

-    Dim lReturn As Long

-    Dim sFilter As String

-    

-    OpenFile.lStructSize = Len(OpenFile)

-    '         OpenFile.hwndOwner = Form1.hWnd

-    '         OpenFile.hInstance = App.hInstance

-    sFilter = "Clexane Data Files" & Chr(0) & "mr*.mdb" & Chr(0)

-    OpenFile.lpstrFilter = sFilter

-    OpenFile.nFilterIndex = 1

-    OpenFile.lpstrFile = String(257, 0)

-    OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1

-    OpenFile.lpstrFileTitle = OpenFile.lpstrFile

-    OpenFile.nMaxFileTitle = OpenFile.nMaxFile

-    OpenFile.lpstrInitialDir = DB_dir

-    OpenFile.lpstrTitle = "Импорт данных"

-    OpenFile.flags = OFN_HIDEREADONLY + OFN_EXPLORER

-    lReturn = GetOpenFileName(OpenFile)

-    If lReturn = 0 Then

-        GetImportDirectory = False

-    Else

-        GetImportDirectory = True

-        flist = Split(OpenFile.lpstrFile, Chr(0), Compare:=vbBinaryCompare)

-        Dim i As Integer

-        i = 0

-        Do While flist(i) <> ""

-            i = i + 1

-        Loop

-        If i = 1 Then

-            flist(1) = flist(0)

-            flist(0) = GetWBPath(flist(1))

-            flist(1) = GetWBName(flist(1))

-        Else

-            flist(0) = flist(0) & "\"

-        End If

-    End If

-End Function

-<<<<<<
-Project Name : 'ClexaneMR'
-Quirk - duff tag length======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).ClearRepName

-    

-    Application.EnableEvents = True

-    Set MyAppEvents.app = Application

-    

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    

-    MyAppEvents.CheckWorkBooksArround ThisWorkbook

-    

-    cmSetStandaloneMode

-    

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-    

-    Application.ScreenUpdating = True

-    

-    If CheckUser Then

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-        ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-        ThisWorkbook.Worksheets(REP_QTR_SHEET).update_history

-        Application.Calculate

-    End If

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    

-    Dim RestMode As Boolean

-    RestMode = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE")

-    

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-'        If RestMode Then

-            ThisWorkbook.Saved = True

-'        Else

-'            ThisWorkbook.Save

-'        End If

-    End If

-    If RestMode Then

-        xlRestoreView

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    End If

-    Application.Caption = Empty

-    Application.CommandBars(STDBAR_NAME).Reset

-    

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-    Dim MaxX, MaxY As Integer

-    With ThisWorkbook.Worksheets(REP_QTR_SHEET)

-        MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-        MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-    End With

-

-    With ThisWorkbook.Application

-        .ScreenUpdating = False

-        .WindowState = xlNormal

-        .Height = MaxY

-        .Width = MaxX

-    End With

-End Sub

-

-

-

-

-

-<<<<<<
-======================
-REP_QTR
->>>>>>
-Attribute VB_Name = "REP_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CQTR_QT As Integer = 0

-Const CQTR_ID As Integer = 1

-Const CQTR_PLN As Integer = 2

-Const CQTR_FCT As Integer = 3

-Const CQTR_BDG As Integer = 4

-Const CQTR_CNT As Integer = 5

-Const CQTR_BEDS As Integer = 6

-Const CQTR_HIR As Integer = 7

-Const CQTR_TER As Integer = 8

-Const CQTR_CRD As Integer = 9

-Const CQTR_CLXN_BDG As Integer = 10

-Const CQTR_CLXN_NMG As Integer = 11

-Const CQTR_PAT_ALL As Integer = 16

-Const CQTR_BDGT_ALL As Integer = 17

-

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub ClearRepName()

-    Unprotect

-    Range("D4") = ""

-    Range("D5") = ""

-    Range("H4") = ""

-    Range("H5") = ""

-End Sub

-

-Sub update_history()

-    Dim objQTR() As tQTR

-    Dim i As Long

-    Dim r As Range

-    Dim cRep As tREP

-    

-    cRep = GetREPRecord

-    Range("D4") = cRep.LastName

-    Range("D5") = cRep.FirstName

-    

-    Range("H4") = GetRegionName(cRep.Region)

-    Range("H5") = GetCityName(cRep.Region, cRep.City)

-    

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    i = GetAll_QTR_Records(objQTR, "%")

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CQTR_QT) = objQTR(i).entry_date

-        Next i

-    End If

-    Dim qcd() As tQTR_COMMON

-    i = Get_QTR_CommonList(qcd)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(qcd)

-            r.Offset(i - 1, CQTR_QT) = qcd(i).qtr.entry_date

-            r.Offset(i - 1, CQTR_ID) = qcd(i).qtr.id

-            r.Offset(i - 1, CQTR_PLN) = qcd(i).qtr.sale_plan

-            r.Offset(i - 1, CQTR_FCT) = qcd(i).c_sale_ALL

-            r.Offset(i - 1, CQTR_BDG) = qcd(i).c_bdgt_LPU

-            r.Offset(i - 1, CQTR_CNT) = qcd(i).i_lcd

-            r.Offset(i - 1, CQTR_BEDS) = qcd(i).c_beds

-            r.Offset(i - 1, CQTR_HIR) = qcd(i).c_pat_HIR

-            r.Offset(i - 1, CQTR_TER) = qcd(i).c_pat_TER

-            r.Offset(i - 1, CQTR_CRD) = qcd(i).c_pat_CRD

-            If qcd(i).c_bdgt_LPU <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_BDG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_LPU

-            End If

-            If qcd(i).c_bdgt_NMG <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_NMG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_BBL_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-

-End Sub

-

-Sub Draw_PAT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CQTR_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRepQtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-

-Private Sub Worksheet_Activate()

-  

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-    

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.Count > 1 And r_sel.Columns.Count < CRow_Width Or r_sel.Rows.Count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.Count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.Count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.Count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CQTR_ID + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    i = currRange.Column - Range(CINP_AREA).Column

-    

-    QTR_ID = r

-

-    If QTR_ID = 0 Then

-        Worksheets(VAR_SHEET).Range("USER_ACTION") = 1

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        If i > CQTR_FCT Then

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-            Range("LAST_FOCUS") = currRange.address

-        Else

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 3

-            Range("LAST_FOCUS") = currRange.address

-        End If

-    End If

-    Cancel = True

-    btHomeDo_IT

-End Sub

-

-<<<<<<
-======================
-mRep_QTR
->>>>>>
-Attribute VB_Name = "mRep_QTR"

-Option Explicit

-

-Sub DO_New_qtr()

-    Dim res As Variant

-    Dim objQTR As tQTR

-    Dim s As String

-    s = GetLastQtr

-    objQTR.entry_date = GetNextQTR(s)

-    

-    If objQTR.entry_date = "" Then

-        Exit Sub

-    End If

-    

-    DO_Price_qtr objQTR.entry_date

-

-End Sub

-

-Sub DO_Price_qtr(ent_date As String)

-    If ent_date = "" Then

-        DO_New_qtr

-    Else

-        Dim qtr As tQTR

-        Dim res As Integer

-        

-        qtr = Get_QTR_Record(ent_date)

-        

-        If qtr.id = 0 Then

-            qtr.entry_date = ent_date

-    

-            With Worksheets(VAR_SHEET)

-                qtr.ClxnH20mg = .Range("ClxnH20mg")

-                qtr.ClxnH40mg = .Range("ClxnH40mg")

-                qtr.ClxnT40mg = .Range("ClxnT40mg")

-                qtr.ClxnC_ACS = .Range("ClxnC_ACS")

-                qtr.ClxnC_IM = .Range("ClxnC_IM")

-            End With

-        End If

-        

-        Dim dlg_nq As dlg_nextQTR

-        Set dlg_nq = New dlg_nextQTR

-        

-        With dlg_nq

-            .tb_qtr_name = qtr.entry_date

-            .tb_bdgt_avts = qtr.sale_plan

-            .tb_qtr_name = qtr.entry_date

-            .tb_ClxnH20mg = qtr.ClxnH20mg

-            .tb_ClxnH40mg = qtr.ClxnH40mg

-            .tb_ClxnT40mg = qtr.ClxnT40mg

-            .tb_ClxnC_ACS = qtr.ClxnC_ACS

-            .tb_ClxnC_IM = qtr.ClxnC_IM

-        End With

-        

-        dlg_nq.Show

-        res = dlg_nq.Tag

-        

-        If res = vbOK Then

-            With dlg_nq

-                If Not IsNumeric(.tb_bdgt_avts) Then

-                    MsgBox "Введите план продаж", vbOK, PROGRAM_NAME

-                Else

-                    If .tb_bdgt_avts = 0 Then

-                        MsgBox "Введите план продаж", vbOK, PROGRAM_NAME

-                        Exit Sub

-                    End If

-                End If

-                Dim bool As Boolean

-                bool = IsNumeric(.tb_ClxnH20mg) _

-                    And IsNumeric(.tb_ClxnH40mg) _

-                    And IsNumeric(.tb_ClxnT40mg) _

-                    And IsNumeric(.tb_ClxnC_ACS) _

-                    And IsNumeric(.tb_ClxnC_IM)

-                If Not bool Then

-                    MsgBox "Вводите правильно цыфры", vbOK, PROGRAM_NAME

-                    Exit Sub

-                End If

-                qtr.sale_plan = .tb_bdgt_avts

-                qtr.entry_date = .tb_qtr_name

-                qtr.ClxnH20mg = .tb_ClxnH20mg

-                qtr.ClxnH40mg = .tb_ClxnH40mg

-                qtr.ClxnT40mg = .tb_ClxnT40mg

-                qtr.ClxnC_ACS = .tb_ClxnC_ACS

-                qtr.ClxnC_IM = .tb_ClxnC_IM

-            End With

-            Insert_QTR_Record qtr

-        End If

-    End If

-End Sub

-

-Sub DO_Edit_qtr(ent_date As String)

-    If ent_date = "" Then

-        DO_New_qtr

-    Else

-        With ThisWorkbook.Worksheets("LPU_LIST")

-            .Range("VIEW_ONLY") = False

-            .Range("ent_date") = ent_date

-            .Select

-        End With

-    End If

-End Sub

-

-Sub DO_Delete_qtr(ent_date As String)

-    If ent_date <> "" Then

-        Dim i As Integer

-        i = MsgBox("Удалить данные за период [" & ent_date & "]?", vbDefaultButton2 + vbOKCancel, PROGRAM_NAME)

-        If i = vbOK Then

-            Dim objQTR As tQTR

-            If ent_date <> "" Then

-                objQTR.entry_date = ent_date

-                objQTR = Get_QTR_Record(ent_date)

-                Delete_QTR_Record objQTR

-                Worksheets(TITLE_SHEET).Select

-                Worksheets(REP_QTR_SHEET).Select

-            End If

-        End If

-    End If

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-

-Sub btHomeDo_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    idx = Worksheets(VAR_SHEET).Range("USER_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            DO_New_qtr

-            ' Обновляем экран

-        Case 2

-            DO_Edit_qtr ent_date

-        Case 3

-            DO_Price_qtr ent_date

-        Case 4

-            dbExport

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    End Select

-    If idx <> 2 Then

-        With ThisWorkbook

-            .Worksheets(TITLE_SHEET).Select

-            .Worksheets(REP_QTR_SHEET).Select

-        End With

-    End If

-End Sub

-

-Sub Delete_qtr()

-    Dim ent_date As String

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    DO_Delete_qtr ent_date

-End Sub

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane[MR]"

-Public Const PROGRAM_VERSION As String = "version 1.6"

-Public Const PROGRAM_FILENAME As String = "clexane-mr"

-Public Const PROGRAM_EXPORTNAME As String = "mr-ex-"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20030329

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "O40"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-End Sub

-

-Function Double2Str(ByVal d As Double, ByVal precision As Integer, Optional Delim As String = ".") As String

-    Dim s As String

-    If Not precision > 0 Then

-        s = Round(d)

-    Else

-        Dim i As Integer

-        i = Fix(d)

-        s = i & Delim

-        d = Abs(d - i)

-        Do

-            precision = precision - 1

-            d = d * 10

-            If precision > 0 Then

-                i = Fix(d)

-            Else

-                i = Round(d)

-            End If

-            If i < 1 Then

-                s = s & "0"

-            Else

-                s = s & i

-                d = d - i

-            End If

-        Loop While precision > 0

-    End If

-    Double2Str = s

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.Count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.name = VAR_SHEET Or sh.name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-<<<<<<
-======================
-Var
->>>>>>
-Attribute VB_Name = "Var"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-title
->>>>>>
-Attribute VB_Name = "title"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LPU_LIST
->>>>>>
-Attribute VB_Name = "LPU_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentLPU_ID() As Long

-    Dim r As Range

-    

-    With Worksheets("LPU_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CLPU_ID)

-    End With

-    

-    getCurrentLPU_ID = r

-End Function

-

-Public Sub LPU_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectLPU_NAME(lpu_id As Long, ent_date As String)

-    If Range("VIEW_ONLY") = True Then

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    Dim cLPU As tLPU

-    If lpu_id = 0 Then

-        cLPU.id = 0

-        cLPU.rep_id = 0

-        cLPU.address = ""

-        cLPU.name = ""

-    Else

-        cLPU = Get_LPU_Record(lpu_id)

-    End If

-    EditLPU cLPU, getEnt_date

-    Worksheet_Activate

-End Sub

-        

-Sub SelectLPU_BDGT(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    If lpu_id = 0 Then

-        SelectLPU_NAME lpu_id, ent_date

-    Else

-        With ThisWorkbook.Worksheets("LPU_BDGT")

-            .Range("VIEW_ONLY") = vo

-            .Range("ret_addr") = "LPU_LIST"

-            .Range("ent_date") = ent_date

-            .Range("lpu_id") = lpu_id

-        End With

-    End If

-End Sub

-

-Sub SelectLPU_HIR(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_CLSN_HIR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-                   

-Sub SelectLPU_TER(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_CLSN_TER")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-       

-Sub SelectLPU_C_ACS(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_CLSN_C_ACS")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateLPUList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.Count > 1 And r_sel.Columns.Count < CINP_WIDTH Or r_sel.Rows.Count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.Count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.Count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.Count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim lpu_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-    

-    ent_date = getEnt_date

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-    

-    Set r = Range(CINP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CINP_AREA).row, CLPU_ID)

-        

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-    

-    lpu_id = r

-    

-    i = Range(Range("LAST_FOCUS")).Column - Range(CINP_AREA).Column

-    

-    If lpu_id = 0 Then

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    End If

-    

-    If lpu_id = 0 Then

-        i = CLPU_NAME

-        Range("JUMP") = ""

-    End If

-    Select Case i

-        Case CLPU_NAME, CLPU_NAME1, CLPU_NAME2, CLPU_BEDS

-            SelectLPU_NAME lpu_id, ent_date

-            Range("JUMP") = ""

-

-        Case CLPU_NMG, CLPU_NFG, CLPU_PLAN, CLPU_FACT

-            SelectLPU_BDGT lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-            

-        Case CLPU_HIR

-            SelectLPU_HIR lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_HIR"

-        

-        Case CLPU_TER

-            SelectLPU_TER lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_TER"

-        

-        Case CLPU_CAR

-            SelectLPU_C_ACS lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_C_ACS"

-        

-        Case Else

-            Range("JUMP") = ""

-    End Select

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-    

-    is_input_range = INPUT_NO

-    

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateLPUList()

-    Dim lcd() As tLPU_COMMON

-    

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-    Dim objQTR As tQTR

-    Dim cRep As tREP

-    

-    ' ent_date = "%" ' % - all records

-    ent_date = getEnt_date

-    

-    objQTR = Get_QTR_Record(ent_date)

-    i = Get_LPU_CommonQTR(lcd, objQTR)

-     

-    ' стираем ФИО

-    Range("C3:C4").ClearContents

-    cRep = GetREPRecord

-    

-    Range("C3") = cRep.LastName

-    Range("C4") = cRep.FirstName

-    Range("G3") = GetRegionName(cRep.Region)

-    Range("G4") = GetCityName(cRep.Region, cRep.City)

-    Range("G5") = objQTR.sale_plan

-    

-

-    

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-        

-        For i = 1 To UBound(lcd)

-            r.Offset(i - 1, CLPU_NAME) = lcd(i).lpu.name

-            r.Offset(i - 1, CLPU_ID) = lcd(i).lpu.id

-            r.Offset(i - 1, CLPU_BEDS) = lcd(i).lpu.beds

-            

-         

-            r.Offset(i - 1, CLPU_NFG) = lcd(i).bdgt.bdgt_NFG

-            r.Offset(i - 1, CLPU_NMG) = lcd(i).bdgt.bdgt_NMG

-            r.Offset(i - 1, CLPU_PLAN) = lcd(i).bdgt.sale_plan

-            

-            r.Offset(i - 1, CLPU_HIR) = lcd(i).pat_HIR

-            r.Offset(i - 1, CLPU_TER) = lcd(i).pat_TER

-            r.Offset(i - 1, CLPU_CAR) = lcd(i).pat_CRD

-            r.Offset(i - 1, CLPU_FACT) = lcd(i).sale_ALL

-            r.Offset(i - 1, CLPU_PAT_LPU) = lcd(i).pat_LPU

-            r.Offset(i - 1, CLPU_BDGT) = lcd(i).bdgt_LPU

-            If lcd(i).bdgt_LPU > 0 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = lcd(i).sale_ALL / lcd(i).bdgt_LPU

-            End If

-            If r.Offset(i - 1, CLPU_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = 1

-            End If

-            

-        Next i

-    End If

-End Sub

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{566B33D6-957A-43E4-8444-D8EA3889700C}{42EE65B8-F8C6-4F95-9F52-7738BF6FCEAD}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-dbACS
->>>>>>
-Attribute VB_Name = "dbACS"

-Option Explicit

-

-Public Type tACS

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    patients_with_geparins As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objACS.ID <> 0 then updatre else insert

-Sub Insert_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objACS.id <> 0 Then

-        dbUpdate_ACS_Record dbConnection, objACS

-    Else

-        dbInsert_ACS_Record dbConnection, objACS

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_ACS_RecordsByLPU_ID(ByRef all_ACS_() As tACS, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_ACS_RecordsByLPU_ID = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, all_ACS_, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_ACS_Record dbConnection, objACS

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub dbInsert_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_acs", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objACS

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("patients_with_geparins") = .patients_with_geparins

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objACS.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim Update_SQL As String

-    

-    With objACS

-        Update_SQL = "UPDATE lpu_acs SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "patients_with_geparins=" & .patients_with_geparins & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_ACS_RecordsbyLPU_ID(dbConnection As Object, all_ACS() As tACS, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_ACS_SQL As String

-    Dim getAll_ACS_SQL As String

-    Dim ACS_Count As Long

-    ACS_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_ACS_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        ACS_Count = dbRecordset("ACS_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_ACS_RecordsbyLPU_ID = ACS_Count

-    

-    If ACS_Count > 0 Then

-        'we have records

-        ReDim all_ACS(1 To ACS_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_ACS_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_ACS As tACS

-                 With tmp_ACS

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .patients_with_geparins = dbRecordset("patients_with_geparins")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 all_ACS(index) = tmp_ACS

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE ID=" & objACS.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_ACS_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_HIR
->>>>>>
-Attribute VB_Name = "LPU_CLSN_HIR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-    

-        Dim objHir As tHIRURGIA

-        

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objHir

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .operations_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L9")

-                .patients_ambulator_clexan_20mg = Range("L10")

-                .patients_ambulator_clexan_40mg = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L19")

-                .patients_stationar_clexan_20mg = Range("L20")

-                .patients_stationar_clexan_40mg = Range("L21")

-            End With

-            Insert_Hir_Record objHir

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objHir.id = Range("rec_id")

-                    If objHir.id <> 0 Then

-                        Delete_Hir_Record objHir

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objHir As tHIRURGIA)

-    Dim qtr As tQTR

-    Dim formula As String

-

-    With objHir

-        Range("rec_id") = .id

-        Range("F6") = .operations_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L9") = .patients_ambulator_clexan

-        Range("L10") = .patients_ambulator_clexan_20mg

-        Range("I21") = .patients_stationar_nmg

-        Range("L19") = .patients_stationar_clexan

-        Range("L20") = .patients_stationar_clexan_20mg

-        

-        qtr = Get_QTR_Record(.entry_date)

-        formula = "=" & qtr.ClxnH20mg & "*($L$10+$L$20)+" & qtr.ClxnH40mg & "*($L$11+$L$21)"

-        Range("F11").formula = formula

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-    

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Range("h_DepFlag") = False

-    

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objHir() As tHIRURGIA

-        Dim i As Integer

-        i = GetAll_Hir_RecordsByLPU_ID(objHir, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.3

-        Else

-            SetupData objHir(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-mSapes
->>>>>>
-Attribute VB_Name = "mSapes"

-Option Explicit

-

-Const SHAPE_COLOR As Integer = 1

-Const SHAPE_NAME As Integer = 2

-

-

-Sub ShapeView(r_sh_finite_state As Range)

-    Dim chk As Range

-    Dim s As String

-    Dim c, idx As Integer

-    For Each chk In r_sh_finite_state

-        idx = 0

-        If chk = "+" Then

-            c = chk.Offset(0, idx + SHAPE_COLOR)

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While c <> 0

-                ShapeFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s)), c

-                idx = idx + 2

-                c = chk.Offset(0, idx + SHAPE_COLOR)

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        Else

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While s <> ""

-                ShapeUnFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s))

-                idx = idx + 2

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        End If

-    Next chk

-End Sub

-

-Sub ShapeFill(sh As ShapeRange, ByVal color As Integer)

-    sh.Fill.Visible = msoTrue

-    sh.Fill.Solid

-    sh.Fill.ForeColor.SchemeColor = color

-    sh.Fill.Transparency = 0#

-End Sub

-

-Sub ShapeUnFill(sh As ShapeRange)

-    sh.Fill.Visible = msoFalse

-    sh.Fill.Transparency = 0#

-End Sub

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Public Const INPUT_NO = 0

-Public Const INPUT_NUMBER = 1

-Public Const INPUT_PERCENT = 2

-Public Const INPUT_STRING = 3

-Public Const INPUT_CHECK = 4

-

-Public Const INP_IDX_TYPE = 1

-Public Const INP_IDX_NEXT = 2

-Public Const INP_IDX_MIN = 3

-Public Const INP_IDX_MAX = 4

-Public Const INP_IDX_DEP = 5

-Public Const INP_IDX_ALT = 7

-

-

-Public Type tInputSet

-    vType As Integer

-    vMin As Long

-    vMax As Long

-    rChk As String

-End Type

-

-Function is_input_cell(ByVal Target As Range, inputs As Range) As tInputSet

-    Dim t As Range

-    Dim iset As tInputSet

-    Dim test As Range

-    iset.vType = INPUT_NO

-    iset.vMin = 0

-    iset.vMax = 0

-    iset.rChk = ""

-    is_input_cell = iset

-

-' Закоментировать следующую сточку для работы

-'  Exit Function

-

-    Set test = Target.Cells(1, 1)

-    For Each t In inputs

-        If Range(t).Column = test.Column And Range(t).row = test.row Then

-            iset.vType = t.Offset(0, INP_IDX_TYPE).Value

-            Select Case iset.vType

-                Case INPUT_CHECK

-                    iset.rChk = t.Offset(0, INP_IDX_ALT)

-                Case INPUT_NUMBER, INPUT_PERCENT

-                    iset.vMin = t.Offset(0, INP_IDX_MIN).Value

-                    iset.vMax = t.Offset(0, INP_IDX_MAX).Value

-            End Select

-            is_input_cell = iset

-            Exit Function

-        End If

-    Next t

-End Function

-

-Function GetFocusAddress(ByVal r As Range, f_next As Range) As String

-    Dim chk, t As Range

-    

-    For Each chk In f_next

-        For Each t In r

-            If t.address = chk Then

-                GetFocusAddress = chk

-                Exit Function

-            End If

-            If Range(chk).Column = t.Column - 1 And Range(chk).row = t.row _

-            Or Range(chk).Column = t.Column And Range(chk).row = t.row - 1 _

-            Then

-                If Range(chk) <> "" Then

-                    If Range(chk) = 0 Then

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_ALT)).address

-                    Else

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_NEXT)).address

-                    End If

-                Else

-                    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-                End If

-                Exit Function

-            End If

-        Next t

-    Next chk

-    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-End Function

-

-Sub SetDependet(r As Range, inputs As Range)

-    Dim chk As Range

-    Dim s, serr As String

-    Dim idx As Integer

-    Dim iset As tInputSet

-    Dim err_found As Boolean

-    

-    If r.Count > 1 Then

-        Exit Sub

-    End If

-    

-    err_found = False

-    For Each chk In inputs

-        idx = INP_IDX_DEP

-        

-        

-        iset.vType = chk.Offset(0, INP_IDX_TYPE).Value

-        Select Case iset.vType

-            Case INPUT_NUMBER, INPUT_PERCENT

-                iset.vMin = chk.Offset(0, INP_IDX_MIN).Value

-                iset.vMax = chk.Offset(0, INP_IDX_MAX).Value

-                

-                If Range(chk) > iset.vMax Then

-                    err_found = True

-                    Range(chk) = iset.vMax

-                    serr = "Выход за дозволенный диапазон [" & iset.vMin & ".." & iset.vMax & "]! Данные скорректированы."

-                End If

-                

-                If Range(chk) = "" Then

-                    s = chk.Offset(0, idx)

-                    Do While s <> ""

-                        Range(s) = ""

-                        idx = idx + 1

-                        s = chk.Offset(0, idx)

-                    Loop

-                End If

-        End Select

-    Next chk

-    If err_found Then

-        MsgBox serr, vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Function CheckInputData(inputs As Range) As Boolean

-    Dim r As Range

-    

-    CheckInputData = True

-    For Each r In inputs

-        If Range(r) = "" Then

-            CheckInputData = False

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100.", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Sub Check_Int_Number(Target As Range, Def_Val As Long)

-    Dim err As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    err = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                err = True

-            End If

-        End If

-    Next r

-    If err Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_TER
->>>>>>
-Attribute VB_Name = "LPU_CLSN_TER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim objTer As tTERAPIA

-        

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objTer

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .patients_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L20")

-            End With

-            Insert_Ter_Record objTer

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objTer.id = Range("rec_id")

-                    If objTer.id <> 0 Then

-                        Delete_Ter_Record objTer

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objTer As tTERAPIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    With objTer

-        Range("rec_id") = .id

-        Range("F6") = .patients_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L11") = .patients_ambulator_clexan

-        Range("I21") = .patients_stationar_nmg

-        Range("L20") = .patients_stationar_clexan

-        

-        qtr = Get_QTR_Record(.entry_date)

-        formula = "=" & qtr.ClxnT40mg & "*($L$12+$L$20)"

-        Range("F11").formula = formula

-        

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-    

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Range("h_DepFlag") = False

-    

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objTer() As tTERAPIA

-        Dim i As Integer

-        i = GetAll_Ter_RecordsByLPU_ID(objTer, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.25

-        Else

-            SetupData objTer(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-    

-    Dim s As String

-    Dim iset As tInputSet

-    

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    

-    Select Case iset.vType

-        Case INPUT_NO

-        

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-            

-            Application.ScreenUpdating = False

-            

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-            

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-        

-        Case INPUT_STRING

-        

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{EBA94131-180E-4709-A2A3-B60D48987620}{47A860A1-BF92-4EBB-A333-AB7E83FAB868}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-LPU_BDGT
->>>>>>
-Attribute VB_Name = "LPU_BDGT"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub SetDefFocus()

-    Range(Range("DEF_FOCUS")).Select

-End Sub

-

-Public Sub ClearData()

-    ClearSheetData

-End Sub

-

-Sub ClearSheetData()

-    If Range("F10") = 0 And Range("F13") = 0 Then

-        Range("F11:F18") = ""

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("F11:F13") = ""

-    End If

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim bdgt As tBUDGET

-        Dim sum As Long

-        Dim test As Boolean

-        With bdgt

-            .lpu_id = Range("lpu_id")

-            .id = Range("rec_id")

-            .entry_date = Range("ent_date")

-            .bdgt_NMG = Round(Range("F11").Value, 0)

-            .bdgt_NFG = Round(Range("F12").Value, 0)

-            .sale_plan = Round(Range("F13").Value, 0)

-            

-            sum = .bdgt_NFG + .bdgt_NMG - .sale_plan

-            test = .bdgt_NFG <> 0 Or .bdgt_NMG <> 0 Or .sale_plan <> 0

-        End With

-        If test Then

-            If sum < 0 Then

-                MsgBox _

-                    "Ваш план превышает выделенный на гепарины бюджет. Сохранить данные?", _

-                    vbOKOnly, PROGRAM_NAME

-            End If

-            If test Then

-                Insert_BDGT_Record bdgt

-            End If

-        Else

-            If bdgt.id <> 0 Then

-                If vbYes = MsgBox("Сохранить нулевые значения?", vbYesNo, PROGRAM_NAME) Then

-                    Insert_BDGT_Record bdgt

-                End If

-                ret_back Range("DEF_FOCUS").Worksheet

-                Exit Sub

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-    End If

-    

-   ClearData

-   ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(cLPU As tLPU_COMMON)

-    Dim t_sum As Long

-    t_sum = 0

-' Setup budget data

-    Range("F11") = cLPU.bdgt.bdgt_NMG

-    Range("F12") = cLPU.bdgt.bdgt_NFG

-    Range("F13") = cLPU.bdgt.sale_plan

-    

-    With cLPU

-        Range("F14") = .pat_ALL

-        Range("F15") = .pat_HIR

-        Range("F16") = .pat_TER

-        Range("F17") = .pat_CRD

-        Range("F18") = .sale_ALL

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    ws_activate

-End Sub

-

-

-Sub ws_activate()

-    Dim cLPU As tLPU_COMMON

-    Dim objQTR As tQTR

-    Dim objLPU As tLPU

-    Dim ent_date As String

-    Dim id As Long

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    id = Range("lpu_id").Value

-    ent_date = Range("ent_date")

-    objQTR = Get_QTR_Record(ent_date)

-    objLPU = Get_LPU_Record(id)

-    Get_LPU_Common cLPU, objLPU, objQTR

-    

-    If cLPU.lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = cLPU.lpu.beds

-        Range("lpu_name") = cLPU.lpu.name

-        Range("lpu_addr") = cLPU.lpu.address

-        Range("rec_id") = cLPU.bdgt.id

-        

-        SetupData cLPU

-        

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-'    MsgBox Target.address

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Dim s As String

-    Dim iset As tInputSet

-    

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    

-    Select Case iset.vType

-        Case INPUT_NO

-        

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-            

-        Case INPUT_PERCENT

-        

-        Case INPUT_STRING

-        

-        Case INPUT_CHECK

-            

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{E3F10C5A-A4B4-42FF-A2C9-6F8198210A07}{563D0F3D-F79D-48F1-AFE4-A2136809B982}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mSheets
->>>>>>
-Attribute VB_Name = "mSheets"

-Option Explicit

-

-Function am_load_now() As Boolean

-    am_load_now = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE")

-End Function

-

-Sub Wks_select(RetSheet As String)

-    Dim sheet As Worksheet

-    For Each sheet In ThisWorkbook.Worksheets

-        If sheet.name = RetSheet Then

-            ThisWorkbook.Worksheets(RetSheet).Select

-            Exit Sub

-        End If

-    Next sheet

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub ret_back(sh As Worksheet)

-    Dim RetSheet As String

-    RetSheet = sh.Range("ret_addr")

-    sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    sh.Range("ret_addr") = ""

-    sh.Range("rec_id") = ""

-    sh.Range("lpu_id") = ""

-    sh.Range("ent_date") = ""

-    sh.Range("lpu_name") = ""

-    sh.Range("lpu_addr") = ""

-    sh.Range("lpu_beds") = ""

-    Wks_select RetSheet

-End Sub

-

-Sub ClearSheetData(r_start As Range)

-    If r_start <> "" Then

-        r_start.Worksheet.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        r_start = ""

-    Else

-        ret_back r_start.Worksheet

-    End If

-End Sub

-

-Sub wks_sel_chng(iset As tInputSet, ByVal Target As Range, sh As Worksheet)

-    Dim DebugMode As Boolean

-    Dim in_range As Range

-    

-    DebugMode = Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-

-    If DebugMode Then

-        sh.Unprotect

-    Else

-        sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    End If

-

-    If iset.vType = INPUT_CHECK Then

-        Set in_range = Target.Worksheet.Range(iset.rChk)

-    Else

-        Set in_range = Target

-    End If

-    

-    Dim str As String

-    str = GetFocusAddress(in_range, sh.Range("h_inputs"))

-

-'    MsgBox Target.Address & "; " & str

-    If str <> Target.address Then

-        sh.Range(str).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-Dlg_lpu_card
->>>>>>
-Attribute VB_Name = "Dlg_lpu_card"

-Attribute VB_Base = "0{137EDDE5-3DB4-4BAD-A245-324DC31ABB36}{3BD7159A-BF6C-403F-B3DF-4834FA9E4D92}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbLPU_List_Change()

-    Dim src As Range

-    Dim idx_src As Integer

-    

-    Set src = Worksheets(VAR_SHEET).Range(Me.cbLPU_List.RowSource)

-    idx_src = Me.cbLPU_List.ListIndex + 1

-    Me.tb_lpu_name.Text = src.Cells(idx_src, 1)

-    Me.tb_lpu_address.Text = src.Cells(idx_src, 2)

-    Me.tbBedsCount.Text = src.Cells(idx_src, 3)

-End Sub

-

-

-Private Sub cbxLPU_List_Enable_Click()

-    

-    If Me.cbxLPU_List_Enable Then

-        

-        Me.tb_lpu_name.Text = ""

-        Me.tb_lpu_name.Enabled = False

-        

-        Me.tb_lpu_address.Text = ""

-        Me.tb_lpu_address.Enabled = False

-        

-        Me.tbBedsCount.Text = ""

-        Me.tbBedsCount.Enabled = False

-        

-        Me.cbLPU_List.Enabled = True

-        cbLPU_List_Change

-    Else

-        Me.tb_lpu_name.Enabled = True

-        Me.tb_lpu_name.Text = ""

-        

-        Me.tb_lpu_address.Enabled = True

-        Me.tb_lpu_address.Text = ""

-        

-        Me.tbBedsCount.Enabled = True

-        Me.tbBedsCount.Text = ""

-        

-        Me.cbLPU_List.Enabled = False

-    End If

-End Sub

-

-<<<<<<
-======================
-UserInfo
->>>>>>
-Attribute VB_Name = "UserInfo"

-Attribute VB_Base = "0{8EB80D4C-3476-421A-A370-6332A07DE509}{A7542905-C9F8-4F39-AD67-B62A88F8F4E6}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Tag = vbOK

-End Sub

-

-Private Sub cbCity_Change()

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_CITY") = Me.cbCity.ListIndex

-        .Calculate

-    End With

-End Sub

-

-Private Sub cbRegion_Change()

-    Dim LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        NewRangeOffsetCol = cbRegion.Value * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).address

-        NewSumRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).address

-        .Calculate

-        .Range("IDX_CITY") = 0

-        cbCity.RowSource = NewCbxRange

-

-    End With

-    cbCity.ListIndex = 0

-End Sub

-

-<<<<<<
-======================
-mREP
->>>>>>
-Attribute VB_Name = "mREP"

-Option Explicit

-

-Sub hwnew()

-    Dim rs As Range

-    Dim re As Object

-    

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    HWReset

-    ReSetREPRecord

-    With Worksheets("REP_QTR")

-        .ClearRepName

-        .Range("REP_QTR_INPUT_DATA").ClearContents

-        .Range("QTR_SEL") = ""

-    End With

-    Worksheets(TITLE_SHEET).Select

-    With Application

-        .DisplayAlerts = False

-        .ThisWorkbook.Save

-        .Quit

-    End With

-End Sub

-

-Function CheckUser() As Boolean

-    Dim objHW() As Long

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    

-    GetHWInfo objHW()

-    i = GetHWRecords(objHW_DB)

-    

-    If i = 0 Then ' First time

-        StoreHWInfo objHW()

-        Worksheets("REP_QTR").Range("QTR_SEL") = ""

-    End If

-    If CheckHWInfo(objHW()) <> True Then

-        CheckUser = False

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    Else

-        CheckUser = SetupUser

-    End If

-End Function

-

-Function SetupUser() As Boolean

-    Dim cUser As tREP

-    Dim idx As Integer

-    Dim dlg_ui As UserInfo

-    

-    Set dlg_ui = New UserInfo

-    

-    cUser = GetREPRecord()

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_REGION") = cUser.Region

-        .Range("IDX_CITY") = cUser.City

-    End With

-        

-    With dlg_ui

-        .cbRegion = cUser.Region

-        .cbCity = cUser.City

-        .tbFName = cUser.FirstName

-        .tbLName = cUser.LastName

-    End With

-    

-    Worksheets(REGS_SHEET).Calculate

-    

-    Dim test_Ok As Boolean

-    test_Ok = False

-    

-    On Error GoTo l1

-

-    Do

-        dlg_ui.Show

-        If dlg_ui.Tag = vbOK Then

-            test_Ok = dlg_ui.tbFName.Value <> "" And dlg_ui.tbLName <> ""

-            If test_Ok Then

-                Exit Do

-            Else

-                MsgBox "Введите имя и фамилию", vbOKOnly, PROGRAM_NAME

-            End If

-        Else

-            Exit Do

-        End If

-    Loop Until False

-l1:

-    If test_Ok Then

-        With cUser

-            .Region = dlg_ui.cbRegion.Value

-            .City = dlg_ui.cbCity.Value

-            .FirstName = dlg_ui.tbFName.Value

-            .LastName = dlg_ui.tbLName.Value

-        End With

-        SetREPRecord cUser

-    Else

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .ThisWorkbook.Saved = True

-            .Quit

-        End With

-    End If

-    SetupUser = test_Ok

-End Function

-

-Sub GetHWInfo(objHW() As Long)

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    i = 1

-    For Each d In dc

-        If d.drivetype = 2 Then ' 2 - HardDisk

-            ReDim Preserve objHW(i)

-            objHW(i) = d.SerialNumber

-            i = i + 1

-        End If

-    Next

-    SortHW objHW

-End Sub

-

-Sub StoreHWInfo(objHW() As Long)

-    UpdateHWRecords objHW

-End Sub

-

-Sub SortHW(objHW() As Long)

-    Dim r As Range

-    Dim rs As Range

-    Dim re As Object

-    Dim i As Integer

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    For i = 1 To UBound(objHW)

-        r = objHW(i)

-        Set r = r.Offset(1, 0)

-    Next i

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).Sort _

-            Key1:=.Range("HW_Number"), _

-            Order1:=xlDescending, _

-            Header:=xlGuess, _

-            OrderCustom:=1, _

-            MatchCase:=False, _

-            Orientation:=xlTopToBottom

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    i = 1

-    Do While r <> ""

-        objHW(i) = r

-        Set r = r.Offset(1, 0)

-        i = i + 1

-    Loop

-End Sub

-

-Function CheckHWInfo(objHW() As Long)

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    CheckHWInfo = False

-        

-    i = GetHWRecords(objHW_DB)

-    If i > 0 Then

-        SortHW objHW_DB

-    End If

-    If UBound(objHW) = UBound(objHW_DB) Then

-        For i = 1 To UBound(objHW)

-            If objHW(i) <> objHW_DB(i) Then

-                Exit Function

-            End If

-        Next i

-        CheckHWInfo = True

-    End If

-End Function

-<<<<<<
-======================
-dbBudget
->>>>>>
-Attribute VB_Name = "dbBudget"

-Option Explicit

-

-Public Type tBUDGET

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    bdgt_NMG As Long

-    bdgt_NFG As Long

-    sale_plan As Long

-End Type

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function GetAll_BDGT_RecordsByLPU_ID(ByRef allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_BDGT_RecordsByLPU_ID = dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection, allBDGT, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function Get_BDGT_Record(ByVal lpu_id As Long, ByVal ent_date As String) As tBUDGET

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    Get_BDGT_Record = dbGet_BDGT_Record(dbConnection, lpu_id, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objBDGT.ID <> 0 then updatre else insert

-Public Sub Insert_BDGT_Record(objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    If objBDGT.id <> 0 Then

-        dbUpdate_BDGT_Record dbConnection, objBDGT

-    Else

-        dbInsert_BDGT_Record dbConnection, objBDGT

-    End If

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Public Sub Delete_BDGT_Record(ByRef objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    dbDelete_BDGT_Record dbConnection, objBDGT

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_BDGT_Record(dbConnection As Object, ByVal lpu_id As Long, ent_date As String) As tBUDGET

-    

-    Dim SQL As String

-    Dim objBDGT As tBUDGET

-    

-    With objBDGT

-        .id = 0

-        .lpu_id = lpu_id

-        .entry_date = ent_date

-        .bdgt_NMG = 0

-        .bdgt_NFG = 0

-        .sale_plan = 0

-    End With

-        

-    

-    SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        With objBDGT

-            .entry_date = dbRecordset("entry_date")

-            .id = dbRecordset("id")

-            .lpu_id = dbRecordset("lpu_id")

-            .bdgt_NFG = dbRecordset("bdgt_NFG")

-            .bdgt_NMG = dbRecordset("bdgt_NMG")

-            .sale_plan = dbRecordset("sale_PLAN")

-        End With

-    End If

-    

-    dbGet_BDGT_Record = objBDGT

-End Function

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection As Object, allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_BDGT_SQL As String

-    Dim getAll_BDGT_SQL As String

-    Dim BDGT_Count As Long

-    BDGT_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_BDGT_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        BDGT_Count = dbRecordset("BDGT_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_BDGT_RecordsbyLPU_ID = BDGT_Count

-    

-    If BDGT_Count > 0 Then

-        'we have records

-        ReDim allBDGT(1 To BDGT_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_BDGT_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpBDGT As tBUDGET

-                 With tmpBDGT

-                    .entry_date = dbRecordset("entry_date")

-                    .id = dbRecordset("id")

-                    .lpu_id = dbRecordset("lpu_id")

-                    .bdgt_NFG = dbRecordset("bdgt_NFG")

-                    .bdgt_NMG = dbRecordset("bdgt_NMG")

-                    .sale_plan = dbRecordset("sale_PLAN")

-                 End With

-                 

-                 allBDGT(index) = tmpBDGT

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbInsert_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "lpu_budget", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    dbRecordset("entry_date") = objBDGT.entry_date

-    dbRecordset("lpu_id") = objBDGT.lpu_id

-    dbRecordset("bdgt_NMG") = objBDGT.bdgt_NMG

-    dbRecordset("bdgt_NFG") = objBDGT.bdgt_NFG

-    dbRecordset("sale_PLAN") = objBDGT.sale_plan

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objBDGT.id = dbRecordset("id")

-  

-End Sub

-

-Public Sub dbUpdate_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu_budget SET " & _

-    "entry_date='" & objBDGT.entry_date & "'," & _

-    "lpu_id=" & objBDGT.lpu_id & "," & _

-    "bdgt_NMG=" & objBDGT.bdgt_NMG & "," & _

-    "bdgt_NFG=" & objBDGT.bdgt_NFG & "," & _

-    "sale_PLAN=" & objBDGT.sale_plan & _

-    " WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-Public Sub dbDelete_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_BDGT_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbDatabase
->>>>>>
-Attribute VB_Name = "dbDatabase"

-Option Explicit

-

-

-Sub dbOpenConnection(dbConnection As Object)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, SQL As String)

-    dbConnection.Execute (SQL)

-End Sub

-

-<<<<<<
-======================
-dbLPU
->>>>>>
-Attribute VB_Name = "dbLPU"

-Option Explicit

-

-Public Type tLPU

-    id As Long

-    rep_id As Long

-    name As String

-    address As String

-    beds As Integer

-End Type

-

-Function Get_LPU_Record(ByVal lpu_id As Long) As tLPU

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_LPU_Record = dbGet_LPU_Record(dbConnection, lpu_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAllLPU(allLPU() As tLPU) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAllLPU = dbGetAllLPU(dbConnection, allLPU)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAllLPUbyQTR(allLPU() As tLPU, ent_date As String) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAllLPUbyQTR = dbGetAllLPUbyQTR(dbConnection, allLPU, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objLPU.id = 0 then insert else update

-Sub Insert_LPU_Record(ByRef objLPU As tLPU)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    If objLPU.id = 0 Then

-        dbInsert_LPU_Record dbConnection, objLPU

-    Else

-        dbUpdate_LPU_Record dbConnection, objLPU

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub Delete_LPU_Record(ByRef objLPU As tLPU)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDelete_LPU_Record dbConnection, objLPU

-    dbCloseConnection dbConnection

-End Sub

-

-Sub Delete_LPU_RecordQTR(ByRef objLPU As tLPU, ent_date As String)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Hir_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Ter_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_ACS_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    

-    dbCloseConnection dbConnection

-    

-End Sub

-

-Function dbGet_LPU_Record(dbConnection As Object, ByVal lpu_id As Long) As tLPU

-    

-    Dim SQL As String

-    Dim objLPU As tLPU

-    

-    objLPU.id = lpu_id

-    objLPU.name = ""

-    objLPU.address = ""

-    

-    SQL = "SELECT * FROM lpu WHERE id=" & lpu_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objLPU.name = dbRecordset("name")

-        objLPU.address = dbRecordset("address")

-        objLPU.rep_id = dbRecordset("rep_id")

-        objLPU.beds = dbRecordset("beds")

-    End If

-    

-    dbGet_LPU_Record = objLPU

-

-End Function

-

-Sub dbInsert_LPU_Record(dbConnection As Object, ByRef objLPU As tLPU)

-  

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu", dbConnection, 2, 2

-    dbRecordset.addnew

-    dbRecordset("name") = objLPU.name

-    dbRecordset("address") = objLPU.address

-    dbRecordset("rep_id") = objLPU.rep_id

-    dbRecordset("beds") = objLPU.beds

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objLPU.id = dbRecordset("id")

-  

-End Sub

-

-Sub dbUpdate_LPU_Record(dbConnection As Object, ByRef objLPU As tLPU)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu SET " & _

-    "name='" & objLPU.name & "'," & _

-    "address='" & objLPU.address & "'," & _

-    "beds=" & objLPU.beds & "," & _

-    "rep_id=" & objLPU.rep_id& & _

-    " WHERE id=" & objLPU.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-

-Function dbGetAllLPU(dbConnection As Object, allLPU() As tLPU) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu"

-    getAll_LPU_SQL = "SELECT * FROM lpu"

-

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAllLPU = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-Function dbGetAllLPUbyQTR(dbConnection As Object, allLPU() As tLPU, ent_date As String) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    Dim where As String

-    where = "WHERE lpu_budget.entry_date like '" & ent_date & "'"

-    

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu_budget " & where

-    

-    getAll_LPU_SQL = "SELECT lpu.id as id, lpu.rep_id as rep_id, lpu.name as name, lpu.address as address, lpu.beds AS beds " & _

-    "FROM lpu, lpu_budget " & where & " AND lpu.id=lpu_budget.lpu_id"

-    

-

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAllLPUbyQTR = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-Sub dbDelete_LPU_Record(dbConnection As Object, ByRef objLPU As tLPU)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu " & _

-    "WHERE id=" & objLPU.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByLPU_ID dbConnection, objLPU.id

-    dbDelete_Hir_RecordsByLPU_ID dbConnection, objLPU.id

-    dbDelete_Ter_RecordsByLPU_ID dbConnection, objLPU.id

-    dbDelete_ACS_RecordsByLPU_ID dbConnection, objLPU.id

-    

-End Sub

-

-Sub dbDelete_LPU_RecordQTR(dbConnection As Object, ByRef objLPU As tLPU, ent_date As String)

-    

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Hir_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Ter_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_ACS_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    

-End Sub

-

-<<<<<<
-======================
-dbREP
->>>>>>
-Attribute VB_Name = "dbREP"

-Option Explicit

-

-Public Type tREP

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function GetREPRecord() As tREP

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetREPRecord = dbGetREPRecord(dbConnection)

-    dbCloseConnection dbConnection

-End Function

-

-Sub SetREPRecord(cUser As tREP)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbSetREPRecord dbConnection, cUser

-    dbCloseConnection dbConnection

-End Sub

-

-Sub ReSetREPRecord()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbReSetREPRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGetREPRecord(dbConnection As Object) As tREP

-    

-    Dim SQL As String

-    Dim objREP As tREP

-    

-    objREP.FirstName = ""

-    objREP.LastName = ""

-    objREP.Region = 0

-    objREP.City = 0

-    SQL = "SELECT firstname, lastname, region, city FROM " & _

-          "rep"

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open SQL, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREP.FirstName = dbRecordset("firstname")

-        objREP.LastName = dbRecordset("lastname")

-        objREP.Region = dbRecordset("region")

-        objREP.City = dbRecordset("city")

-        

-    End If

-    

-    dbGetREPRecord = objREP

-        

-End Function

-

-Public Sub dbSetREPRecord(dbConnection As Object, ByRef objREP As tREP)

-  

-    Dim DeleteSQL As String

-    Dim InsertSQL As String

-    

-    DeleteSQL = "DELETE FROM rep"

-    InsertSQL = "INSERT INTO rep (firstname, lastname, region, city) VALUES (" & _

-    "'" & objREP.FirstName & "', " & _

-    "'" & objREP.LastName & "', " & _

-    objREP.Region & ", " & _

-    objREP.City & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    dbRecordset.Open InsertSQL, dbConnection

-End Sub

-

-Public Sub dbReSetREPRecord(dbConnection As Object)

-  

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM rep"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    CheckWorkBooksArround Wb

-End Sub

-

-

-Sub CheckWorkBooksArround(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If app.Workbooks.Count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKOnly, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-        Exit Sub

-    End If

-

-End Sub

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub SaveExcelState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-        ActiveWorkbook.DisplayDrawingObjects = xlDisplayShapes

-        

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.Count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars(STDBAR_NAME).Visible = False

-End Sub

-

-

-Public Sub RestoreExcelState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars(STDBAR_NAME).Visible = True

-End Sub

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Public Const STDBAR_NAME = "Worksheet Menu Bar"

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Export"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 620

-                        .OnAction = "cmExport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Exit && Restore Excel"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 548

-                        .OnAction = "cmExitRestore"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(flag As Boolean)

-    If flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars(STDBAR_NAME)

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmExport()

-    dbExport

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    Dim dlg As dlgAbout

-    Set dlg = New dlgAbout

-    

-    dlg.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlg.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlg.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlg.Show

-End Sub

-

-Sub cmMail2Support()

-    Dim err_description As String

-    Dim dlg_msg As dlg_Mail

-    Set dlg_msg = New dlg_Mail

-    With dlg_msg

-        .Show

-        If .Tag = vbOK Then

-            ThisWorkbook.Worksheets(VAR_SHEET).Range("ERR_MESSAGE") _

-                = .tbMessage.Text

-            ThisWorkbook.Save

-            ThisWorkbook.SendMail Recipients:="infra@i-rs.ru", Subject:=PROGRAM_NAME & " ver.:" & PROGRAM_VERSION

-            MsgBox "Сообщение об ошибке отправлено. Перезагрузите программу.", vbOKOnly, PROGRAM_NAME

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-    End With

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-'        helppath = "hh.exe " & .Path & "\Telfast.chm"

-'        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub set_work_mode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetupEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-End Sub

-

-Sub cmSetStandaloneMode()

-    set_work_mode

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    Dim dlg As dlgGetPwd

-    rp = common_pwd

-    

-    Set dlg = New dlgGetPwd

-    dlg.edPwd = ""

-    dlg.Show

-    

-    If dlg.edPwd = rp Then

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmHomePage()

-    ThisWorkbook.Worksheets("REP_QTR").Select

-End Sub

-

-Sub cmExitRestore()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = True

-    Application.Quit

-End Sub

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    Dim dlg_prn As dlgPrint

-    

-    Set dlg_prn = New dlgPrint

-    

-    With dlg_prn

-        .cbMainReport = True

-        .cbMainBudget = False

-        .cbSrcData = False

-        .cbAllSheets = False

-    

-        .Show

-    

-        If .Tag = vbCancel Then

-            Exit Sub

-        End If

-    End With

-    

-    Dim PrnIdx As Integer

-    

-    With dlg_prn

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("REP_QTR", "budget", "Final")

-    Case 1111

-        plist = Array("REP_QTR", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("REP_QTR")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Clexane bar"

-Public Const common_pwd As String = "crdjhxtyjr"

-

-

-Sub SetupEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    Wb.Worksheets(TITLE_SHEET).Select

-    With Application

-        .Caption = PROGRAM_NAME & " " & PROGRAM_VERSION

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .SaveExcelState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = False

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Wb.Worksheets(TITLE_SHEET).Select

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-'                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    If cWindow.Type = xlWorkbook Then

-                        cWindow.DisplayHeadings = True

-                    End If

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu True

-        End If

-        With mobjAppState

-            .RestoreExcelState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Worksheets(TITLE_SHEET).Select

-'        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Option Explicit

-

-Sub UpdateHWRecords(objHW() As Long)

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    dbUpdateHWRecords dbConnection, objHW

-    dbCloseConnection dbConnection

-End Sub

-

-Function GetHWRecords(objHW() As Long) As Integer

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    GetHWRecords = dbGetHWRecords(dbConnection, objHW)

-    dbCloseConnection dbConnection

-End Function

-

-Sub HWReset()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbInsertHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    

-    Dim dbRecordset As Object

-    Dim i As Long

-    

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "hw", dbConnection, 2, 2

-    

-    For i = 1 To UBound(objHW)

-        dbRecordset.addnew

-        dbRecordset("num") = objHW(i)

-        dbRecordset.Update

-    Next i

-    

-End Sub

-

-Sub dbUpdateHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    dbDeleteHWRecord dbConnection

-    dbInsertHWRecords dbConnection, objHW

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-dbHir
->>>>>>
-Attribute VB_Name = "dbHir"

-Option Explicit

-

-Public Type tHIRURGIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    operations_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_ambulator_clexan_40mg As Integer

-    patients_ambulator_clexan_20mg As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-    patients_stationar_clexan_40mg As Integer

-    patients_stationar_clexan_20mg As Integer

-End Type

-

-' if objHir.ID <> 0 then updatre else insert

-Sub Insert_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objHir.id <> 0 Then

-        dbUpdate_Hir_Record dbConnection, objHir

-    Else

-        dbInsert_Hir_Record dbConnection, objHir

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Hir_RecordsByLPU_ID(ByRef allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Hir_RecordsByLPU_ID = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, allHir, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Hir_Record dbConnection, objHir

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objHir.ID <> 0 then updatre else insert

-

-Sub dbInsert_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_hir", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objHir

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("operations_per_quarter") = .operations_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_ambulator_clexan_20mg") = .patients_ambulator_clexan_20mg

-        dbRecordset("patients_ambulator_clexan_40mg") = .patients_ambulator_clexan_40mg

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-        dbRecordset("patients_stationar_clexan_20mg") = .patients_stationar_clexan_20mg

-        dbRecordset("patients_stationar_clexan_40mg") = .patients_stationar_clexan_40mg

-        

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objHir.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim UpdateSQL As String

-    

-    With objHir

-        UpdateSQL = "UPDATE lpu_hir SET " & _

-            "entry_date='" & objHir.entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "operations_per_quarter=" & .operations_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_ambulator_clexan_20mg=" & .patients_ambulator_clexan_20mg & "," & _

-            "patients_ambulator_clexan_40mg=" & .patients_ambulator_clexan_40mg & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & "," & _

-            "patients_stationar_clexan_20mg=" & .patients_stationar_clexan_20mg & "," & _

-            "patients_stationar_clexan_40mg=" & .patients_stationar_clexan_40mg & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_Hir_RecordsbyLPU_ID(dbConnection As Object, allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Hir_SQL As String

-    Dim getAll_Hir_SQL As String

-    Dim Hir_Count As Long

-    Hir_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Hir_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Hir_Count = dbRecordset("HIR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Hir_RecordsbyLPU_ID = Hir_Count

-    

-    If Hir_Count > 0 Then

-        'we have records

-        ReDim allHir(1 To Hir_Count)

-        Dim index As Integer

-        index = 1

-        dbRecordset.Open getAll_Hir_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpHir As tHIRURGIA

-                 With tmpHir

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .operations_per_quarter = dbRecordset("operations_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_ambulator_clexan_20mg = dbRecordset("patients_ambulator_clexan_20mg")

-                    .patients_ambulator_clexan_40mg = dbRecordset("patients_ambulator_clexan_40mg")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                    .patients_stationar_clexan_20mg = dbRecordset("patients_stationar_clexan_20mg")

-                    .patients_stationar_clexan_40mg = dbRecordset("patients_stationar_clexan_40mg")

-                 End With

-                 

-                 allHir(index) = tmpHir

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE ID=" & objHir.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Hir_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbTer
->>>>>>
-Attribute VB_Name = "dbTer"

-Option Explicit

-

-Public Type tTERAPIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objTer.ID <> 0 then updatre else insert

-Sub Insert_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objTer.id <> 0 Then

-        dbUpdate_Ter_Record dbConnection, objTer

-    Else

-        dbInsert_Ter_Record dbConnection, objTer

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Ter_RecordsByLPU_ID(ByRef allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Ter_RecordsByLPU_ID = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, allTer, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Ter_Record dbConnection, objTer

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objTer.ID <> 0 then updatre else insert

-

-Sub dbInsert_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_ter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objTer

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("risk_percent") = Double2Str(.risk_percent, 3)

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objTer.id = dbRecordset("ID")

-

-End Sub

-

-Sub test()

-    Dim s As String

-    Dim d As Single

-    d = 1235.6789

-    s = Format(d, "####0,00")

-    MsgBox s

-End Sub

-

-Sub dbUpdate_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim Update_SQL As String

-    

-    With objTer

-        Update_SQL = "UPDATE lpu_ter SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_Ter_RecordsbyLPU_ID(dbConnection As Object, allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Ter_SQL As String

-    Dim getAll_Ter_SQL As String

-    Dim Ter_Count As Long

-    Ter_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Ter_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Ter_Count = dbRecordset("TER_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Ter_RecordsbyLPU_ID = Ter_Count

-    

-    If Ter_Count > 0 Then

-        'we have records

-        ReDim allTer(1 To Ter_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_Ter_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpTer As tTERAPIA

-                 With tmpTer

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 allTer(index) = tmpTer

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE ID=" & objTer.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Ter_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-mLPU_LIST
->>>>>>
-Attribute VB_Name = "mLPU_LIST"

-Option Explicit

-

-Public Const CINP_AREA As String = "B12"

-Public Const CLPU_NAME As Integer = 0

-Public Const CLPU_NAME1 As Integer = 1

-Public Const CLPU_NAME2 As Integer = 2

-Public Const CLPU_ID As Integer = 3

-Public Const CLPU_BEDS As Integer = 4

-Public Const CLPU_NFG As Integer = 5

-Public Const CLPU_NMG As Integer = 6

-Public Const CLPU_HIR As Integer = 7

-Public Const CLPU_TER As Integer = 8

-Public Const CLPU_CAR As Integer = 9

-Public Const CLPU_FACT As Integer = 10

-Public Const CLPU_PLAN As Integer = 11

-Public Const CLPU_PAT_LPU As Integer = 16

-Public Const CLPU_BDGT As Integer = 17

-Public Const CLPU_PAT_ALL As Integer = 16

-

-

-

-Sub EditLPU(cLPU As tLPU, ent_date As String)

-    Dim del_request As Integer

-    Dim allLPU() As tLPU

-    Dim lpu_count As Integer

-    Dim i As Integer

-    Dim tmp_LPU_List As Range

-    Dim tmp_LPU_List_Addr As String

-    Dim r_end As Range

-    Dim dlg As Dlg_lpu_card

-    

-    Set dlg = New Dlg_lpu_card

-    

-    lpu_count = GetAllLPU(allLPU)

-    With Worksheets(VAR_SHEET)

-        Set tmp_LPU_List = .Range("tmp_LPU_List")

-        Set r_end = .Range(tmp_LPU_List, tmp_LPU_List.End(xlDown))

-        Set r_end = .Range(r_end, r_end.End(xlToRight))

-        .Range(tmp_LPU_List, r_end).ClearContents

-    End With

-        

-    If lpu_count <> 0 Then

-        dlg.cbxLPU_List_Enable.Enabled = True

-        For i = 1 To UBound(allLPU)

-            tmp_LPU_List.Cells(i, 1) = allLPU(i).name

-            tmp_LPU_List.Cells(i, 2) = allLPU(i).address

-            tmp_LPU_List.Cells(i, 3) = allLPU(i).beds

-            tmp_LPU_List.Cells(i, 4) = allLPU(i).id

-        Next i

-    Else

-        dlg.cbxLPU_List_Enable.Enabled = False

-    End If

-    

-    tmp_LPU_List_Addr = Worksheets(VAR_SHEET).name & "!" & _

-            Worksheets(VAR_SHEET).Range(tmp_LPU_List, tmp_LPU_List.End(xlDown)).address

-

-    With dlg

-        .cbLPU_List.RowSource = tmp_LPU_List_Addr

-        .cbLPU_List.ListIndex = 0

-        .cbxLPU_List_Enable = False

-        .cbLPU_List.Enabled = False

-        If cLPU.id <> 0 Then

-            .cbxLPU_List_Enable.Enabled = False

-        Else

-            If lpu_count <> 0 Then

-                .cbxLPU_List_Enable.Enabled = True

-            Else

-                .cbxLPU_List_Enable.Enabled = False

-            End If

-        End If

-        .tb_lpu_name.Text = cLPU.name

-        .tb_lpu_address.Text = cLPU.address

-        .tbBedsCount = cLPU.beds

-

-        .Tag = vbCancel

-    End With

-    

-    dlg.Show

-    

-    If Not IsNumeric(dlg.Tag) Then

-        Exit Sub

-    End If

-    

-    If dlg.Tag = vbOK Then

-        Dim n As Variant

-        Dim test As Integer

-        test = 0

-        n = dlg.tbBedsCount.Value

-        If Not IsNumeric(n) Then

-            test = 1

-        Else

-            If n = 0 Then

-                test = 1

-            End If

-        End If

-        If test = 0 Then

-            

-            cLPU.name = dlg.tb_lpu_name.Text

-            cLPU.address = dlg.tb_lpu_address.Text

-            cLPU.beds = dlg.tbBedsCount.Value

-                                    

-            If cLPU.name = "" Or cLPU.address = "" Then

-                test = 2

-            End If

-        End If

-        Select Case test

-            Case 0

-                If dlg.cbxLPU_List_Enable.Value = True Then

-                    cLPU.id = tmp_LPU_List.Cells(dlg.cbLPU_List.ListIndex + 1, 4)

-                End If

-                Insert_LPU_Record cLPU

-                ' Проверить наличие данных для ЛПУ в квартале

-                Dim bdgt As tBUDGET

-                bdgt = Get_BDGT_Record(cLPU.id, ent_date)

-                ' Записи нет: создать пустую запись в lpu_budget

-                If bdgt.id = 0 Then

-                    bdgt.lpu_id = cLPU.id

-                    bdgt.entry_date = ent_date

-                    Insert_BDGT_Record bdgt

-                End If

-            Case 1

-                MsgBox "Коечная мощьность измеряется числом более чем 1!", vbOKOnly, PROGRAM_NAME

-            Case 2

-                MsgBox "Наименование и адрес ЛПУ не должны быть пустыми!", vbOKOnly, PROGRAM_NAME

-        End Select

-    End If

-End Sub

-

-Sub Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-

-End Sub

-

-Sub Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btLPU_DEL_IT()

-    Dim cLPU As tLPU

-    Dim ent_date As String

-    Dim delete_all As Integer

-    Dim dlg_del As dlg_LPU_delete

-    

-    With Worksheets("LPU_LIST")

-        ent_date = .Range("ent_date")

-        cLPU.id = .getCurrentLPU_ID()

-    End With

-    

-    If cLPU.id = 0 Then

-        MsgBox "Укажите удаляемый объект", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    cLPU = Get_LPU_Record(cLPU.id)

-    

-    Set dlg_del = New dlg_LPU_delete

-    With dlg_del

-        .chbDeleteQTR.Value = True

-        .chbDeleteAll.Value = False

-        .lComment = ent_date & ": Удаление ЛПУ '" _

-        & cLPU.name & "', расположенного по адресу:" _

-        & cLPU.address & "."

-        .Show

-        

-        If .Tag = vbOK Then

-            If .chbDeleteAll.Value Then

-                delete_all = _

-                    MsgBox("Все записи об ЛПУ с именем '" & cLPU.name & _

-                    "' будут удалены навсегда.", vbOK, PROGRAM_NAME)

-                If delete_all = vbOK Then

-                    Delete_LPU_Record cLPU

-                End If

-            Else

-                Delete_LPU_RecordQTR cLPU, ent_date

-            End If

-        End If

-    End With

-    

-    With ThisWorkbook

-        .Worksheets(TITLE_SHEET).Select

-        .Worksheets("LPU_LIST").Select

-    End With

-End Sub

-

-Sub btLPU_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Activate

-End Sub

-

-

-Sub btLPU_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim lpu_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("QTR_ACTION").Value

-    With Worksheets("LPU_LIST")

-        ent_date = .getEnt_date()

-        

-    

-        lpu_id = .getCurrentLPU_ID

-        If lpu_id <> 0 And i = 1 Then

-            lpu_id = 0

-        End If

-        If lpu_id = 0 Then

-            i = 1

-        End If

-        Select Case i

-            Case 1, 6

-                .SelectLPU_NAME lpu_id, ent_date

-                .Range("JUMP") = ""

-            Case 2

-                If lpu_id <> 0 Then

-                    .SelectLPU_BDGT lpu_id, ent_date

-                    .Range("JUMP") = "LPU_BDGT"

-                End If

-            Case 3

-                If lpu_id <> 0 Then

-                    .SelectLPU_HIR lpu_id, ent_date

-                    .Range("JUMP") = "LPU_CLSN_HIR"

-                End If

-            Case 4

-                If lpu_id <> 0 Then

-                    .SelectLPU_TER lpu_id, ent_date

-                    .Range("JUMP") = "LPU_CLSN_TER"

-                End If

-            Case 5

-                If lpu_id <> 0 Then

-                    .SelectLPU_C_ACS lpu_id, ent_date

-                    .Range("JUMP") = "LPU_CLSN_C_ACS"

-                End If

-        End Select

-    End With

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-dbQTR
->>>>>>
-Attribute VB_Name = "dbQTR"

-Option Explicit

-

-Public Type tQTR

-    id As Long

-    entry_date As String

-    rep_id As Long

-    sale_plan As Long

-    ClxnH20mg As Long

-    ClxnH40mg As Long

-    ClxnT40mg As Long

-    ClxnC_IM As Long

-    ClxnC_ACS As Long

-End Type

-

-

-Function GetLastQTR_fromDB() As String

-    Dim dbConnection As Object

-    Dim getCount_QTR_SQL As String

-    Dim getLast_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter"

-    getLast_QTR_SQL = "SELECT MAX(entry_date) as ent_date FROM quarter"

-    

-    dbOpenConnection dbConnection

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    If QTR_Count > 0 Then

-        'we have records

-        dbRecordset.Open getLast_QTR_SQL, dbConnection

-        getLast_QTR_SQL = dbRecordset("ent_date")

-    Else

-        getLast_QTR_SQL = ""

-    End If

-    

-    GetLastQTR_fromDB = getLast_QTR_SQL

-    dbCloseConnection dbConnection

-End Function

-

-Sub Insert_QTR_Record(ByRef objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objQTR.id <> 0 Then

-        dbUpdate_QTR_Record dbConnection, objQTR

-    Else

-        dbInsert_QTR_Record dbConnection, objQTR

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-Function Get_QTR_Record(ent_date As String) As tQTR

-    Dim dbConnection As Object

-    Dim allQTR() As tQTR

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    i = dbGetAll_QTR_Records(dbConnection, allQTR, ent_date)

-    If i <> 0 Then

-        Get_QTR_Record = allQTR(1)

-    End If

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTR_Records(ByRef All_QTR() As tQTR, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_QTR_Records = dbGetAll_QTR_Records(dbConnection, All_QTR, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_QTR_Record(ByRef objQTR As tQTR)

-    Dim dbConnection As Object

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_QTR_Record dbConnection, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objQTR.ID <> 0 then updatre else insert

-Sub dbInsert_QTR_Record(dbConnection As Object, ByRef objQTR As tQTR)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "quarter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objQTR

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("sale_plan") = .sale_plan

-        dbRecordset("rep_id") = .rep_id

-        dbRecordset("ClxnH20mg") = .ClxnH20mg

-        dbRecordset("ClxnH40mg") = .ClxnH40mg

-        dbRecordset("ClxnT40mg") = .ClxnT40mg

-        dbRecordset("ClxnC_IM") = .ClxnC_IM

-        dbRecordset("ClxnC_ACS") = .ClxnC_ACS

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objQTR.id = dbRecordset("id")

-

-End Sub

-

-Sub dbUpdate_QTR_Record(dbConnection As Object, ByRef objQTR As tQTR)

-    Dim Update_SQL As String

-    

-    With objQTR

-        Update_SQL = "UPDATE quarter SET " & _

-            "entry_date='" & .entry_date & "'" & "," & _

-            "rep_id=" & .rep_id & "," & _

-            "sale_plan=" & .sale_plan & "," & _

-            "ClxnH20mg=" & .ClxnH20mg & "," & _

-            "ClxnH40mg=" & .ClxnH40mg & "," & _

-            "ClxnT40mg=" & .ClxnT40mg & "," & _

-            "ClxnC_IM=" & .ClxnC_IM & "," & _

-            "ClxnC_ACS=" & .ClxnC_ACS & _

-            " WHERE id=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if ent_date = % then all_records

-Function dbGetAll_QTR_Records(dbConnection As Object, All_QTR() As tQTR, ent_date As String) As Integer

-    

-    Dim getCount_QTR_SQL As String

-    Dim getAll_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter WHERE entry_date like '" & ent_date & "'"

-    getAll_QTR_SQL = "SELECT * FROM quarter WHERE entry_date like '" & ent_date & "' ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_QTR_Records = QTR_Count

-    

-    If QTR_Count > 0 Then

-        'we have records

-        ReDim All_QTR(1 To QTR_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTR_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTR As tQTR

-                 With tmp_QTR

-                    .entry_date = dbRecordset("entry_date")

-                    .rep_id = dbRecordset("rep_id")

-                    .sale_plan = dbRecordset("sale_plan")

-                    .ClxnH20mg = dbRecordset("ClxnH20mg")

-                    .ClxnH40mg = dbRecordset("ClxnH40mg")

-                    .ClxnT40mg = dbRecordset("ClxnT40mg")

-                    .ClxnC_IM = dbRecordset("ClxnC_IM")

-                    .ClxnC_ACS = dbRecordset("ClxnC_ACS")

-                    .id = dbRecordset("id")

-                 End With

-                 

-                 All_QTR(index) = tmp_QTR

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_QTR_Record(dbConnection As Object, ByRef objQTR As tQTR)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM quarter " & _

-    "WHERE id=" & objQTR.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByQTR dbConnection, objQTR.entry_date

-    dbDelete_Hir_RecordsByQTR dbConnection, objQTR.entry_date

-    dbDelete_Ter_RecordsByQTR dbConnection, objQTR.entry_date

-    dbDelete_ACS_RecordsByQTR dbConnection, objQTR.entry_date

-       

-End Sub

-<<<<<<
-======================
-cdbQTR
->>>>>>
-Attribute VB_Name = "cdbQTR"

-Option Explicit

-

-Public Type tQTR_COMMON

-    qtr As tQTR

-    i_lcd As Long           ' число ЛПУ в СПИСКЕ

-    lcd() As tLPU_COMMON    ' список ЛПУ

-    c_beds As Long          ' сумма коек

-    c_bdgt_NFG As Long      ' общий бюджет на НФГ

-    c_bdgt_NMG As Long      ' общий бюджет на НМГ

-    c_bdgt_LPU As Long      ' общий бюджет на гепарины

-    c_sale_PLAN As Long     ' план продаж репа

-    c_sale_ALL As Long      ' продажи

-    c_sale_HIR As Long      ' в хирургии

-    c_sale_TER  As Long     ' в терапии

-    c_sale_CRD  As Long     ' в кардиологии

-    c_pat_HIR   As Long     ' пациенты

-    c_pat_TER   As Long     '

-    c_pat_CRD   As Long     '

-    c_pat_ALL   As Long     '

-    c_pat_LPU   As Long     ' Всего операций

-End Type

-

-Function Get_QTR_CommonList(ByRef qcd() As tQTR_COMMON) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_QTR_CommonList = dbGet_QTR_CommonList(dbConnection, qcd)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_CommonList(dbConnection As Object, ByRef qcd() As tQTR_COMMON) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim allQTR() As tQTR

-    i = dbGetAll_QTR_Records(dbConnection, allQTR, "%")

-    dbGet_QTR_CommonList = i

-    If i > 0 Then

-        ReDim qcd(i)

-        For i = 1 To UBound(allQTR)

-            With qcd(i)

-                .qtr = allQTR(i)

-                .c_beds = 0

-                .c_bdgt_NFG = 0

-                .c_bdgt_NMG = 0

-                .c_bdgt_LPU = 0

-                .c_sale_PLAN = 0

-                .c_pat_HIR = 0

-                .c_pat_TER = 0

-                .c_pat_CRD = 0

-                .c_pat_ALL = 0

-                .c_sale_HIR = 0

-                .c_sale_TER = 0

-                .c_sale_CRD = 0

-                .c_sale_ALL = 0

-                .c_pat_LPU = 0

-                

-                j = dbGet_LPU_CommonQTR(dbConnection, .lcd, .qtr)

-                .i_lcd = j

-                If j > 0 Then

-                    For j = 1 To UBound(.lcd)

-                        .c_beds = .c_beds + .lcd(j).lpu.beds

-                        .c_bdgt_NFG = .c_bdgt_NFG + .lcd(j).bdgt.bdgt_NFG

-                        .c_bdgt_NMG = .c_bdgt_NMG + .lcd(j).bdgt.bdgt_NMG

-                        .c_bdgt_LPU = .c_bdgt_LPU + .lcd(j).bdgt_LPU

-                        .c_sale_PLAN = .c_sale_PLAN + .lcd(j).bdgt.sale_plan

-                        .c_pat_HIR = .c_pat_HIR + .lcd(j).pat_HIR

-                        .c_pat_TER = .c_pat_TER + .lcd(j).pat_TER

-                        .c_pat_CRD = .c_pat_CRD + .lcd(j).pat_CRD

-                        .c_pat_ALL = .c_pat_ALL + .lcd(j).pat_ALL

-                        .c_sale_HIR = .c_sale_HIR + .lcd(j).sale_HIR

-                        .c_sale_TER = .c_sale_TER + .lcd(j).sale_TER

-                        .c_sale_CRD = .c_sale_CRD + .lcd(j).sale_CRD

-                        .c_sale_ALL = .c_sale_ALL + .lcd(j).sale_ALL

-                        .c_pat_LPU = .c_pat_LPU + .lcd(j).pat_LPU

-                    Next j

-                    

-                End If

-            End With

-        Next i

-    End If

-End Function

-

-Function GetLastQtr() As String

-    Dim s As String

-    Dim r As Range

-    Set r = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Do While r.Cells(1, 1) <> ""

-        s = r.Cells(1, 1)

-        Set r = r.Cells.Offset(1, 0)

-    Loop

-    GetLastQtr = s

-End Function

-

-Function GetNextQTR(ent_date As String) As String

-    Dim rd As Range

-    Dim idx As Integer

-    Dim b As Variant

-    Dim dlg As dlg_newQTR

-    Set dlg = New dlg_newQTR

-    

-    On Error GoTo l_exit

-    If ent_date = "" Then

-        Dim ir As Variant

-        idx = 0

-        dlg.Show

-        b = dlg.Tag

-            

-        If IsNumeric(b) Then

-            GetNextQTR = dlg.cbQTR

-        Else

-            GetNextQTR = ""

-        End If

-    Else

-        Set rd = Worksheets(VAR_SHEET).Range("Date_Lst")

-        idx = WorksheetFunction.Match(ent_date, rd, 0)

-        GetNextQTR = WorksheetFunction.index(rd, idx + 1, 1)

-    End If

-l_exit:

-End Function

-<<<<<<
-======================
-mRestView
->>>>>>
-Attribute VB_Name = "mRestView"

-Option Explicit

-

-Sub xlRestoreView()

-Attribute xlRestoreView.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute xlRestoreView.VB_ProcData.VB_Invoke_Func = " \n14"

-    With Application

-        .CommandBars("Standard").Visible = True

-        .CommandBars("Formatting").Visible = True

-        .DisplayFormulaBar = True

-        .DisplayStatusBar = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = True

-        .EditDirectlyInCell = True

-    End With

-End Sub

-<<<<<<
-======================
-dlg_newQTR
->>>>>>
-Attribute VB_Name = "dlg_newQTR"

-Attribute VB_Base = "0{2FC04B4C-EB99-433E-ACDB-A920D02B9B5B}{777B85CC-ADE3-4188-94C8-9E07DA8B5076}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mDec2TS
->>>>>>
-Attribute VB_Name = "mDec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-CHRT_LPU_BBL
->>>>>>
-Attribute VB_Name = "CHRT_LPU_BBL"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Unprotect

-    Range("view_key") = True

-    On Error Resume Next

-    ChangeLabels

-    Range("A1").Select

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Unprotect

-    Dim s As String

-    s = Range("ret_addr")

-    Protect UserInterfaceOnly:=True

-    Wks_select (s)

-End Sub

-

-Sub BCLabelChng_Click()

-    Unprotect

-    If Range("view_key") Then

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать названия"

-    Else

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать объемы"

-    End If

-    Range("view_key") = Not Range("view_key")

-    ChangeLabels

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub ChangeLabels()

-    Dim i As Integer

-    Dim offset_text As Integer

-    Dim src As Range

-    Set src = Range("CHRT_BBL_DATA")

-    

-    offset_text = 3

-    If Range("view_key") Then

-        offset_text = 4

-    End If

-    

-    On Error GoTo ExitLabel

-    

-    With ChartObjects(1).Chart

-        With .SeriesCollection(1)

-            For i = 1 To .Points.Count

-                On Error Resume Next

-                .Points(i).DataLabel.Characters.Text = Format(src.Cells(i, offset_text))

-            Next i

-        End With

-    End With

-ExitLabel:

-End Sub

-

-<<<<<<
-======================
-CHRT_PAT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PAT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-<<<<<<
-======================
-CHRT_PAT_LPU
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_nextQTR
->>>>>>
-Attribute VB_Name = "dlg_nextQTR"

-Attribute VB_Base = "0{3F7D7D75-90F6-4829-9E24-CA5391BB2A03}{A1A0F296-0D28-4123-8E38-82FA6EE6F2EF}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-

-<<<<<<
-======================
-cdbLPU
->>>>>>
-Attribute VB_Name = "cdbLPU"

-Option Explicit

-

-Public Type tLPU_COMMON

-    lpu As tLPU

-    bdgt As tBUDGET

-    i_hir As Long

-    hir() As tHIRURGIA

-    i_ter As Long

-    ter() As tTERAPIA

-    i_ACS As Long

-    ACS() As tACS

-    bdgt_LPU As Long

-    sale_HIR As Long

-    sale_TER As Long

-    sale_CRD As Long

-    sale_ALL As Long

-    pat_HIR As Long

-    pat_TER As Long

-    pat_CRD As Long

-    pat_ALL As Long     ' Сумма всех пациентов на клексане

-    pat_LPU As Long     ' Число потенциальных пациентов для продаж клексана

-End Type

-

-Function Get_LPU_CommonQTR(ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    Get_LPU_CommonQTR = dbGet_LPU_CommonQTR(dbConnection, lcd, objQTR)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_CommonQTR(dbConnection As Object, ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    i = dbGetAllLPUbyQTR(dbConnection, allLPU, objQTR.entry_date)

-    dbGet_LPU_CommonQTR = i

-    If i > 0 Then

-        ReDim lcd(i)

-        For i = 1 To UBound(allLPU)

-            dbGet_LPU_Common dbConnection, lcd(i), allLPU(i), objQTR

-        Next i

-    End If

-End Function

-

-Sub Get_LPU_Common(ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    dbGet_LPU_Common dbConnection, lcd, cLPU, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbGet_LPU_Common(dbConnection As Object, ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-

-    lcd.lpu = cLPU

-    lcd.bdgt = dbGet_BDGT_Record(dbConnection, cLPU.id, objQTR.entry_date)

-    lcd.i_hir = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, lcd.hir, cLPU.id, objQTR.entry_date)

-    lcd.i_ter = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, lcd.ter, cLPU.id, objQTR.entry_date)

-    lcd.i_ACS = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, lcd.ACS, cLPU.id, objQTR.entry_date)

-    With lcd

-        .bdgt_LPU = .bdgt.bdgt_NFG + .bdgt.bdgt_NMG

-        .pat_LPU = 0

-        If .i_hir > 0 Then

-            .pat_HIR = .hir(1).patients_ambulator_clexan + .hir(1).patients_stationar_clexan

-            .sale_HIR = objQTR.ClxnH20mg * (.hir(1).patients_ambulator_clexan_20mg + .hir(1).patients_stationar_clexan_20mg)

-            .sale_HIR = .sale_HIR + objQTR.ClxnH40mg * (.hir(1).patients_ambulator_clexan_40mg + .hir(1).patients_stationar_clexan_40mg)

-            .pat_LPU = .pat_LPU + .hir(1).operations_per_quarter

-        End If

-        If .i_ter > 0 Then

-            .pat_TER = .ter(1).patients_ambulator_clexan + .ter(1).patients_stationar_clexan

-            .sale_TER = .pat_TER * objQTR.ClxnT40mg

-            .pat_LPU = .pat_LPU + .ter(1).patients_per_quarter

-        End If

-        If .i_ACS > 0 Then

-            .pat_CRD = .ACS(1).patients_stationar_clexan

-            .sale_CRD = .pat_CRD * objQTR.ClxnC_ACS

-            .pat_LPU = .pat_LPU + .ACS(1).patients_per_quarter

-        End If

-        .pat_ALL = .pat_HIR + .pat_TER + .pat_CRD

-        .sale_ALL = .sale_HIR + .sale_TER + .sale_CRD

-    End With

-End Sub

-

-<<<<<<
-======================
-CHRT_PIE
->>>>>>
-Attribute VB_Name = "CHRT_PIE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-   

-    Unprotect

-    On Error Resume Next

-    Range("P5:Q24").Sort _

-        Key1:=Range("Q5"), _

-        Order1:=xlDescending, _

-        Header:=xlGuess, _

-        OrderCustom:=1, _

-        MatchCase:=False, _

-        Orientation:=xlTopToBottom

-        

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PLN_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PLN_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_BDGT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_BDGT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_LPU_delete
->>>>>>
-Attribute VB_Name = "dlg_LPU_delete"

-Attribute VB_Base = "0{91AE5FA0-01C7-4C10-9E5F-D1D2DDF29401}{5726592A-BC0A-4E79-A963-35D354045716}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlg_Mail
->>>>>>
-Attribute VB_Name = "dlg_Mail"

-Attribute VB_Base = "0{FB055133-927F-41FF-BC90-442833A40591}{11BCAB43-1EDD-440B-AB0E-20CD6E42E11A}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dbREP_id
->>>>>>
-Attribute VB_Name = "dbREP_id"

-Public Type tID_REP

-    id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Public Type tID_REP_COMMON

-    id_rep As tID_REP

-    i_qtr As Long

-    qtrs As tQTR_COMMON

-End Type

-<<<<<<
-======================
-cdbExport
->>>>>>
-Attribute VB_Name = "cdbExport"

-Option Explicit

-

-Function GetDBSN() As String

-    Dim n As Long

-    Randomize Timer

-    n = Int((100000000 - 1000000 + 1) * Rnd + 1000000)

-    GetDBSN = Dec2ThirtySix(n)

-End Function

-

-Sub dbExport()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim last_qtr As String

-    

-    On Error GoTo ErrHandler

-    

-    last_qtr = GetLastQTR_fromDB

-    If last_qtr = "" Then

-        MsgBox "Нет записей в базе данных. Экспорт невозможен.", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & last_qtr & "_" & GetDBSN() & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Данные экспортированы в файл:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для передачи", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-Exit Sub

-

-ErrHandler:

-    If err.number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-<<<<<<
-======================
-mRegs
->>>>>>
-Attribute VB_Name = "mRegs"

-Option Explicit

-

-Function GetRegionName(idx As Integer) As String

-    GetRegionName = Worksheets(REGS_SHEET).Range("LST_REGIONS").Cells(idx + 1, 1).Text

-End Function

-

-Function GetCityName(idx_reg As Integer, idx_city As Integer) As String

-    GetCityName = Worksheets(REGS_SHEET).Range("CITY_TABLES").Offset(idx_city + 1, idx_reg * 2).Text

-End Function

-

-Sub t()

-    Dim r As Integer

-    Dim c As Integer

-    Dim s As String

-    

-    r = 3

-    c = 3

-    s = GetRegionName(r)

-    s = s & ", " & GetCityName(r, c)

-    MsgBox s

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Save

-End Sub

-

-Private Sub Workbook_Open()

-    FindRestoreData

-End Sub

-

-Sub FindRestoreData()

-    Dim i As Integer

-    Dim def_dir As String

-    Dim dbname As String

-    Dim caption As String

-    caption = PROGRAM_NAME + " " + PROGRAM_VERSION

-    If MsgBox("Восстановление данных. Продолжить?", vbYesNo, caption) = vbYes Then

-        def_dir = "C:\CLEXANE"

-        If GetDBName(def_dir, dbname) Then

-            HWReset dbname

-            MsgBox "Данные в файле " + dbname + " восстановлены :)", vbOKOnly, caption

-        Else

-            MsgBox "Выход без изменений"

-        End If

-    End If

-    With Application

-        .DisplayAlerts = False

-        .Quit

-    End With

-End Sub

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mDataBase
->>>>>>
-Attribute VB_Name = "mDataBase"

-Option Explicit

-

-Sub dbOpenConnection(dbConnection As Object, dbname As String)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = dbname

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, SQL As String)

-    dbConnection.Execute (SQL)

-End Sub

-

-

-

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-End Sub

-

-Function Double2Str(ByVal d As Double, ByVal precision As Integer, Optional Delim As String = ".") As String

-    Dim s As String

-    If Not precision > 0 Then

-        s = Round(d)

-    Else

-        Dim i As Integer

-        i = Fix(d)

-        s = i & Delim

-        d = Abs(d - i)

-        Do

-            precision = precision - 1

-            d = d * 10

-            If precision > 0 Then

-                i = Fix(d)

-            Else

-                i = Round(d)

-            End If

-            If i < 1 Then

-                s = s & "0"

-            Else

-                s = s & i

-                d = d - i

-            End If

-        Loop While precision > 0

-    End If

-    Double2Str = s

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetWBName(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBName = Right(FullName, s_len - pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.Count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.Name = VAR_SHEET Or sh.Name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane"

-Public Const PROGRAM_VERSION As String = "version 1.6"

-Public Const PROGRAM_FILENAME As String = "clexane-mr"

-Public Const PROGRAM_EXPORTNAME As String = "mr-ex-"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20030329

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "O40"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Sub HWReset(dbname As String)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection, dbname

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-mGetDBName
->>>>>>
-Attribute VB_Name = "mGetDBName"

-Option Explicit

-

-Const OFN_ALLOWMULTISELECT As Long = 512

-Const OFN_EXPLORER As Long = 524288

-Const OFN_HIDEREADONLY As Long = 4

-Const OFN_NONETWORKBUTTON As Long = 131072

-Const OFN_READONLY As Long = 1

-       

-Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _

-    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

-

-Private Type OPENFILENAME

-    lStructSize As Long

-    hWndOwner As Long

-    hInstance As Long

-    lpstrFilter As String

-    lpstrCustomFilter As String

-    nMaxCustFilter As Long

-    nFilterIndex As Long

-    lpstrFile As String

-    nMaxFile As Long

-    lpstrFileTitle As String

-    nMaxFileTitle As Long

-    lpstrInitialDir As String

-    lpstrTitle As String

-    flags As Long

-    nFileOffset As Integer

-    nFileExtension As Integer

-    lpstrDefExt As String

-    lCustData As Long

-    lpfnHook As Long

-    lpTemplateName As String

-End Type

-

-Function GetDBName(DB_dir As String, dbname As String) As Boolean

-    Dim OpenFile As OPENFILENAME

-    Dim lReturn As Long

-    Dim sFilter As String

-    

-    OpenFile.lStructSize = Len(OpenFile)

-    '         OpenFile.hwndOwner = Form1.hWnd

-    '         OpenFile.hInstance = App.hInstance

-    sFilter = "Clexane Data Files" & Chr(0) & "clexane*.mdb" & Chr(0)

-    OpenFile.lpstrFilter = sFilter

-    OpenFile.nFilterIndex = 1

-    OpenFile.lpstrFile = String(257, 0)

-    OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1

-    OpenFile.lpstrFileTitle = OpenFile.lpstrFile

-    OpenFile.nMaxFileTitle = OpenFile.nMaxFile

-    OpenFile.lpstrInitialDir = DB_dir

-    OpenFile.lpstrTitle = "Исправление данных"

-    OpenFile.flags = OFN_HIDEREADONLY + OFN_EXPLORER

-    lReturn = GetOpenFileName(OpenFile)

-    If lReturn = 0 Then

-        GetDBName = False

-        dbname = ""

-    Else

-        GetDBName = True

-        Dim flist() As String

-        flist = Split(OpenFile.lpstrFile, Chr(0), Compare:=vbBinaryCompare)

-        dbname = flist(0)

-    End If

-End Function

-

-

-<<<<<<
-Project Name : 'ClexaneRM'
-Quirk - duff tag length======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    ThisWorkbook.Worksheets(RM_QTR_SHEET).ClearRMName

-    

-    Application.EnableEvents = True

-    Set MyAppEvents.app = Application

-    

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    

-    MyAppEvents.CheckWorkBooksArround ThisWorkbook

-    

-    cmSetStandaloneMode

-    

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-    

-    Application.ScreenUpdating = True

-    

-    If CheckUser Then

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).update_history

-        Application.Calculate

-    End If

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    

-    Dim RestMode As Boolean

-    RestMode = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE")

-    

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-'        If RestMode Then

-            ThisWorkbook.Saved = True

-'        Else

-'            ThisWorkbook.Save

-'        End If

-    End If

-    Application.Caption = Empty

-    Application.CommandBars(STDBAR_NAME).Reset

-    If RestMode Then

-        xlRestoreView

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    End If

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-    Dim MaxX, MaxY As Integer

-    With ThisWorkbook.Worksheets(TITLE_SHEET)

-        MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-        MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-    End With

-

-    With ThisWorkbook.Application

-        .ScreenUpdating = False

-        .WindowState = xlNormal

-        .Height = MaxY

-        .Width = MaxX

-    End With

-End Sub

-

-

-

-

-

-<<<<<<
-======================
-REP_QTR
->>>>>>
-Attribute VB_Name = "REP_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CQTR_QT As Integer = 0

-Const CQTR_ID As Integer = 1

-Const CQTR_PLN As Integer = 2

-Const CQTR_FCT As Integer = 3

-Const CQTR_BDG As Integer = 4

-Const CQTR_CNT As Integer = 5

-Const CQTR_BEDS As Integer = 6

-Const CQTR_HIR As Integer = 7

-Const CQTR_TER As Integer = 8

-Const CQTR_CRD As Integer = 9

-Const CQTR_CLXN_BDG As Integer = 10

-Const CQTR_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub update_history()

-    Dim objQTR() As tQTR

-    Dim i As Long

-    Dim r As Range

-    Dim cRep As tREPID

-

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    Range("D4") = cRep.LastName

-    Range("D5") = cRep.FirstName

-

-    Range("H4") = GetRegionName(cRep.Region)

-    Range("H5") = GetCityName(cRep.Region, cRep.City)

-

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetAll_QTR_Records_by_REP(objQTR, "%", cRep.rep_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CQTR_QT) = objQTR(i).entry_date

-        Next i

-    End If

-    Dim qcd() As tQTR_COMMON

-    i = Get_QTR_CommonList_by_REP(qcd, "%", cRep.rep_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(qcd)

-            r.Offset(i - 1, CQTR_QT) = qcd(i).qtr.entry_date

-            r.Offset(i - 1, CQTR_ID) = qcd(i).qtr.id

-            r.Offset(i - 1, CQTR_PLN) = qcd(i).qtr.sale_PLAN

-            r.Offset(i - 1, CQTR_FCT) = qcd(i).c_sale_ALL

-            r.Offset(i - 1, CQTR_BDG) = qcd(i).c_bdgt_LPU

-            r.Offset(i - 1, CQTR_CNT) = qcd(i).i_lcd

-            r.Offset(i - 1, CQTR_BEDS) = qcd(i).c_beds

-            r.Offset(i - 1, CQTR_HIR) = qcd(i).c_pat_HIR

-            r.Offset(i - 1, CQTR_TER) = qcd(i).c_pat_TER

-            r.Offset(i - 1, CQTR_CRD) = qcd(i).c_pat_CRD

-            If qcd(i).c_bdgt_LPU <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_BDG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_LPU

-            End If

-            If qcd(i).c_bdgt_NMG <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_NMG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CQTR_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRepQtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect UserInterfaceOnly:=True

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CQTR_ID + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    i = currRange.Column - Range(CINP_AREA).Column

-

-    QTR_ID = r

-

-    If QTR_ID = 0 Then

-        Worksheets(VAR_SHEET).Range("USER_ACTION") = 1

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        If i > CQTR_FCT Then

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-            Range("LAST_FOCUS") = currRange.address

-        Else

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 3

-            Range("LAST_FOCUS") = currRange.address

-        End If

-    End If

-    Cancel = True

-    btHomeDo_IT

-End Sub

-

-<<<<<<
-======================
-mRep_QTR
->>>>>>
-Attribute VB_Name = "mRep_QTR"

-Option Explicit

-

-Sub NoFunc()

-    MsgBox "Функция не доступна", vbOKOnly, PROGRAM_NAME

-End Sub

-

-Sub DO_Price_qtr(ent_date As String)

-    Dim qtr As tQTR

-    Dim res As Integer

-    Dim cRep As tREPID

-

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    qtr = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-

-    If qtr.id = 0 Then

-        qtr.entry_date = ent_date

-

-        With Worksheets(VAR_SHEET)

-            qtr.ClxnH20mg = .Range("ClxnH20mg")

-            qtr.ClxnH40mg = .Range("ClxnH40mg")

-            qtr.ClxnT40mg = .Range("ClxnT40mg")

-            qtr.ClxnC_ACS = .Range("ClxnC_ACS")

-            qtr.ClxnC_IM = .Range("ClxnC_IM")

-        End With

-    End If

-

-    Dim dlg_nq As dlg_nextQTR

-    Set dlg_nq = New dlg_nextQTR

-

-    With dlg_nq

-        .tb_qtr_name = qtr.entry_date

-        .tb_bdgt_avts = qtr.sale_PLAN

-        .tb_qtr_name = qtr.entry_date

-        .tb_ClxnH20mg = qtr.ClxnH20mg

-        .tb_ClxnH40mg = qtr.ClxnH40mg

-        .tb_ClxnT40mg = qtr.ClxnT40mg

-        .tb_ClxnC_ACS = qtr.ClxnC_ACS

-        .tb_ClxnC_IM = qtr.ClxnC_IM

-    End With

-

-    dlg_nq.Show

-End Sub

-

-Sub DO_Edit_qtr(ent_date As String)

-    If ent_date = "" Then

-        NoFunc

-    Else

-        Dim rep_id As Long

-        rep_id = Worksheets(REP_QTR_SHEET).Range("REP_ID")

-        With ThisWorkbook.Worksheets("LPU_LIST")

-            .Range("VIEW_ONLY") = True

-            .Range("ent_date") = ent_date

-            .Range("REP_ID") = rep_id

-            .Select

-        End With

-    End If

-End Sub

-

-Sub DO_Delete_qtr(ent_date As String)

-    If ent_date <> "" Then

-        MsgBox "Удалить данные за период [" & ent_date & "] нельзя ", vbOKOnly, PROGRAM_NAME

-    End If

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-

-Sub btHomeDo_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    idx = Worksheets(VAR_SHEET).Range("USER_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            NoFunc

-            ' Обновляем экран

-        Case 2

-            DO_Edit_qtr ent_date

-        Case 3

-            DO_Price_qtr ent_date

-        Case 4

-            NoFunc

-    End Select

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-Sub Delete_qtr()

-'    Dim ent_date As String

-'    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-'    DO_Delete_qtr ent_date

-End Sub

-

-Sub btREP_QTR_RET_IT()

-    Dim s As String

-    With Worksheets("REP_QTR")

-        .Range("LAST_FOCUS") = ""

-        s = .Range("ret_addr")

-        .Range("ret_addr") = ""

-    End With

-    If s <> "" Then

-        ThisWorkbook.Worksheets(s).Select

-    Else

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane[RM]"

-Public Const PROGRAM_VERSION As String = "version 1.3"

-Public Const PROGRAM_FILENAME As String = "clexane-rm"

-Public Const PROGRAM_BACKUPNAME As String = "rm-backup-"

-Public Const PROGRAM_EXPORTNAME As String = "rm-ex-"

-Public Const PROGRAM_IMPORTNAME As String = "mr-ex-*"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20030329

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "O40"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-Public Const RM_QTR_SHEET As String = "RM_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-

-End Sub

-

-Function Double2Str(ByVal d As Double, ByVal precision As Integer, Optional Delim As String = ".") As String

-    Dim s As String

-    If Not precision > 0 Then

-        s = Round(d)

-    Else

-        Dim i As Integer

-        i = Fix(d)

-        s = i & Delim

-        d = Abs(d - i)

-        Do

-            precision = precision - 1

-            d = d * 10

-            If precision > 0 Then

-                i = Fix(d)

-            Else

-                i = Round(d)

-            End If

-            If i < 1 Then

-                s = s & "0"

-            Else

-                s = s & i

-                d = d - i

-            End If

-        Loop While precision > 0

-    End If

-    Double2Str = s

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetWBName(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBName = Right(FullName, s_len - pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.name = VAR_SHEET Or sh.name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-<<<<<<
-======================
-Var
->>>>>>
-Attribute VB_Name = "Var"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-title
->>>>>>
-Attribute VB_Name = "title"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LPU_LIST
->>>>>>
-Attribute VB_Name = "LPU_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentLPU_ID() As Long

-    Dim r As Range

-

-    With Worksheets("LPU_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CLPU_ID)

-    End With

-

-    getCurrentLPU_ID = r

-End Function

-

-Public Sub LPU_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectLPU_NAME(lpu_id As Long, ent_date As String)

-    If Range("VIEW_ONLY") = True Then

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    Dim cLPU As tLPU

-    If lpu_id = 0 Then

-        cLPU.id = 0

-        cLPU.rep_id = 0

-        cLPU.address = ""

-        cLPU.name = ""

-    Else

-        cLPU = Get_LPU_Record(lpu_id)

-    End If

-    EditLPU cLPU, getEnt_date

-    Worksheet_Activate

-End Sub

-

-Sub SelectLPU_BDGT(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    vo = Range("VIEW_ONLY")

-    If lpu_id = 0 Then

-        SelectLPU_NAME lpu_id, ent_date

-    Else

-        With ThisWorkbook.Worksheets("LPU_BDGT")

-            .Range("VIEW_ONLY") = vo

-            .Range("ret_addr") = "LPU_LIST"

-            .Range("REP_ID") = r_id

-            .Range("ent_date") = ent_date

-            .Range("lpu_id") = lpu_id

-        End With

-    End If

-End Sub

-

-Sub SelectLPU_HIR(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_HIR")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Sub SelectLPU_TER(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_TER")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Sub SelectLPU_C_ACS(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_C_ACS")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect UserInterfaceOnly:=True

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateLPUList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim lpu_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CINP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CINP_AREA).row, CLPU_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    lpu_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CINP_AREA).Column

-

-    If lpu_id = 0 Then

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    End If

-

-    If lpu_id = 0 Then

-        i = CLPU_NAME

-        Range("JUMP") = ""

-    End If

-    Select Case i

-        Case CLPU_NAME, CLPU_NAME1, CLPU_NAME2, CLPU_BEDS

-            SelectLPU_NAME lpu_id, ent_date

-            Range("JUMP") = ""

-

-        Case CLPU_NMG, CLPU_NFG, CLPU_PLAN, CLPU_FACT

-            SelectLPU_BDGT lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-

-        Case CLPU_HIR

-            SelectLPU_HIR lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_HIR"

-

-        Case CLPU_TER

-            SelectLPU_TER lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_TER"

-

-        Case CLPU_CAR

-            SelectLPU_C_ACS lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        Case Else

-            Range("JUMP") = ""

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateLPUList()

-    Dim lcd() As tLPU_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-    Dim objQTR As tQTR

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    ent_date = getEnt_date

-

-'     ent_date = "%" ' % - all records

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-    i = Get_LPU_CommonQTR(lcd, objQTR)

-

-'     стираем ФИО

-    Range("C3:C4").ClearContents

-

-    Range("C3") = cRep.LastName

-    Range("C4") = cRep.FirstName

-    Range("G3") = GetRegionName(cRep.Region)

-    Range("G4") = GetCityName(cRep.Region, cRep.City)

-    Range("G5") = objQTR.sale_PLAN

-

-

-

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(lcd)

-            r.Offset(i - 1, CLPU_NAME) = lcd(i).lpu.name

-            r.Offset(i - 1, CLPU_ID) = lcd(i).lpu.id

-            r.Offset(i - 1, CLPU_BEDS) = lcd(i).lpu.beds

-

-

-            r.Offset(i - 1, CLPU_NFG) = lcd(i).bdgt.bdgt_NFG

-            r.Offset(i - 1, CLPU_NMG) = lcd(i).bdgt.bdgt_NMG

-            r.Offset(i - 1, CLPU_PLAN) = lcd(i).bdgt.sale_PLAN

-

-            r.Offset(i - 1, CLPU_HIR) = lcd(i).pat_HIR

-            r.Offset(i - 1, CLPU_TER) = lcd(i).pat_TER

-            r.Offset(i - 1, CLPU_CAR) = lcd(i).pat_CRD

-            r.Offset(i - 1, CLPU_FACT) = lcd(i).sale_ALL

-            r.Offset(i - 1, CLPU_PAT_LPU) = lcd(i).pat_LPU

-            r.Offset(i - 1, CLPU_BDGT) = lcd(i).bdgt_LPU

-            If lcd(i).bdgt_LPU > 0 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = lcd(i).sale_ALL / lcd(i).bdgt_LPU

-            End If

-            If r.Offset(i - 1, CLPU_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{F2A5159C-AEB6-4066-B85F-339184DAFECD}{712D78F6-CCB6-499E-9674-B992A7482317}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-dbACS
->>>>>>
-Attribute VB_Name = "dbACS"

-Option Explicit

-

-Public Type tACS

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    patients_with_geparins As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objACS.ID <> 0 then updatre else insert

-Sub Insert_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objACS.id <> 0 Then

-        dbUpdate_ACS_Record dbConnection, objACS

-    Else

-        dbInsert_ACS_Record dbConnection, objACS

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_ACS_RecordsByLPU_ID(ByRef all_ACS_() As tACS, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_ACS_RecordsByLPU_ID = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, all_ACS_, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_ACS_Record dbConnection, objACS

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub dbInsert_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_acs", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objACS

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("patients_with_geparins") = .patients_with_geparins

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objACS.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim Update_SQL As String

-    

-    With objACS

-        Update_SQL = "UPDATE lpu_acs SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "patients_with_geparins=" & .patients_with_geparins & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_ACS_RecordsbyLPU_ID(dbConnection As Object, all_ACS() As tACS, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_ACS_SQL As String

-    Dim getAll_ACS_SQL As String

-    Dim ACS_Count As Long

-    ACS_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_ACS_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        ACS_Count = dbRecordset("ACS_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_ACS_RecordsbyLPU_ID = ACS_Count

-    

-    If ACS_Count > 0 Then

-        'we have records

-        ReDim all_ACS(1 To ACS_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_ACS_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_ACS As tACS

-                 With tmp_ACS

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .patients_with_geparins = dbRecordset("patients_with_geparins")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 all_ACS(index) = tmp_ACS

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE ID=" & objACS.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_ACS_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_HIR
->>>>>>
-Attribute VB_Name = "LPU_CLSN_HIR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-

-        Dim objHir As tHIRURGIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objHir

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .operations_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L9")

-                .patients_ambulator_clexan_20mg = Range("L10")

-                .patients_ambulator_clexan_40mg = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L19")

-                .patients_stationar_clexan_20mg = Range("L20")

-                .patients_stationar_clexan_40mg = Range("L21")

-            End With

-            Insert_Hir_Record objHir

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objHir.id = Range("rec_id")

-                    If objHir.id <> 0 Then

-                        Delete_Hir_Record objHir

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objHir As tHIRURGIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    With objHir

-        Range("rec_id") = .id

-        Range("F6") = .operations_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L9") = .patients_ambulator_clexan

-        Range("L10") = .patients_ambulator_clexan_20mg

-        Range("I21") = .patients_stationar_nmg

-        Range("L19") = .patients_stationar_clexan

-        Range("L20") = .patients_stationar_clexan_20mg

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id)

-

-        formula = "=" & qtr.ClxnH20mg & "*($L$10+$L$20)+" & qtr.ClxnH40mg & "*($L$11+$L$21)"

-        Range("F11").formula = formula

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objHir() As tHIRURGIA

-        Dim i As Integer

-        i = GetAll_Hir_RecordsByLPU_ID(objHir, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.3

-        Else

-            SetupData objHir(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-mSapes
->>>>>>
-Attribute VB_Name = "mSapes"

-Option Explicit

-

-Const SHAPE_COLOR As Integer = 1

-Const SHAPE_NAME As Integer = 2

-

-

-Sub ShapeView(r_sh_finite_state As Range)

-    Dim chk As Range

-    Dim s As String

-    Dim c, idx As Integer

-    For Each chk In r_sh_finite_state

-        idx = 0

-        If chk = "+" Then

-            c = chk.Offset(0, idx + SHAPE_COLOR)

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While c <> 0

-                ShapeFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s)), c

-                idx = idx + 2

-                c = chk.Offset(0, idx + SHAPE_COLOR)

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        Else

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While s <> ""

-                ShapeUnFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s))

-                idx = idx + 2

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        End If

-    Next chk

-End Sub

-

-Sub ShapeFill(sh As ShapeRange, ByVal color As Integer)

-    sh.Fill.Visible = msoTrue

-    sh.Fill.Solid

-    sh.Fill.ForeColor.SchemeColor = color

-    sh.Fill.Transparency = 0#

-End Sub

-

-Sub ShapeUnFill(sh As ShapeRange)

-    sh.Fill.Visible = msoFalse

-    sh.Fill.Transparency = 0#

-End Sub

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Public Const INPUT_NO = 0

-Public Const INPUT_NUMBER = 1

-Public Const INPUT_PERCENT = 2

-Public Const INPUT_STRING = 3

-Public Const INPUT_CHECK = 4

-

-Public Const INP_IDX_TYPE = 1

-Public Const INP_IDX_NEXT = 2

-Public Const INP_IDX_MIN = 3

-Public Const INP_IDX_MAX = 4

-Public Const INP_IDX_DEP = 5

-Public Const INP_IDX_ALT = 7

-

-

-Public Type tInputSet

-    vType As Integer

-    vMin As Long

-    vMax As Long

-    rChk As String

-End Type

-

-Function is_input_cell(ByVal Target As Range, inputs As Range) As tInputSet

-    Dim t As Range

-    Dim iset As tInputSet

-    Dim test As Range

-    iset.vType = INPUT_NO

-    iset.vMin = 0

-    iset.vMax = 0

-    iset.rChk = ""

-    is_input_cell = iset

-

-' Закоментировать следующую сточку для работы

-'  Exit Function

-

-    Set test = Target.Cells(1, 1)

-    For Each t In inputs

-        If Range(t).Column = test.Column And Range(t).row = test.row Then

-            iset.vType = t.Offset(0, INP_IDX_TYPE).Value

-            Select Case iset.vType

-                Case INPUT_CHECK

-                    iset.rChk = t.Offset(0, INP_IDX_ALT)

-                Case INPUT_NUMBER, INPUT_PERCENT

-                    iset.vMin = t.Offset(0, INP_IDX_MIN).Value

-                    iset.vMax = t.Offset(0, INP_IDX_MAX).Value

-            End Select

-            is_input_cell = iset

-            Exit Function

-        End If

-    Next t

-End Function

-

-Function GetFocusAddress(ByVal r As Range, f_next As Range) As String

-    Dim chk, t As Range

-    

-    For Each chk In f_next

-        For Each t In r

-            If t.address = chk Then

-                GetFocusAddress = chk

-                Exit Function

-            End If

-            If Range(chk).Column = t.Column - 1 And Range(chk).row = t.row _

-            Or Range(chk).Column = t.Column And Range(chk).row = t.row - 1 _

-            Then

-                If Range(chk) <> "" Then

-                    If Range(chk) = 0 Then

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_ALT)).address

-                    Else

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_NEXT)).address

-                    End If

-                Else

-                    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-                End If

-                Exit Function

-            End If

-        Next t

-    Next chk

-    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-End Function

-

-Sub SetDependet(r As Range, inputs As Range)

-    Dim chk As Range

-    Dim s, serr As String

-    Dim idx As Integer

-    Dim iset As tInputSet

-    Dim err_found As Boolean

-    

-    If r.count > 1 Then

-        Exit Sub

-    End If

-    

-    err_found = False

-    For Each chk In inputs

-        idx = INP_IDX_DEP

-        

-        

-        iset.vType = chk.Offset(0, INP_IDX_TYPE).Value

-        Select Case iset.vType

-            Case INPUT_NUMBER, INPUT_PERCENT

-                iset.vMin = chk.Offset(0, INP_IDX_MIN).Value

-                iset.vMax = chk.Offset(0, INP_IDX_MAX).Value

-                

-                If Range(chk) > iset.vMax Then

-                    err_found = True

-                    Range(chk) = iset.vMax

-                    serr = "Выход за дозволенный диапазон [" & iset.vMin & ".." & iset.vMax & "]! Данные скорректированы."

-                End If

-                

-                If Range(chk) = "" Then

-                    s = chk.Offset(0, idx)

-                    Do While s <> ""

-                        Range(s) = ""

-                        idx = idx + 1

-                        s = chk.Offset(0, idx)

-                    Loop

-                End If

-        End Select

-    Next chk

-    If err_found Then

-        MsgBox serr, vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Function CheckInputData(inputs As Range) As Boolean

-    Dim r As Range

-    

-    CheckInputData = True

-    For Each r In inputs

-        If Range(r) = "" Then

-            CheckInputData = False

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100.", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Sub Check_Int_Number(Target As Range, Def_Val As Long)

-    Dim err As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    err = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                err = True

-            End If

-        End If

-    Next r

-    If err Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_TER
->>>>>>
-Attribute VB_Name = "LPU_CLSN_TER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim objTer As tTERAPIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objTer

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .patients_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L20")

-            End With

-            Insert_Ter_Record objTer

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objTer.id = Range("rec_id")

-                    If objTer.id <> 0 Then

-                        Delete_Ter_Record objTer

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objTer As tTERAPIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    With objTer

-        Range("rec_id") = .id

-        Range("F6") = .patients_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L11") = .patients_ambulator_clexan

-        Range("I21") = .patients_stationar_nmg

-        Range("L20") = .patients_stationar_clexan

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id)

-        formula = "=" & qtr.ClxnT40mg & "*($L$12+$L$20)"

-        Range("F11").formula = formula

-

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objTer() As tTERAPIA

-        Dim i As Integer

-        i = GetAll_Ter_RecordsByLPU_ID(objTer, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.25

-        Else

-            SetupData objTer(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{5D2CB2D2-3E5E-4B6E-9E0C-2EEBA5E10E17}{C891C133-B6B4-43D3-B411-B4A821905C23}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-LPU_BDGT
->>>>>>
-Attribute VB_Name = "LPU_BDGT"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub SetDefFocus()

-    Range(Range("DEF_FOCUS")).Select

-End Sub

-

-Public Sub ClearData()

-    ClearSheetData

-End Sub

-

-Sub ClearSheetData()

-    If Range("F10") = 0 And Range("F13") = 0 Then

-        Range("F11:F18") = ""

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("F11:F13") = ""

-    End If

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim bdgt As tBUDGET

-        Dim test As Boolean

-        Dim sum As Long

-        With bdgt

-            .lpu_id = Range("lpu_id")

-            .id = Range("rec_id")

-            .entry_date = Range("ent_date")

-            .bdgt_NMG = Round(Range("F11").Value, 0)

-            .bdgt_NFG = Round(Range("F12").Value, 0)

-            .sale_PLAN = Round(Range("F13").Value, 0)

-

-            sum = .bdgt_NFG + .bdgt_NMG - .sale_PLAN

-            test = .bdgt_NFG <> 0 Or .bdgt_NMG <> 0 Or .sale_PLAN <> 0

-        End With

-        If test Then

-            If sum < 0 Then

-                MsgBox _

-                    "Ваш план превышает выделенный на гепарины бюджет. Сохранить данные?", _

-                    vbOKOnly, PROGRAM_NAME

-            End If

-            If test Then

-                Insert_BDGT_Record bdgt

-            End If

-        Else

-            If bdgt.id <> 0 Then

-                If vbYes = MsgBox("Удалить данные из базы!", vbYesNo, PROGRAM_NAME) Then

-                    Delete_BDGT_Record bdgt

-                End If

-                ret_back Range("DEF_FOCUS").Worksheet

-                Exit Sub

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-    End If

-

-   ClearData

-   ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(cLPU As tLPU_COMMON)

-    Dim t_sum As Long

-    t_sum = 0

-' Setup budget data

-    Range("F11") = cLPU.bdgt.bdgt_NMG

-    Range("F12") = cLPU.bdgt.bdgt_NFG

-    Range("F13") = cLPU.bdgt.sale_PLAN

-

-    With cLPU

-        Range("F14") = .pat_ALL

-        Range("F15") = .pat_HIR

-        Range("F16") = .pat_TER

-        Range("F17") = .pat_CRD

-        Range("F18") = .sale_ALL

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-    ws_activate

-End Sub

-

-

-Sub ws_activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Dim cLPU As tLPU_COMMON

-    Dim objQTR As tQTR

-    Dim objLPU As tLPU

-    Dim ent_date As String

-    Dim id As Long

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    id = Range("lpu_id").Value

-    ent_date = Range("ent_date")

-    

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-

-    objLPU = Get_LPU_Record(id)

-    Get_LPU_Common cLPU, objLPU, objQTR

-

-    If cLPU.lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = cLPU.lpu.beds

-        Range("lpu_name") = cLPU.lpu.name

-        Range("lpu_addr") = cLPU.lpu.address

-        Range("rec_id") = cLPU.bdgt.id

-

-        SetupData cLPU

-

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-'    MsgBox Target.address

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case INPUT_CHECK

-

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{BB60E38F-A4AB-4AB4-91D0-40AA798D9F5C}{BE9A54D9-F093-4755-9E17-0B47BB5E2546}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mSheets
->>>>>>
-Attribute VB_Name = "mSheets"

-Option Explicit

-

-Function am_load_now() As Boolean

-    am_load_now = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE")

-End Function

-

-Sub Wks_select(RetSheet As String)

-    Dim sheet As Worksheet

-    For Each sheet In ThisWorkbook.Worksheets

-        If sheet.name = RetSheet Then

-            ThisWorkbook.Worksheets(RetSheet).Select

-            Exit Sub

-        End If

-    Next sheet

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub ret_back(sh As Worksheet)

-    Dim RetSheet As String

-    RetSheet = sh.Range("ret_addr")

-    sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    sh.Range("ret_addr") = ""

-    sh.Range("rec_id") = ""

-    sh.Range("lpu_id") = ""

-    sh.Range("ent_date") = ""

-    sh.Range("lpu_name") = ""

-    sh.Range("lpu_addr") = ""

-    sh.Range("lpu_beds") = ""

-    Wks_select RetSheet

-End Sub

-

-Sub ClearSheetData(r_start As Range)

-    If r_start <> "" Then

-        r_start.Worksheet.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        r_start = ""

-    Else

-        ret_back r_start.Worksheet

-    End If

-End Sub

-

-Sub wks_sel_chng(iset As tInputSet, ByVal Target As Range, sh As Worksheet)

-    Dim DebugMode As Boolean

-    Dim in_range As Range

-    

-    DebugMode = Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-

-    If DebugMode Then

-        sh.Unprotect

-    Else

-        sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    End If

-

-    If iset.vType = INPUT_CHECK Then

-        Set in_range = Target.Worksheet.Range(iset.rChk)

-    Else

-        Set in_range = Target

-    End If

-    

-    Dim str As String

-    str = GetFocusAddress(in_range, sh.Range("h_inputs"))

-

-'    MsgBox Target.Address & "; " & str

-    If str <> Target.address Then

-        sh.Range(str).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-Dlg_lpu_card
->>>>>>
-Attribute VB_Name = "Dlg_lpu_card"

-Attribute VB_Base = "0{2C69E842-8DA9-4240-A0A8-F6B0141DC246}{75AAB28C-ADCF-4D1B-9D5A-AF89E80A810C}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbLPU_List_Change()

-    Dim src As Range

-    Dim idx_src As Integer

-    

-    Set src = Worksheets(VAR_SHEET).Range(Me.cbLPU_List.RowSource)

-    idx_src = Me.cbLPU_List.ListIndex + 1

-    Me.tb_lpu_name.Text = src.Cells(idx_src, 1)

-    Me.tb_lpu_address.Text = src.Cells(idx_src, 2)

-    Me.tbBedsCount.Text = src.Cells(idx_src, 3)

-End Sub

-

-

-Private Sub cbxLPU_List_Enable_Click()

-    

-    If Me.cbxLPU_List_Enable Then

-        

-        Me.tb_lpu_name.Text = ""

-        Me.tb_lpu_name.Enabled = False

-        

-        Me.tb_lpu_address.Text = ""

-        Me.tb_lpu_address.Enabled = False

-        

-        Me.tbBedsCount.Text = ""

-        Me.tbBedsCount.Enabled = False

-        

-        Me.cbLPU_List.Enabled = True

-        cbLPU_List_Change

-    Else

-        Me.tb_lpu_name.Enabled = True

-        Me.tb_lpu_name.Text = ""

-        

-        Me.tb_lpu_address.Enabled = True

-        Me.tb_lpu_address.Text = ""

-        

-        Me.tbBedsCount.Enabled = True

-        Me.tbBedsCount.Text = ""

-        

-        Me.cbLPU_List.Enabled = False

-    End If

-End Sub

-

-<<<<<<
-======================
-UserInfo
->>>>>>
-Attribute VB_Name = "UserInfo"

-Attribute VB_Base = "0{BA873669-5C2D-400A-8A8B-572ACD8CCE4C}{D11400A0-9912-4240-A78C-44C33731216A}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Tag = vbOK

-End Sub

-

-Private Sub cbCity_Change()

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_CITY") = Me.cbCity.ListIndex

-        .Calculate

-    End With

-End Sub

-

-Private Sub cbRegion_Change()

-    Dim LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        NewRangeOffsetCol = cbRegion.Value * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).address

-        NewSumRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).address

-        .Calculate

-        .Range("IDX_CITY") = 0

-        cbCity.RowSource = NewCbxRange

-

-    End With

-    cbCity.ListIndex = 0

-End Sub

-

-<<<<<<
-======================
-mREGMAN
->>>>>>
-Attribute VB_Name = "mREGMAN"

-Option Explicit

-

-Sub hwnew()

-    Dim rs As Range

-    Dim re As Object

-    

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    HWReset

-    ReSet_REGMAN_Record

-    With Worksheets("RM_QTR")

-        .ClearRMName

-        .Range("REP_QTR_INPUT_DATA").ClearContents ' Это не ошибка, названия совпадают

-'        .Range("A1").Select

-    End With

-    Worksheets(TITLE_SHEET).Select

-    With Application

-        .DisplayAlerts = False

-        .ThisWorkbook.Save

-        .Quit

-    End With

-End Sub

-

-Function CheckUser() As Boolean

-    Dim objHW() As Long

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    

-    GetHWInfo objHW()

-    i = GetHWRecords(objHW_DB)

-    

-    If i = 0 Then ' First time

-        StoreHWInfo objHW()

-    End If

-    If CheckHWInfo(objHW()) <> True Then

-        CheckUser = False

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    Else

-        CheckUser = SetupUser

-    End If

-End Function

-

-Function SetupUser() As Boolean

-    Dim cREGMAN As tREGMAN

-    Dim idx As Integer

-    Dim dlg_ui As UserInfo

-    

-    Set dlg_ui = New UserInfo

-    

-    cREGMAN = Get_REGMAN_Record()

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_REGION") = cREGMAN.Region

-        .Range("IDX_CITY") = cREGMAN.City

-    End With

-        

-    With dlg_ui

-        .cbRegion = cREGMAN.Region

-        .cbCity = cREGMAN.City

-        .tbFName = cREGMAN.FirstName

-        .tbLName = cREGMAN.LastName

-    End With

-    

-    Worksheets(REGS_SHEET).Calculate

-    

-    Dim test_Ok As Boolean

-    test_Ok = False

-    

-    On Error GoTo l1

-    

-    Do

-        dlg_ui.Show

-        If dlg_ui.Tag = vbOK Then

-            test_Ok = dlg_ui.tbFName.Value <> "" And dlg_ui.tbLName <> ""

-            If test_Ok Then

-                Exit Do

-            Else

-                MsgBox "Введите имя и фамилию", vbOKOnly, PROGRAM_NAME

-            End If

-        Else

-            Exit Do

-        End If

-    Loop Until False

-l1:

-    If test_Ok Then

-        With cREGMAN

-            .Region = dlg_ui.cbRegion.Value

-            .City = dlg_ui.cbCity.Value

-            .FirstName = dlg_ui.tbFName.Value

-            .LastName = dlg_ui.tbLName.Value

-        End With

-        Set_REGMAN_Record cREGMAN

-    Else

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .ThisWorkbook.Saved = True

-            .Quit

-        End With

-    End If

-    SetupUser = test_Ok

-End Function

-

-Sub GetHWInfo(objHW() As Long)

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    i = 1

-    For Each d In dc

-        If d.drivetype = 2 Then ' 2 - HardDisk

-            ReDim Preserve objHW(i)

-            objHW(i) = d.SerialNumber

-            i = i + 1

-        End If

-    Next

-    SortHW objHW

-End Sub

-

-Sub StoreHWInfo(objHW() As Long)

-    UpdateHWRecords objHW

-End Sub

-

-Sub SortHW(objHW() As Long)

-    Dim r As Range

-    Dim rs As Range

-    Dim re As Object

-    Dim i As Integer

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    For i = 1 To UBound(objHW)

-        r = objHW(i)

-        Set r = r.Offset(1, 0)

-    Next i

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).Sort _

-            Key1:=.Range("HW_Number"), _

-            Order1:=xlDescending, _

-            Header:=xlGuess, _

-            OrderCustom:=1, _

-            MatchCase:=False, _

-            Orientation:=xlTopToBottom

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    i = 1

-    Do While r <> ""

-        objHW(i) = r

-        Set r = r.Offset(1, 0)

-        i = i + 1

-    Loop

-End Sub

-

-Function CheckHWInfo(objHW() As Long)

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    CheckHWInfo = False

-        

-    i = GetHWRecords(objHW_DB)

-    If i > 0 Then

-        SortHW objHW_DB

-    End If

-    If UBound(objHW) = UBound(objHW_DB) Then

-        For i = 1 To UBound(objHW)

-            If objHW(i) <> objHW_DB(i) Then

-                Exit Function

-            End If

-        Next i

-        CheckHWInfo = True

-    End If

-End Function

-

-

-<<<<<<
-======================
-dbBudget
->>>>>>
-Attribute VB_Name = "dbBudget"

-Option Explicit

-

-Public Type tBUDGET

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    bdgt_NMG As Long

-    bdgt_NFG As Long

-    sale_PLAN As Long

-End Type

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function GetAll_BDGT_RecordsByLPU_ID(ByRef allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_BDGT_RecordsByLPU_ID = dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection, allBDGT, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function Get_BDGT_Record(ByVal lpu_id As Long, ByVal ent_date As String) As tBUDGET

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    Get_BDGT_Record = dbGet_BDGT_Record(dbConnection, lpu_id, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objBDGT.ID <> 0 then updatre else insert

-Public Sub Insert_BDGT_Record(objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    If objBDGT.id <> 0 Then

-        dbUpdate_BDGT_Record dbConnection, objBDGT

-    Else

-        dbInsert_BDGT_Record dbConnection, objBDGT

-    End If

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Public Sub Delete_BDGT_Record(ByRef objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    dbDelete_BDGT_Record dbConnection, objBDGT

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_BDGT_Record(dbConnection As Object, ByVal lpu_id As Long, ent_date As String) As tBUDGET

-    

-    Dim sql As String

-    Dim objBDGT As tBUDGET

-    

-    With objBDGT

-        .id = 0

-        .lpu_id = lpu_id

-        .entry_date = ent_date

-        .bdgt_NMG = 0

-        .bdgt_NFG = 0

-        .sale_PLAN = 0

-    End With

-        

-    

-    sql = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        With objBDGT

-            .entry_date = dbRecordset("entry_date")

-            .id = dbRecordset("id")

-            .lpu_id = dbRecordset("lpu_id")

-            .bdgt_NFG = dbRecordset("bdgt_NFG")

-            .bdgt_NMG = dbRecordset("bdgt_NMG")

-            .sale_PLAN = dbRecordset("sale_PLAN")

-        End With

-    End If

-    

-    dbGet_BDGT_Record = objBDGT

-End Function

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection As Object, allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_BDGT_SQL As String

-    Dim getAll_BDGT_SQL As String

-    Dim BDGT_Count As Long

-    BDGT_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_BDGT_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        BDGT_Count = dbRecordset("BDGT_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_BDGT_RecordsbyLPU_ID = BDGT_Count

-    

-    If BDGT_Count > 0 Then

-        'we have records

-        ReDim allBDGT(1 To BDGT_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_BDGT_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpBDGT As tBUDGET

-                 With tmpBDGT

-                    .entry_date = dbRecordset("entry_date")

-                    .id = dbRecordset("id")

-                    .lpu_id = dbRecordset("lpu_id")

-                    .bdgt_NFG = dbRecordset("bdgt_NFG")

-                    .bdgt_NMG = dbRecordset("bdgt_NMG")

-                    .sale_PLAN = dbRecordset("sale_PLAN")

-                 End With

-                 

-                 allBDGT(index) = tmpBDGT

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbInsert_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "lpu_budget", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    dbRecordset("entry_date") = objBDGT.entry_date

-    dbRecordset("lpu_id") = objBDGT.lpu_id

-    dbRecordset("bdgt_NMG") = objBDGT.bdgt_NMG

-    dbRecordset("bdgt_NFG") = objBDGT.bdgt_NFG

-    dbRecordset("sale_PLAN") = objBDGT.sale_PLAN

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objBDGT.id = dbRecordset("id")

-  

-End Sub

-

-Public Sub dbUpdate_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu_budget SET " & _

-    "entry_date='" & objBDGT.entry_date & "'," & _

-    "lpu_id=" & objBDGT.lpu_id & "," & _

-    "bdgt_NMG=" & objBDGT.bdgt_NMG & "," & _

-    "bdgt_NFG=" & objBDGT.bdgt_NFG & "," & _

-    "sale_PLAN=" & objBDGT.sale_PLAN & _

-    " WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-Public Sub dbDelete_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_BDGT_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbDatabase
->>>>>>
-Attribute VB_Name = "dbDatabase"

-Option Explicit

-

-

-Sub dbOpenConnection(dbConnection As Object)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-<<<<<<
-======================
-dbLPU
->>>>>>
-Attribute VB_Name = "dbLPU"

-Option Explicit

-

-Public Type tLPU

-    id As Long

-    rep_id As Long

-    name As String

-    address As String

-    beds As Integer

-End Type

-

-Function Get_LPU_Record(ByVal lpu_id As Long) As tLPU

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_LPU_Record = dbGet_LPU_Record(dbConnection, lpu_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_LPU_byQTR(allLPU() As tLPU, ent_date As String, rep_id As Long) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_LPU_byQTR = dbGetAll_LPU_byQTR(dbConnection, allLPU, ent_date, rep_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_Record(dbConnection As Object, ByVal lpu_id As Long) As tLPU

-    

-    Dim sql As String

-    Dim objLPU As tLPU

-    

-    objLPU.id = lpu_id

-    objLPU.name = ""

-    objLPU.address = ""

-    

-    sql = "SELECT * FROM lpu WHERE id=" & lpu_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objLPU.name = dbRecordset("name")

-        objLPU.address = dbRecordset("address")

-        objLPU.rep_id = dbRecordset("rep_id")

-        objLPU.beds = dbRecordset("beds")

-    End If

-    

-    dbGet_LPU_Record = objLPU

-

-End Function

-

-Function dbGetAll_LPU_byQTR(dbConnection As Object, allLPU() As tLPU, ent_date As String, rep_id As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    Dim Where As String

-    Where = "WHERE lpu_budget.entry_date like '" & ent_date & "'" & " AND lpu.id=lpu_budget.lpu_id AND lpu.rep_id=" & rep_id

-

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu_budget, lpu " & Where

-    

-    getAll_LPU_SQL = "SELECT lpu.id as id, lpu.rep_id as rep_id, lpu.name as name, lpu.address as address, lpu.beds AS beds " & _

-    "FROM lpu, lpu_budget " & Where

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_LPU_byQTR = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-dbREP
->>>>>>
-Attribute VB_Name = "dbREP"

-'Option Explicit

-'

-'Public Type tREP

-'    FirstName As String

-'    LastName As String

-'    Region As Integer

-'    City As Integer

-'End Type

-'

-'Function GetREPRecord() As tREP

-'    Dim dbConnection As Object

-'

-'    dbOpenConnection dbConnection

-'    GetREPRecord = dbGetREPRecord(dbConnection)

-'    dbCloseConnection dbConnection

-'End Function

-'

-'Sub SetREPRecord(cUser As tREP)

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbSetREPRecord dbConnection, cUser

-'    dbCloseConnection dbConnection

-'End Sub

-'

-'Sub ReSetREPRecord()

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbReSetREPRecord dbConnection

-'    dbCloseConnection dbConnection

-'End Sub

-'

-'Public Function dbGetREPRecord(dbConnection As Object) As tREP

-'

-'    Dim SQL As String

-'    Dim objREP As tREP

-'

-'    objREP.FirstName = ""

-'    objREP.LastName = ""

-'    objREP.Region = 0

-'    objREP.City = 0

-'    SQL = "SELECT firstname, lastname, region, city FROM " & _

-'          "rep"

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open SQL, dbConnection

-'    ', 3, 3

-'    If Not dbRecordset.BOF Then

-'

-'        objREP.FirstName = dbRecordset("firstname")

-'        objREP.LastName = dbRecordset("lastname")

-'        objREP.Region = dbRecordset("region")

-'        objREP.City = dbRecordset("city")

-'

-'    End If

-'

-'    dbGetREPRecord = objREP

-'

-'End Function

-'

-'Public Sub dbSetREPRecord(dbConnection As Object, ByRef objREP As tREP)

-'

-'    Dim DeleteSQL As String

-'    Dim InsertSQL As String

-'

-'    DeleteSQL = "DELETE FROM rep"

-'    InsertSQL = "INSERT INTO rep (firstname, lastname, region, city) VALUES (" & _

-'    "'" & objREP.FirstName & "', " & _

-'    "'" & objREP.LastName & "', " & _

-'    objREP.Region & ", " & _

-'    objREP.City & ")"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-'

-'End Sub

-'

-'Public Sub dbReSetREPRecord(dbConnection As Object)

-'

-'    Dim DeleteSQL As String

-'

-'    DeleteSQL = "DELETE FROM rep"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-'

-'End Sub

-'

-

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    CheckWorkBooksArround Wb

-End Sub

-

-

-Sub CheckWorkBooksArround(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If app.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKOnly, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-        Exit Sub

-    End If

-

-End Sub

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub SaveExcelState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-        ActiveWorkbook.DisplayDrawingObjects = xlDisplayShapes

-        

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars(STDBAR_NAME).Visible = False

-End Sub

-

-

-Public Sub RestoreExcelState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars(STDBAR_NAME).Visible = True

-End Sub

-

-

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Public Const STDBAR_NAME = "Worksheet Menu Bar"

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Import"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmImport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Export"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 620

-                        .OnAction = "cmExport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Exit && Restore Excel"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 548

-                        .OnAction = "cmExitRestore"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-       End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(flag As Boolean)

-    If flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars(STDBAR_NAME)

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmImport()

-    Worksheets(RM_QTR_SHEET).Select

-    ImportData

-End Sub

-

-Sub cmExport()

-    dbExport

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    Dim dlg As dlgAbout

-    Set dlg = New dlgAbout

-    

-    dlg.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlg.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlg.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlg.Show

-End Sub

-

-Sub cmMail2Support()

-    Dim err_description As String

-    Dim dlg_msg As dlg_Mail

-    Set dlg_msg = New dlg_Mail

-    With dlg_msg

-        .Show

-        If .Tag = vbOK Then

-            ThisWorkbook.Worksheets(VAR_SHEET).Range("ERR_MESSAGE") _

-                = .tbMessage.Text

-            ThisWorkbook.Save

-            ThisWorkbook.SendMail Recipients:="infra@i-rs.ru", Subject:=PROGRAM_NAME & " ver.:" & PROGRAM_VERSION

-            MsgBox "Сообщение об ошибке отправлено. Перезагрузите программу.", vbOKOnly, PROGRAM_NAME

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-    End With

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-'        helppath = "hh.exe " & .Path & "\Telfast.chm"

-'        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub set_work_mode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetupEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-End Sub

-

-Sub cmSetStandaloneMode()

-    set_work_mode

-    ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    Dim dlg As dlgGetPwd

-    rp = common_pwd

-    

-    Set dlg = New dlgGetPwd

-    dlg.edPwd = ""

-    dlg.Show

-    

-    If dlg.edPwd = rp Then

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmHomePage()

-    ThisWorkbook.Worksheets("RM_QTR").Select

-End Sub

-

-Sub cmExitRestore()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = True

-    Application.Quit

-End Sub

-

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    Dim dlg_prn As dlgPrint

-    

-    Set dlg_prn = New dlgPrint

-    

-    With dlg_prn

-        .cbMainReport = True

-        .cbMainBudget = False

-        .cbSrcData = False

-        .cbAllSheets = False

-    

-        .Show

-    

-        If .Tag = vbCancel Then

-            Exit Sub

-        End If

-    End With

-    

-    Dim PrnIdx As Integer

-    

-    With dlg_prn

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("REP_QTR", "budget", "Final")

-    Case 1111

-        plist = Array("REP_QTR", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("REP_QTR")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Clexane bar"

-Public Const common_pwd As String = "crdjhxtyjr"

-

-

-Sub SetupEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    Wb.Worksheets(TITLE_SHEET).Select

-    With Application

-        .Caption = PROGRAM_NAME & " " & PROGRAM_VERSION

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .SaveExcelState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = False

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Wb.Worksheets(TITLE_SHEET).Select

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    If cWindow.Type = xlWorkbook Then

-                        cWindow.DisplayHeadings = True

-                    End If

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu True

-        End If

-        With mobjAppState

-            .RestoreExcelState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Worksheets(TITLE_SHEET).Select

-'        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Option Explicit

-

-Sub UpdateHWRecords(objHW() As Long)

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    dbUpdateHWRecords dbConnection, objHW

-    dbCloseConnection dbConnection

-End Sub

-

-Function GetHWRecords(objHW() As Long) As Integer

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    GetHWRecords = dbGetHWRecords(dbConnection, objHW)

-    dbCloseConnection dbConnection

-End Function

-

-Sub HWReset()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbInsertHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    

-    Dim dbRecordset As Object

-    Dim i As Long

-    

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "hw", dbConnection, 2, 2

-    

-    For i = 1 To UBound(objHW)

-        dbRecordset.addnew

-        dbRecordset("num") = objHW(i)

-        dbRecordset.Update

-    Next i

-    

-End Sub

-

-Sub dbUpdateHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    dbDeleteHWRecord dbConnection

-    dbInsertHWRecords dbConnection, objHW

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-dbHir
->>>>>>
-Attribute VB_Name = "dbHir"

-Option Explicit

-

-Public Type tHIRURGIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    operations_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_ambulator_clexan_40mg As Integer

-    patients_ambulator_clexan_20mg As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-    patients_stationar_clexan_40mg As Integer

-    patients_stationar_clexan_20mg As Integer

-End Type

-

-' if objHir.ID <> 0 then updatre else insert

-Sub Insert_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objHir.id <> 0 Then

-        dbUpdate_Hir_Record dbConnection, objHir

-    Else

-        dbInsert_Hir_Record dbConnection, objHir

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Hir_RecordsByLPU_ID(ByRef allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Hir_RecordsByLPU_ID = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, allHir, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Hir_Record dbConnection, objHir

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objHir.ID <> 0 then updatre else insert

-

-Sub dbInsert_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_hir", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objHir

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("operations_per_quarter") = .operations_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_ambulator_clexan_20mg") = .patients_ambulator_clexan_20mg

-        dbRecordset("patients_ambulator_clexan_40mg") = .patients_ambulator_clexan_40mg

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-        dbRecordset("patients_stationar_clexan_20mg") = .patients_stationar_clexan_20mg

-        dbRecordset("patients_stationar_clexan_40mg") = .patients_stationar_clexan_40mg

-        

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objHir.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim UpdateSQL As String

-    

-    With objHir

-        UpdateSQL = "UPDATE lpu_hir SET " & _

-            "entry_date='" & objHir.entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "operations_per_quarter=" & .operations_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_ambulator_clexan_20mg=" & .patients_ambulator_clexan_20mg & "," & _

-            "patients_ambulator_clexan_40mg=" & .patients_ambulator_clexan_40mg & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & "," & _

-            "patients_stationar_clexan_20mg=" & .patients_stationar_clexan_20mg & "," & _

-            "patients_stationar_clexan_40mg=" & .patients_stationar_clexan_40mg & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_Hir_RecordsbyLPU_ID(dbConnection As Object, allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Hir_SQL As String

-    Dim getAll_Hir_SQL As String

-    Dim Hir_Count As Long

-    Hir_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Hir_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Hir_Count = dbRecordset("HIR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Hir_RecordsbyLPU_ID = Hir_Count

-    

-    If Hir_Count > 0 Then

-        'we have records

-        ReDim allHir(1 To Hir_Count)

-        Dim index As Integer

-        index = 1

-        dbRecordset.Open getAll_Hir_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpHir As tHIRURGIA

-                 With tmpHir

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .operations_per_quarter = dbRecordset("operations_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_ambulator_clexan_20mg = dbRecordset("patients_ambulator_clexan_20mg")

-                    .patients_ambulator_clexan_40mg = dbRecordset("patients_ambulator_clexan_40mg")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                    .patients_stationar_clexan_20mg = dbRecordset("patients_stationar_clexan_20mg")

-                    .patients_stationar_clexan_40mg = dbRecordset("patients_stationar_clexan_40mg")

-                 End With

-                 

-                 allHir(index) = tmpHir

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE ID=" & objHir.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Hir_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbTer
->>>>>>
-Attribute VB_Name = "dbTer"

-Option Explicit

-

-Public Type tTERAPIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objTer.ID <> 0 then updatre else insert

-Sub Insert_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objTer.id <> 0 Then

-        dbUpdate_Ter_Record dbConnection, objTer

-    Else

-        dbInsert_Ter_Record dbConnection, objTer

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Ter_RecordsByLPU_ID(ByRef allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Ter_RecordsByLPU_ID = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, allTer, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Ter_Record dbConnection, objTer

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objTer.ID <> 0 then updatre else insert

-

-Sub dbInsert_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_ter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objTer

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objTer.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim Update_SQL As String

-    

-    With objTer

-        Update_SQL = "UPDATE lpu_ter SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_Ter_RecordsbyLPU_ID(dbConnection As Object, allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Ter_SQL As String

-    Dim getAll_Ter_SQL As String

-    Dim Ter_Count As Long

-    Ter_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Ter_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Ter_Count = dbRecordset("TER_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Ter_RecordsbyLPU_ID = Ter_Count

-    

-    If Ter_Count > 0 Then

-        'we have records

-        ReDim allTer(1 To Ter_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_Ter_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpTer As tTERAPIA

-                 With tmpTer

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 allTer(index) = tmpTer

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE ID=" & objTer.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Ter_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-mLPU_LIST
->>>>>>
-Attribute VB_Name = "mLPU_LIST"

-Option Explicit

-

-Public Const CINP_AREA As String = "B12"

-Public Const CLPU_NAME As Integer = 0

-Public Const CLPU_NAME1 As Integer = 1

-Public Const CLPU_NAME2 As Integer = 2

-Public Const CLPU_ID As Integer = 3

-Public Const CLPU_BEDS As Integer = 4

-Public Const CLPU_NFG As Integer = 5

-Public Const CLPU_NMG As Integer = 6

-Public Const CLPU_HIR As Integer = 7

-Public Const CLPU_TER As Integer = 8

-Public Const CLPU_CAR As Integer = 9

-Public Const CLPU_FACT As Integer = 10

-Public Const CLPU_PLAN As Integer = 11

-Public Const CLPU_PAT_LPU As Integer = 16

-Public Const CLPU_BDGT As Integer = 17

-Public Const CLPU_PAT_ALL As Integer = 16

-

-

-

-Sub EditLPU(cLPU As tLPU, ent_date As String)

-    NoFunc

-End Sub

-

-Sub Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-

-End Sub

-

-Sub Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btLPU_DEL_IT()

-    Dim cLPU As tLPU

-    Dim ent_date As String

-    Dim delete_all As Integer

-    Dim dlg_del As dlg_LPU_delete

-

-    With Worksheets("LPU_LIST")

-        ent_date = .Range("ent_date")

-        cLPU.id = .getCurrentLPU_ID()

-    End With

-

-    If cLPU.id = 0 Then

-        MsgBox "Укажите удаляемый объект", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    cLPU = Get_LPU_Record(cLPU.id)

-

-    Set dlg_del = New dlg_LPU_delete

-    With dlg_del

-        .chbDeleteQTR.Value = True

-        .chbDeleteAll.Value = False

-        .lComment = ent_date & ": Удаление ЛПУ '" _

-        & cLPU.name & "', расположенного по адресу:" _

-        & cLPU.address & " не разрешено."

-        .Show

-    End With

-End Sub

-

-Sub btLPU_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        

-        Wks_select .Range("ret_addr")

-    End With

-

-End Sub

-

-

-Sub btLPU_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim lpu_id As Long

-

-    i = Worksheets(VAR_SHEET).Range("QTR_ACTION").Value

-    With Worksheets("LPU_LIST")

-        ent_date = .getEnt_date()

-

-

-        lpu_id = .getCurrentLPU_ID

-        If lpu_id = 0 And i <> 6 Then

-            i = 1

-        End If

-        Select Case i

-            Case 1

-                .SelectLPU_NAME lpu_id, ent_date

-                .Range("JUMP") = ""

-            Case 2

-                .SelectLPU_BDGT lpu_id, ent_date

-                .Range("JUMP") = "LPU_BDGT"

-            Case 3

-                .SelectLPU_HIR lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_HIR"

-

-            Case 4

-                .SelectLPU_TER lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_TER"

-

-            Case 5

-                .SelectLPU_C_ACS lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        End Select

-    End With

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-dbQTR
->>>>>>
-Attribute VB_Name = "dbQTR"

-Option Explicit

-

-Public Type tQTR

-    id As Long

-    entry_date As String

-    rep_id As Long

-    sale_PLAN As Long

-    ClxnH20mg As Long

-    ClxnH40mg As Long

-    ClxnT40mg As Long

-    ClxnC_IM As Long

-    ClxnC_ACS As Long

-End Type

-

-Function Get_QTR_Record(ByVal QTR_ID As Long) As tQTR

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_QTR_Record = dbGet_QTR_Record(dbConnection, QTR_ID)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_Record(dbConnection As Object, ByVal QTR_ID As Long) As tQTR

-    

-    Dim sql As String

-    Dim objQTR As tQTR

-    

-    With objQTR

-        .ClxnC_ACS = 0

-        .ClxnC_IM = 0

-        .ClxnH20mg = 0

-        .ClxnH40mg = 0

-        .ClxnT40mg = 0

-        .entry_date = ""

-        .id = QTR_ID

-    End With

-    

-    sql = "SELECT * FROM quarter WHERE id=" & QTR_ID

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objQTR.entry_date = dbRecordset("entry_date")

-        objQTR.rep_id = dbRecordset("rep_id")

-        objQTR.sale_PLAN = dbRecordset("sale_plan")

-        objQTR.ClxnH20mg = dbRecordset("ClxnH20mg")

-        objQTR.ClxnH40mg = dbRecordset("ClxnH40mg")

-        objQTR.ClxnT40mg = dbRecordset("ClxnT40mg")

-        objQTR.ClxnC_IM = dbRecordset("ClxnC_IM")

-        objQTR.ClxnC_ACS = dbRecordset("ClxnC_ACS")

-        objQTR.id = dbRecordset("id")

-    End If

-    

-    dbGet_QTR_Record = objQTR

-

-End Function

-

-

-Function Get_QTR_Record_by_REP(ent_date As String, rep_id As Long) As tQTR

-    Dim dbConnection As Object

-    Dim allQTR() As tQTR

-    Dim i As Long

-

-    dbOpenConnection dbConnection

-

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id)

-    If i <> 0 Then

-        Get_QTR_Record_by_REP = allQTR(1)

-    End If

-

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTR_Records_by_REP(ByRef all_QTR() As tQTR, ent_date As String, rep_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-

-    GetAll_QTR_Records_by_REP = dbGetAll_QTR_Records_By_REP(dbConnection, all_QTR, ent_date, rep_id)

-

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGetAll_QTR_Records_By_REP(dbConnection As Object, all_QTR() As tQTR, ent_date As String, rep_id As Long) As Integer

-

-    Dim getCount_QTR_SQL As String

-    Dim getAll_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter " & _

-    "WHERE entry_date like '" & ent_date & "' AND rep_id=" & rep_id

-    getAll_QTR_SQL = "SELECT * FROM quarter " & _

-    "WHERE entry_date like '" & ent_date & "' AND rep_id=" & rep_id & " ORDER BY entry_date"

-

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-

-    dbRecordset.Close

-

-    dbGetAll_QTR_Records_By_REP = QTR_Count

-

-    If QTR_Count > 0 Then

-        'we have records

-        ReDim all_QTR(1 To QTR_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTR_SQL, dbConnection

-

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTR As tQTR

-                 With tmp_QTR

-                    .entry_date = dbRecordset("entry_date")

-                    .rep_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .ClxnH20mg = dbRecordset("ClxnH20mg")

-                    .ClxnH40mg = dbRecordset("ClxnH40mg")

-                    .ClxnT40mg = dbRecordset("ClxnT40mg")

-                    .ClxnC_IM = dbRecordset("ClxnC_IM")

-                    .ClxnC_ACS = dbRecordset("ClxnC_ACS")

-                    .id = dbRecordset("id")

-                 End With

-

-                 all_QTR(index) = tmp_QTR

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-cdbQTR
->>>>>>
-Attribute VB_Name = "cdbQTR"

-Option Explicit

-

-Public Type tQTR_COMMON

-    qtr As tQTR

-    i_lcd As Long           ' число ЛПУ в СПИСКЕ

-    lcd() As tLPU_COMMON    ' список ЛПУ

-    c_beds As Long          ' сумма коек

-    c_bdgt_NFG As Long      ' общий бюджет на НФГ

-    c_bdgt_NMG As Long      ' общий бюджет на НМГ

-    c_bdgt_LPU As Long      ' общий бюджет на гепарины

-    c_sale_PLAN As Long     ' план продаж репа

-    c_sale_ALL As Long      ' продажи

-    c_sale_HIR As Long      ' в хирургии

-    c_sale_TER  As Long     ' в терапии

-    c_sale_CRD  As Long     ' в кардиологии

-    c_pat_HIR   As Long     ' пациенты

-    c_pat_TER   As Long     '

-    c_pat_CRD   As Long     '

-    c_pat_ALL   As Long     '

-    c_pat_LPU   As Long     ' Всего операций

-End Type

-

-Function GetLastQTR_fromDB() As String

-    Dim dbConnection As Object

-    Dim getCount_QTR_SQL As String

-    Dim getLast_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter"

-    getLast_QTR_SQL = "SELECT MAX(entry_date) as ent_date FROM quarter"

-    

-    dbOpenConnection dbConnection

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    If QTR_Count > 0 Then

-        'we have records

-        dbRecordset.Open getLast_QTR_SQL, dbConnection

-        getLast_QTR_SQL = dbRecordset("ent_date")

-    End If

-    GetLastQTR_fromDB = getLast_QTR_SQL

-    dbCloseConnection dbConnection

-End Function

-

-Function Get_QTR_CommonList_by_REP(ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_QTR_CommonList_by_REP = dbGet_QTR_CommonList_by_REP(dbConnection, qcd, ent_date, rep_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_CommonList_by_REP(dbConnection As Object, ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim allQTR() As tQTR

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id)

-    dbGet_QTR_CommonList_by_REP = i

-    If i > 0 Then

-        ReDim qcd(i)

-        For i = 1 To UBound(allQTR)

-            With qcd(i)

-                .qtr = allQTR(i)

-                .c_beds = 0

-                .c_bdgt_NFG = 0

-                .c_bdgt_NMG = 0

-                .c_bdgt_LPU = 0

-                .c_sale_PLAN = 0

-                .c_pat_HIR = 0

-                .c_pat_TER = 0

-                .c_pat_CRD = 0

-                .c_pat_ALL = 0

-                .c_sale_HIR = 0

-                .c_sale_TER = 0

-                .c_sale_CRD = 0

-                .c_sale_ALL = 0

-                .c_pat_LPU = 0

-                

-                j = dbGet_LPU_CommonQTR(dbConnection, .lcd, .qtr)

-                .i_lcd = j

-                If j > 0 Then

-                    For j = 1 To UBound(.lcd)

-                        .c_beds = .c_beds + .lcd(j).lpu.beds

-                        .c_bdgt_NFG = .c_bdgt_NFG + .lcd(j).bdgt.bdgt_NFG

-                        .c_bdgt_NMG = .c_bdgt_NMG + .lcd(j).bdgt.bdgt_NMG

-                        .c_bdgt_LPU = .c_bdgt_LPU + .lcd(j).bdgt_LPU

-                        .c_sale_PLAN = .c_sale_PLAN + .lcd(j).bdgt.sale_PLAN

-                        .c_pat_HIR = .c_pat_HIR + .lcd(j).pat_HIR

-                        .c_pat_TER = .c_pat_TER + .lcd(j).pat_TER

-                        .c_pat_CRD = .c_pat_CRD + .lcd(j).pat_CRD

-                        .c_pat_ALL = .c_pat_ALL + .lcd(j).pat_ALL

-                        .c_sale_HIR = .c_sale_HIR + .lcd(j).sale_HIR

-                        .c_sale_TER = .c_sale_TER + .lcd(j).sale_TER

-                        .c_sale_CRD = .c_sale_CRD + .lcd(j).sale_CRD

-                        .c_sale_ALL = .c_sale_ALL + .lcd(j).sale_ALL

-                        .c_pat_LPU = .c_pat_LPU + .lcd(j).pat_LPU

-                    Next j

-                    

-                End If

-            End With

-        Next i

-    End If

-End Function

-

-Function GetLastQtr() As String

-    Dim s As String

-    Dim r As Range

-    Set r = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Do While r.Cells(1, 1) <> ""

-        s = r.Cells(1, 1)

-        Set r = r.Cells.Offset(1, 0)

-    Loop

-    GetLastQtr = s

-End Function

-

-Function GetNextQTR(ent_date As String) As String

-    Dim rd As Range

-    Dim idx As Integer

-    Dim b As Variant

-    Dim dlg As dlg_newQTR

-    Set dlg = New dlg_newQTR

-    

-    If ent_date = "" Then

-        Dim ir As Variant

-        idx = 0

-        dlg.Show

-        b = dlg.Tag

-            

-        If IsNumeric(b) Then

-            GetNextQTR = dlg.cbQTR

-        Else

-            GetNextQTR = ""

-        End If

-    Else

-        Set rd = Worksheets(VAR_SHEET).Range("Date_Lst")

-        idx = WorksheetFunction.Match(ent_date, rd, 0)

-        GetNextQTR = WorksheetFunction.index(rd, idx + 1, 1)

-    End If

-End Function

-<<<<<<
-======================
-mRestView
->>>>>>
-Attribute VB_Name = "mRestView"

-Option Explicit

-

-Sub xlRestoreView()

-Attribute xlRestoreView.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute xlRestoreView.VB_ProcData.VB_Invoke_Func = " \n14"

-    With Application

-        .CommandBars("Standard").Visible = True

-        .CommandBars("Formatting").Visible = True

-        .DisplayFormulaBar = True

-        .DisplayStatusBar = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = True

-    End With

-End Sub

-<<<<<<
-======================
-dlg_newQTR
->>>>>>
-Attribute VB_Name = "dlg_newQTR"

-Attribute VB_Base = "0{3EA3C15A-5493-445F-9858-2F241E7D6CEA}{849C1FE1-631A-485D-BE54-A7B73124582C}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mDec2TS
->>>>>>
-Attribute VB_Name = "mDec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-CHRT_LPU_BBL
->>>>>>
-Attribute VB_Name = "CHRT_LPU_BBL"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Unprotect

-    Range("view_key") = True

-    On Error Resume Next

-    ChangeLabels

-    Range("A1").Select

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Unprotect

-    Dim s As String

-    s = Range("ret_addr")

-    Protect UserInterfaceOnly:=True

-    Wks_select (s)

-End Sub

-

-Sub BCLabelChng_Click()

-    Unprotect

-    If Range("view_key") Then

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать названия"

-    Else

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать объемы"

-    End If

-    Range("view_key") = Not Range("view_key")

-    ChangeLabels

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub ChangeLabels()

-    Dim i As Integer

-    Dim offset_text As Integer

-    Dim src As Range

-    Set src = Range("CHRT_BBL_DATA")

-    

-    offset_text = 3

-    If Range("view_key") Then

-        offset_text = 4

-    End If

-    

-    With ChartObjects(1).Chart

-        With .SeriesCollection(1)

-            For i = 1 To .Points.count

-                On Error GoTo ExitLabel

-                .Points(i).DataLabel.Characters.Text = Format(src.Cells(i, offset_text))

-            Next i

-        End With

-    End With

-ExitLabel:

-End Sub

-

-<<<<<<
-======================
-CHRT_PAT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PAT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-<<<<<<
-======================
-CHRT_PAT_LPU
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_nextQTR
->>>>>>
-Attribute VB_Name = "dlg_nextQTR"

-Attribute VB_Base = "0{B85FF7F1-50C0-4433-BC6F-8A0F2C9BDDDA}{EC2D2B9E-9ED2-4005-A1E9-EF0626D3B7E7}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-cdbLPU
->>>>>>
-Attribute VB_Name = "cdbLPU"

-Option Explicit

-

-Public Type tLPU_COMMON

-    lpu As tLPU

-    bdgt As tBUDGET

-    i_hir As Long

-    hir() As tHIRURGIA

-    i_ter As Long

-    ter() As tTERAPIA

-    i_ACS As Long

-    ACS() As tACS

-    bdgt_LPU As Long

-    sale_HIR As Long

-    sale_TER As Long

-    sale_CRD As Long

-    sale_ALL As Long

-    pat_HIR As Long

-    pat_TER As Long

-    pat_CRD As Long

-    pat_ALL As Long     ' Сумма всех пациентов на клексане

-    pat_LPU As Long     ' Число потенциальных пациентов для продаж клексана

-End Type

-

-Function Get_LPU_CommonQTR(ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    Get_LPU_CommonQTR = dbGet_LPU_CommonQTR(dbConnection, lcd, objQTR)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_CommonQTR(dbConnection As Object, ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    i = dbGetAll_LPU_byQTR(dbConnection, allLPU, objQTR.entry_date, objQTR.rep_id)

-    dbGet_LPU_CommonQTR = i

-    If i > 0 Then

-        ReDim lcd(i)

-        For i = 1 To UBound(allLPU)

-            dbGet_LPU_Common dbConnection, lcd(i), allLPU(i), objQTR

-        Next i

-    End If

-End Function

-

-Sub Get_LPU_Common(ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    dbGet_LPU_Common dbConnection, lcd, cLPU, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbGet_LPU_Common(dbConnection As Object, ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-

-    lcd.lpu = cLPU

-    lcd.bdgt = dbGet_BDGT_Record(dbConnection, cLPU.id, objQTR.entry_date)

-    lcd.i_hir = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, lcd.hir, cLPU.id, objQTR.entry_date)

-    lcd.i_ter = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, lcd.ter, cLPU.id, objQTR.entry_date)

-    lcd.i_ACS = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, lcd.ACS, cLPU.id, objQTR.entry_date)

-    With lcd

-        .bdgt_LPU = .bdgt.bdgt_NFG + .bdgt.bdgt_NMG

-        .pat_LPU = 0

-        If .i_hir > 0 Then

-            .pat_HIR = .hir(1).patients_ambulator_clexan + .hir(1).patients_stationar_clexan

-            .sale_HIR = objQTR.ClxnH20mg * (.hir(1).patients_ambulator_clexan_20mg + .hir(1).patients_stationar_clexan_20mg)

-            .sale_HIR = .sale_HIR + objQTR.ClxnH40mg * (.hir(1).patients_ambulator_clexan_40mg + .hir(1).patients_stationar_clexan_40mg)

-            .pat_LPU = .pat_LPU + .hir(1).operations_per_quarter

-        End If

-        If .i_ter > 0 Then

-            .pat_TER = .ter(1).patients_ambulator_clexan + .ter(1).patients_stationar_clexan

-            .sale_TER = .pat_TER * objQTR.ClxnT40mg

-            .pat_LPU = .pat_LPU + .ter(1).patients_per_quarter

-        End If

-        If .i_ACS > 0 Then

-            .pat_CRD = .ACS(1).patients_stationar_clexan

-            .sale_CRD = .pat_CRD * objQTR.ClxnC_ACS

-            .pat_LPU = .pat_LPU + .ACS(1).patients_per_quarter

-        End If

-        .pat_ALL = .pat_HIR + .pat_TER + .pat_CRD

-        .sale_ALL = .sale_HIR + .sale_TER + .sale_CRD

-    End With

-End Sub

-

-<<<<<<
-======================
-CHRT_PIE
->>>>>>
-Attribute VB_Name = "CHRT_PIE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    

-    Unprotect

-    

-    On Error Resume Next

-    

-    Range("P5:Q24").Sort _

-        Key1:=Range("Q5"), _

-        Order1:=xlDescending, _

-        Header:=xlGuess, _

-        OrderCustom:=1, _

-        MatchCase:=False, _

-        Orientation:=xlTopToBottom

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PLN_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PLN_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_BDGT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_BDGT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_LPU_delete
->>>>>>
-Attribute VB_Name = "dlg_LPU_delete"

-Attribute VB_Base = "0{EC96F2D1-337D-47DF-B0F1-A6DF3F8CD5CC}{7EB42A63-CBFC-45B0-AE4D-C3E3D8FE7420}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlg_Mail
->>>>>>
-Attribute VB_Name = "dlg_Mail"

-Attribute VB_Base = "0{7B669454-C2AA-4FDF-8311-7ADEDDEF3FF3}{D07A0A02-4923-46C8-8EE8-62769243087D}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dbREP_id
->>>>>>
-Attribute VB_Name = "dbREP_id"

-Public Type tREPID

-    rep_id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function GetAll_REPID_Records_by_QTR(ByRef all_REPID() As tREPID, ent_date As String) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_REPID_Records_by_QTR = dbGetAll_REPID_Records_by_QTR(dbConnection, all_REPID, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-Function Get_REPID_Record(id As Long) As tREPID

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REPID_Record = dbGet_REPID_Record(dbConnection, id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_REPID_Records(ByRef all_REPID() As tREPID) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_REPID_Records = dbGetAll_REPID_Records(dbConnection, all_REPID)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function dbGet_REPID_Record(dbConnection As Object, id As Long) As tREPID

-    

-    Dim sql As String

-    Dim objREPID As tREPID

-    

-    objREPID.FirstName = ""

-    objREPID.LastName = ""

-    objREPID.Region = 0

-    objREPID.City = 0

-    sql = "SELECT rep_id, firstname, lastname, region, city FROM " & _

-          "rep WHERE rep_id=" & id

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREPID.rep_id = dbRecordset("rep_id")

-        objREPID.FirstName = dbRecordset("firstname")

-        objREPID.LastName = dbRecordset("lastname")

-        objREPID.Region = dbRecordset("region")

-        objREPID.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REPID_Record = objREPID

-        

-End Function

-

-Function dbGetAll_REPID_Records_by_QTR(dbConnection As Object, ByRef all_REPID() As tREPID, ent_date As String) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    Dim Where As String

-    

-    REPID_Count = 0

-    Where = " WHERE lpu_budget.entry_date like '" & ent_date & "' " & _

-        "AND rep.rep_id=lpu.rep_id AND lpu.id=lpu_budget.lpu_id"

-    

-    

-    getAll_REPID_SQL = "SELECT distinct rep.* FROM rep, lpu, lpu_budget" & Where

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM (" & getAll_REPID_SQL & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records_by_QTR = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Function dbGetAll_REPID_Records(dbConnection As Object, ByRef all_REPID() As tREPID) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    REPID_Count = 0

-    

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM rep"

-    getAll_REPID_SQL = "SELECT * FROM rep"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-cdbExport
->>>>>>
-Attribute VB_Name = "cdbExport"

-Option Explicit

-

-Function GetDBSN() As String

-    Dim n As Long

-    Randomize Timer

-    n = Int((100000000 - 1000000 + 1) * Rnd + 1000000)

-    GetDBSN = Dec2ThirtySix(n)

-End Function

-

-Sub dbExport()

-    Dim src_file As String

-    Dim dst_file As String

-    

-    On Error GoTo ErrHandler

-    

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & GetLastQTR_fromDB & "_" & GetDBSN() & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Данные экспортированы в файл:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для передачи", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-Exit Sub

-

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-<<<<<<
-======================
-mRegs
->>>>>>
-Attribute VB_Name = "mRegs"

-Option Explicit

-

-Function GetRegionName(idx As Integer) As String

-    GetRegionName = Worksheets(REGS_SHEET).Range("LST_REGIONS").Cells(idx + 1, 1).Text

-End Function

-

-Function GetCityName(idx_reg As Integer, idx_city As Integer) As String

-    GetCityName = Worksheets(REGS_SHEET).Range("CITY_TABLES").Offset(idx_city + 1, idx_reg * 2).Text

-End Function

-

-Sub testReg()

-    Dim r As Integer

-    Dim c As Integer

-    Dim s As String

-    

-    r = 3

-    c = 3

-    s = GetRegionName(r)

-    s = s & ", " & GetCityName(r, c)

-    MsgBox s

-End Sub

-

-<<<<<<
-======================
-RM_QTR
->>>>>>
-Attribute VB_Name = "RM_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CRGN_QT As Integer = 0

-Const CRGN_PLN As Integer = 2

-Const CRGN_FCT As Integer = 3

-Const CRGN_BDG As Integer = 4

-Const CRGN_LPU As Integer = 5

-Const CRGN_REP As Integer = 6

-Const CRGN_HIR As Integer = 7

-Const CRGN_TER As Integer = 8

-Const CRGN_CRD As Integer = 9

-Const CRGN_CLXN_BDG As Integer = 10

-Const CRGN_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub ClearRMName()

-    Unprotect

-    Range("D4") = ""

-    Range("D5") = ""

-    Range("H4") = ""

-End Sub

-

-Sub update_history()

-    Dim objRGN() As tREGION

-    Dim i As Long

-    Dim r As Range

-    Dim cRMan As tREGMAN

-

-    cRMan = Get_REGMAN_Record

-    

-    Range("D4") = cRMan.LastName

-    Range("D5") = cRMan.FirstName

-

-    Range("H4") = GetRegionName(cRMan.Region)

-    

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetRGN_COMM_DATA(objRGN)

-    

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objRGN)

-            r.Offset(i - 1, CRGN_QT) = objRGN(i).ent_date

-            r.Offset(i - 1, CRGN_FCT) = objRGN(i).total_SALE

-            r.Offset(i - 1, CRGN_PLN) = objRGN(i).sale_PLAN

-            r.Offset(i - 1, CRGN_BDG) = objRGN(i).total_BDGT

-            r.Offset(i - 1, CRGN_LPU) = objRGN(i).total_LPU

-            r.Offset(i - 1, CRGN_REP) = objRGN(i).total_REP

-            r.Offset(i - 1, CRGN_HIR) = objRGN(i).total_HIR

-            r.Offset(i - 1, CRGN_TER) = objRGN(i).total_TER

-            r.Offset(i - 1, CRGN_CRD) = objRGN(i).total_ACS

-            If objRGN(i).total_BDGT <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_BDG) = objRGN(i).total_SALE / objRGN(i).total_BDGT

-            End If

-            If objRGN(i).total_BDGT_NMG <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_NMG) = objRGN(i).total_SALE / objRGN(i).total_BDGT_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRGN_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRM_QtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR_RM

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR_RM

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR_RM

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = RM_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect UserInterfaceOnly:=True

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CRGN_QT + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    If r = "" Then

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = currRange.address

-        With Worksheets("REP_LIST")

-            .Range("ret_addr") = "RM_QTR"

-            .Range("ent_date") = r

-            .Range("VIEW_ONLY") = True

-        End With

-    End If

-    Cancel = True

-    btRM_QTR_Do_IT

-End Sub

-

-<<<<<<
-======================
-dbREG_MAN
->>>>>>
-Attribute VB_Name = "dbREG_MAN"

-Option Explicit

-

-Public Type tREGMAN

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function Get_REGMAN_Record() As tREGMAN

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REGMAN_Record = dbGet_REGMAN_Record(dbConnection)

-    dbCloseConnection dbConnection

-End Function

-

-Sub Set_REGMAN_Record(cREGMAN As tREGMAN)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbSet_REGMAN_Record dbConnection, cREGMAN

-    dbCloseConnection dbConnection

-End Sub

-

-Sub ReSet_REGMAN_Record()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbReSet_REGMAN_Record dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_REGMAN_Record(dbConnection As Object) As tREGMAN

-    

-    Dim sql As String

-    Dim objREGMAN As tREGMAN

-    

-    objREGMAN.FirstName = ""

-    objREGMAN.LastName = ""

-    objREGMAN.Region = 0

-    objREGMAN.City = 0

-    sql = "SELECT firstname, lastname, region, city FROM " & _

-          "reg_man"

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREGMAN.FirstName = dbRecordset("firstname")

-        objREGMAN.LastName = dbRecordset("lastname")

-        objREGMAN.Region = dbRecordset("region")

-        objREGMAN.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REGMAN_Record = objREGMAN

-        

-End Function

-

-Public Sub dbSet_REGMAN_Record(dbConnection As Object, ByRef objREGMAN As tREGMAN)

-  

-    Dim DeleteSQL As String

-    Dim InsertSQL As String

-    

-    DeleteSQL = "DELETE FROM reg_man"

-    InsertSQL = "INSERT INTO reg_man (firstname, lastname, region, city) VALUES (" & _

-    "'" & objREGMAN.FirstName & "', " & _

-    "'" & objREGMAN.LastName & "', " & _

-    objREGMAN.Region & ", " & _

-    objREGMAN.City & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    dbRecordset.Open InsertSQL, dbConnection

-       

-End Sub

-

-Public Sub dbReSet_REGMAN_Record(dbConnection As Object)

-  

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM reg_man"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    

-End Sub

-

-

-<<<<<<
-======================
-dbDatabaseMerge
->>>>>>
-Attribute VB_Name = "dbDatabaseMerge"

-Option Explicit

-

-Public Type tDBFIELD

-    name As String

-End Type

-

-Public Type tDBTABLE

-    name As String

-    field() As tDBFIELD

-End Type

-

-

-Function dbGetConnection(dbAccessFileFullPath As String) As Object

-    Dim dbConnection As Object

-    Dim dbAccessFilePasswd As String

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFileFullPath & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    Set dbGetConnection = dbConnection

-End Function

-

-Sub dbCloseOpenedConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteOpenedSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-Function dbMergeREP(from_dbConnection As Object, to_dbConnection As Object) As Long

-

-    Dim getRecordset As Object

-    Dim getREPData_SQL As String

-    Dim REP_fn As String

-    Dim REP_ln As String

-    Dim REP_region As String

-    Dim REP_city As String

-

-

-    getREPData_SQL = "SELECT * FROM rep"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getREPData_SQL, from_dbConnection

-        

-        If Not getRecordset.BOF Then

-            REP_fn = getRecordset("firstname")

-            REP_ln = getRecordset("lastname")

-            REP_city = getRecordset("city")

-            REP_region = getRecordset("region")

-        Else

-            MsgBox "There is no information about rep! This database cannot be merged!!!"

-            dbMergeREP = -1

-            Exit Function

-        End If

-    

-    Dim insertRecordset As Object

-    Set insertRecordset = CreateObject("ADODB.Recordset")

-        

-    insertRecordset.Open "rep", to_dbConnection, 2, 2

-    insertRecordset.addnew

-        

-    insertRecordset("firstname") = REP_fn

-    insertRecordset("lastname") = REP_ln

-    insertRecordset("region") = REP_region

-    insertRecordset("city") = REP_city

-    insertRecordset.Update

-    insertRecordset.MoveLast

-    'new ID

-    

-    dbMergeREP = insertRecordset("rep_id")

-    

-End Function

-

-Sub dbMergeLPU(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getLPU_SQL As String

-    Dim getRecordset As Object

-    Dim idx As Long

-    idx = 1

-    

-    getLPU_SQL = "SELECT * FROM lpu"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getLPU_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            ReDim Preserve objLPU(1 To idx)

-            objLPU(idx).old_lpu_id = getRecordset("id")

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "lpu", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("name") = getRecordset("name")

-            insRS("address") = getRecordset("address")

-            insRS("beds") = getRecordset("beds")

-            insRS.Update

-            insRS.MoveLast

-            'new ID

-            

-            objLPU(idx).new_lpu_id = insRS("id")

-                        

-            idx = idx + 1

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about LPU! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-

-Sub dbMergeLPURelated(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object)

-

-    ' 6 tables to change

-    Dim tables(1 To 5) As tDBTABLE

-    

-    'lpu budget

-    tables(1).name = "lpu_budget"

-    ReDim tables(1).field(1 To 4)

-    

-    tables(1).field(1).name = "entry_date"

-    tables(1).field(2).name = "bdgt_NMG"

-    tables(1).field(3).name = "bdgt_NFG"

-    tables(1).field(4).name = "sale_PLAN"

-    

-    'lpu hir

-    tables(2).name = "lpu_hir"

-    ReDim tables(2).field(1 To 13)

-    

-    tables(2).field(1).name = "entry_date"

-    tables(2).field(2).name = "operations_per_quarter"

-    tables(2).field(3).name = "risk_percent"

-    tables(2).field(4).name = "patients_with_risk_ON"

-    tables(2).field(5).name = "patients_ambulator"

-    tables(2).field(6).name = "patients_ambulator_nmg"

-    tables(2).field(7).name = "patients_ambulator_clexan"

-    tables(2).field(8).name = "patients_ambulator_clexan_40mg"

-    tables(2).field(9).name = "patients_ambulator_clexan_20mg"

-    tables(2).field(10).name = "patients_stationar_nmg"

-    tables(2).field(11).name = "patients_stationar_clexan"

-    tables(2).field(12).name = "patients_stationar_clexan_40mg"

-    tables(2).field(13).name = "patients_stationar_clexan_20mg"

-    

-    

-    'lpu acs

-    tables(3).name = "lpu_acs"

-    ReDim tables(3).field(1 To 5)

-    

-    tables(3).field(1).name = "entry_date"

-    tables(3).field(2).name = "patients_with_geparins"

-    tables(3).field(3).name = "patients_per_quarter"

-    tables(3).field(4).name = "patients_stationar_nmg"

-    tables(3).field(5).name = "patients_stationar_clexan"

-    

-    'lpu acs

-    tables(4).name = "lpu_im"

-    ReDim tables(4).field(1 To 5)

-    

-    tables(4).field(1).name = "entry_date"

-    tables(4).field(2).name = "patients_with_geparins"

-    tables(4).field(3).name = "patients_per_quarter"

-    tables(4).field(4).name = "patients_stationar_nmg"

-    tables(4).field(5).name = "patients_stationar_clexan"

-    

-    

-    'lpu acs

-    tables(5).name = "lpu_ter"

-    ReDim tables(5).field(1 To 9)

-    

-    tables(5).field(1).name = "entry_date"

-    tables(5).field(2).name = "patients_per_quarter"

-    tables(5).field(3).name = "risk_percent"

-    tables(5).field(4).name = "patients_with_risk_ON"

-    tables(5).field(5).name = "patients_ambulator"

-    tables(5).field(6).name = "patients_ambulator_nmg"

-    tables(5).field(7).name = "patients_ambulator_clexan"

-    tables(5).field(8).name = "patients_stationar_nmg"

-    tables(5).field(9).name = "patients_stationar_clexan"

-    

-    

-    

-    Dim tbl_idx As Integer

-    

-    For tbl_idx = 1 To UBound(tables)

-        

-        Dim getSQL As String

-        Dim getRS As Object

-        

-        

-        

-        Set getRS = CreateObject("ADODB.Recordset")

-        

-        getSQL = "SELECT * FROM " & tables(tbl_idx).name

-        getRS.Open getSQL, from_db

-        

-        If Not getRS.BOF Then

-            Do While Not getRS.EOF

-                Dim insRS As Object

-                Set insRS = CreateObject("ADODB.Recordset")

-                

-                insRS.Open tables(tbl_idx).name, to_db, 2, 2

-                insRS.addnew

-                Dim fld_idx As Integer

-    

-                    For fld_idx = 1 To UBound(tables(tbl_idx).field)

-                        insRS(tables(tbl_idx).field(fld_idx).name) = getRS(tables(tbl_idx).field(fld_idx).name)

-                        insRS("lpu_id") = findNewLPU_IDByOld(objLPU, getRS("lpu_id"))

-                    Next fld_idx

-                    

-                insRS.Update

-                insRS.MoveLast

-                getRS.MoveNext

-            Loop

-        End If

-        

-        

-    Next tbl_idx

-

-End Sub

-

-Function findNewLPU_IDByOld(objLPU() As tLPUCONVERTION, old_id As Long)

-

-Dim i As Integer

-For i = 1 To UBound(objLPU)

-    If objLPU(i).old_lpu_id = old_id Then

-        findNewLPU_IDByOld = objLPU(i).new_lpu_id

-        Exit Function

-    End If

-Next i

-

-findNewLPU_IDByOld = -1

-End Function

-

-

-

-

-

-Sub dbMergeQTR(from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getQTR_SQL As String

-    Dim getRecordset As Object

-    

-    getQTR_SQL = "SELECT * FROM quarter"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getQTR_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "quarter", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("entry_date") = getRecordset("entry_date")

-            insRS("sale_plan") = getRecordset("sale_plan")

-            insRS("ClxnH20mg") = getRecordset("ClxnH20mg")

-            insRS("ClxnH40mg") = getRecordset("ClxnH40mg")

-            insRS("ClxnT40mg") = getRecordset("ClxnT40mg")

-            insRS("ClxnC_IM") = getRecordset("ClxnC_IM")

-            insRS("ClxnC_ACS") = getRecordset("ClxnC_ACS")

-            

-            

-            insRS.Update

-            

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about quarter budget! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-dbMerge
->>>>>>
-Attribute VB_Name = "dbMerge"

-Option Explicit

-

-Public Type tLPUCONVERTION

-    old_lpu_id As Long

-    new_lpu_id As Long

-End Type

-

-Sub Merge_BackUp_All_Data()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim time_stump As String

-    

-    On Error GoTo ErrHandler

-    

-    time_stump = Format(Date, "yy-mm-dd_") & Format(Time, "hh-mm")

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_BACKUPNAME & time_stump & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Старые данные сохранены в файле:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для восстановления данных в случае утери", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-    Exit Sub

-    

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-

-Sub Merge_Clear_All_Data(access_file_full_path As String)

-    

-    Dim db As Object

-    Dim tables_to_clear() As String

-    On Error GoTo ErrHandler

-    

-    ReDim tables_to_clear(1 To 8)

-    tables_to_clear(1) = "rep"

-    tables_to_clear(2) = "lpu"

-    tables_to_clear(3) = "lpu_budget"

-    tables_to_clear(4) = "lpu_hir"

-    tables_to_clear(5) = "lpu_ter"

-    tables_to_clear(6) = "lpu_acs"

-    tables_to_clear(7) = "lpu_im"

-    tables_to_clear(8) = "quarter"

-    

-    Set db = dbGetConnection(access_file_full_path)

-

-    Dim i As Integer

-    

-    For i = 1 To UBound(tables_to_clear)

-        

-        If tables_to_clear(i) <> "" Then

-            Dim Clear_SQL As String

-            Clear_SQL = "DELETE FROM " & tables_to_clear(i)

-            dbExecuteOpenedSQL db, Clear_SQL

-        Else

-            'do nothing or show message

-        End If

-    Next i

-    

-    dbCloseOpenedConnection db

-    Set db = Nothing

-    

-'    Dim Engine As Object

-'    Set Engine = CreateObject("JRO.JetEngine")

-'    Engine.CompactDatabase "Password=password;Data Source=" & access_file_full_path, _

-'    "Password=password;Data Source=c:\tmp\1.mdb"

-    

-Exit Sub

-

-ErrHandler:

-    MsgBox "something wrong: " & err.Description

-    Resume Next

-    

-End Sub

-

-Function MergeREP(from_file As String, to_file As String) As Long

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    Dim new_rep_id As Long

-

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    MergeREP = dbMergeREP(db1, db2)

-    'MsgBox "new rep ID is " & new_rep_id

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Function

-

-Sub MergeQTR(from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeQTR db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-

-Sub MergeLPU(objLPU() As tLPUCONVERTION, from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeLPU objLPU, db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-Sub MergeLPURelated(objLPU() As tLPUCONVERTION, from_file As String, to_file As String)

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    dbMergeLPURelated objLPU, db1, db2

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-

-End Sub

-

-Sub MergeGlobal(rep_files() As String, rm_file As String)

-

-    Dim i As Integer

-    'clear output file content

-    Merge_Clear_All_Data rm_file

-    

-    For i = 1 To UBound(rep_files)

-        

-        Dim rep_file As String

-        'setup input and output files

-        rep_file = rep_files(i)

-        

-        Dim new_rep_id As Long

-        ' insert REP data and get new rep_id

-        new_rep_id = MergeREP(rep_file, rm_file)

-        

-        Dim objLPU() As tLPUCONVERTION

-        'insert all LPU using new generated rep_id

-        'and populate objLPU old->new relation object

-        

-        MergeLPU objLPU, rep_file, rm_file, new_rep_id

-        'insert quarter data using new rep_id

-        MergeQTR rep_file, rm_file, new_rep_id

-        

-        

-        ' and.... insert all another data (5 tables excl version and hw)

-        'using objLPU old->new relation object

-        MergeLPURelated objLPU, rep_file, rm_file

-    

-    

-    Next i

-    

-End Sub

-

-Function GetDBList(MyPath() As String, ByRef dblist() As String) As Integer

-    Dim i As Integer

-    Dim MyName, MyMask

-    MyMask = MyPath(0) & MyPath(1) & PROGRAM_DATAEXT

-    i = 0

-    MyName = Dir(MyMask)      ' Retrieve the first entry.

-    Do While MyName <> ""    ' Start the loop.

-        ' Ignore the current directory and the encompassing directory.

-        If MyName <> "." And MyName <> ".." Then

-            ' Use bitwise comparison to make sure MyName is a directory.

-            i = i + 1

-            ReDim Preserve dblist(i)

-            dblist(i) = MyPath(0) & MyName

-        End If

-        MyName = Dir    ' Get next entry.

-    Loop

-    GetDBList = i

-End Function

-

-<<<<<<
-======================
-dlgImprtDB
->>>>>>
-Attribute VB_Name = "dlgImprtDB"

-Attribute VB_Base = "0{D5892870-2C88-40C8-A817-AC9B1CF37C2C}{9853EBEA-4E48-41F9-89C0-6F753EB6A0C2}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Private Sub btSelAll_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = True

-    Next i

-End Sub

-

-Private Sub btUnselect_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = False

-    Next i

-End Sub

-<<<<<<
-======================
-dbQTR_RM
->>>>>>
-Attribute VB_Name = "dbQTR_RM"

-Option Explicit

-

-Public Type tQTRRM

-    id As Long

-    entry_date As String

-    rm_id As Long

-    sale_PLAN As Long

-End Type

-

-

-Sub Insert_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objQTRRM.id <> 0 Then

-        dbUpdate_QTRRM_Record dbConnection, objQTRRM

-    Else

-        dbInsert_QTRRM_Record dbConnection, objQTRRM

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-Function Get_QTRRM_Record(ent_date As String) As tQTRRM

-    Dim dbConnection As Object

-    Dim allQTRRM() As tQTRRM

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    i = dbGetAll_QTRRM_Records(dbConnection, allQTRRM, ent_date)

-    If i <> 0 Then

-        Get_QTRRM_Record = allQTRRM(1)

-    End If

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTRRM_Records(ByRef all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_QTRRM_Records = dbGetAll_QTRRM_Records(dbConnection, all_QTRRM, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_QTRRM_Record dbConnection, objQTRRM

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objQTRRM.ID <> 0 then updatre else insert

-Sub dbInsert_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "quarter_rm", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objQTRRM

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("sale_plan") = .sale_PLAN

-        dbRecordset("rm_id") = .rm_id

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objQTRRM.id = dbRecordset("id")

-

-End Sub

-

-Sub dbUpdate_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim Update_SQL As String

-    

-    With objQTRRM

-        Update_SQL = "UPDATE quarter_rm SET " & _

-            "entry_date='" & .entry_date & "'" & "," & _

-            "rm_id=" & .rm_id & "," & _

-            "sale_plan=" & .sale_PLAN & "," & _

-            " WHERE id=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if ent_date = % then all_records

-Function dbGetAll_QTRRM_Records(dbConnection As Object, all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    

-    Dim getCount_QTRRM_SQL As String

-    Dim getAll_QTRRM_SQL As String

-    Dim QTRRM_Count As Long

-    QTRRM_Count = 0

-    

-    getCount_QTRRM_SQL = "SELECT COUNT(*) AS QTRRM_TOTAL FROM quarter_rm WHERE entry_date like '" & ent_date & "'"

-    getAll_QTRRM_SQL = "SELECT * FROM quarter_rm WHERE entry_date like '" & ent_date & "' ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTRRM_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTRRM_Count = dbRecordset("QTRRM_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_QTRRM_Records = QTRRM_Count

-    

-    If QTRRM_Count > 0 Then

-        'we have records

-        ReDim all_QTRRM(1 To QTRRM_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTRRM_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTRRM As tQTRRM

-                 With tmp_QTRRM

-                    .entry_date = dbRecordset("entry_date")

-                    .rm_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .id = dbRecordset("id")

-                 End With

-                 

-                 all_QTRRM(index) = tmp_QTRRM

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM quarter_rm " & _

-    "WHERE id=" & objQTRRM.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-    

-    'delete related budget entries

-    MsgBox "remember delete related"

-'    dbDelete_BDGT_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Hir_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Ter_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_ACS_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-       

-End Sub

-

-

-<<<<<<
-======================
-REP_LIST
->>>>>>
-Attribute VB_Name = "REP_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentREP_ID() As Long

-    Dim r As Range

-

-    With Worksheets("REP_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CREP_ID)

-    End With

-

-    getCurrentREP_ID = r

-End Function

-

-Public Sub REP_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Rep_Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Rep_Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Rep_Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Rep_Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectREP_LPU(rep_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim r_id As Long

-    

-    Range("JUMP") = "LPU_LIST"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-        .Range("ent_date") = ent_date

-    End With

-End Sub

-

-Public Sub SelectREP_QTR(rep_id As Long)

-    Dim vo As Boolean

-    Dim r_id As Long

-    

-    Range("JUMP") = "REP_QTR"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("REP_QTR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateREPList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim rep_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CREP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CREP_AREA).row, CREP_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    rep_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CREP_AREA).Column

-    

-    If i < 4 Then

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 1

-    Else

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 2

-    End If

-    

-    If rep_id = 0 Then

-        Range("LAST_FOCUS") = Range(CREP_AREA).address

-    End If

-

-    If rep_id = 0 Then

-        i = CREP_NAME

-        Range("JUMP") = ""

-    Else

-        btREP_LIST_DO_IT

-    End If

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateREPList()

-    Dim rcd() As tREPID_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-

-    ent_date = getEnt_date

-

-    i = Get_REP_CommonList_by_QTR(rcd, ent_date)

-

-    With ThisWorkbook.Worksheets("REP_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(rcd)

-            r.Offset(i - 1, CREP_NAME) = rcd(i).rep.FirstName & " " & rcd(i).rep.LastName

-            r.Offset(i - 1, CREP_ID) = rcd(i).rep.rep_id

-            r.Offset(i - 1, CREP_BEDS) = rcd(i).qtrs(1).c_beds

-

-            r.Offset(i - 1, CREP_NFG) = rcd(i).qtrs(1).c_bdgt_NFG

-            r.Offset(i - 1, CREP_NMG) = rcd(i).qtrs(1).c_bdgt_NMG

-

-            r.Offset(i - 1, CREP_PLAN) = rcd(i).qtrs(1).qtr.sale_PLAN

-

-            r.Offset(i - 1, CREP_HIR) = rcd(i).qtrs(1).c_pat_HIR

-            r.Offset(i - 1, CREP_TER) = rcd(i).qtrs(1).c_pat_TER

-            r.Offset(i - 1, CREP_CAR) = rcd(i).qtrs(1).c_pat_CRD

-            r.Offset(i - 1, CREP_FACT) = rcd(i).qtrs(1).c_sale_ALL

-            r.Offset(i - 1, CREP_PAT_LPU) = rcd(i).qtrs(1).c_pat_LPU

-            r.Offset(i - 1, CREP_BDGT) = rcd(i).qtrs(1).c_bdgt_LPU

-            If rcd(i).qtrs(1).c_bdgt_LPU > 0 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = rcd(i).qtrs(1).c_sale_ALL / rcd(i).qtrs(1).c_bdgt_LPU

-            End If

-            If r.Offset(i - 1, CREP_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-

-

-<<<<<<
-======================
-mREP_LIST
->>>>>>
-Attribute VB_Name = "mREP_LIST"

-Option Explicit

-

-Public Const CREP_AREA As String = "B12"

-Public Const CREP_NAME As Integer = 0

-Public Const CREP_NAME1 As Integer = 1

-Public Const CREP_NAME2 As Integer = 2

-Public Const CREP_ID As Integer = 3

-Public Const CREP_BEDS As Integer = 4

-Public Const CREP_NFG As Integer = 5

-Public Const CREP_NMG As Integer = 6

-Public Const CREP_HIR As Integer = 7

-Public Const CREP_TER As Integer = 8

-Public Const CREP_CAR As Integer = 9

-Public Const CREP_FACT As Integer = 10

-Public Const CREP_PLAN As Integer = 11

-Public Const CREP_PAT_LPU As Integer = 16

-Public Const CREP_BDGT As Integer = 17

-Public Const CREP_PAT_ALL As Integer = 16

-

-

-

-Sub EditREP(cRep As tREPID, ent_date As String)

-    NoFunc

-End Sub

-

-Sub Rep_Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btREP_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = "RM_QTR"

-    End With

-    ThisWorkbook.Worksheets("RM_QTR").Activate

-End Sub

-

-

-Sub btREP_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim rep_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("REP_LST_DETALS")

-    With Worksheets("REP_LIST")

-        rep_id = .getCurrentREP_ID

-        

-        Select Case i

-            Case 1:

-                .SelectREP_QTR rep_id

-            Case 2:

-                ent_date = .getEnt_date()

-                .SelectREP_LPU rep_id, ent_date

-        End Select

-    End With

-    

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-

-

-

-<<<<<<
-======================
-cdbREP
->>>>>>
-Attribute VB_Name = "cdbREP"

-Option Explicit

-

-Public Type tREPID_COMMON

-    rep As tREPID

-    i_qtrs As Integer

-    qtrs() As tQTR_COMMON

-End Type

-

-Function Get_REP_CommonList_by_QTR(ByRef rcd() As tREPID_COMMON, ent_date As String) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_REP_CommonList_by_QTR = dbGet_REP_CommonList_by_QTR(dbConnection, rcd, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_REP_CommonList_by_QTR(dbConnection As Object, ByRef rcd() As tREPID_COMMON, ent_date As String) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim k As Long

-    Dim allREPID() As tREPID

-    

-    i = dbGetAll_REPID_Records_by_QTR(dbConnection, allREPID, ent_date)

-    dbGet_REP_CommonList_by_QTR = i

-    If i > 0 Then

-        ReDim rcd(i)

-        For i = 1 To UBound(allREPID)

-            rcd(i).rep = allREPID(i)

-            rcd(i).i_qtrs = Get_QTR_CommonList_by_REP(rcd(i).qtrs, ent_date, allREPID(i).rep_id)

-        Next i

-    End If

-End Function

-

-

-

-<<<<<<
-======================
-CHRT_PAT_LPU_A
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU_A"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-cdbRegion
->>>>>>
-Attribute VB_Name = "cdbRegion"

-Option Explicit

-

-Type tREGION

-    ent_date As String

-    total_SALE As Long ' общий объем продаж

-    total_BDGT As Long ' бюджет всех ЛПУ

-    total_BDGT_NMG As Long ' бюджет всех ЛПУ на НМГ

-    total_LPU As Long ' число ЛПУ

-    total_REP   As Long ' число репов

-    total_BEDS As Long ' общее число коек

-    total_HIR As Long '  общее число пациентов на клексане в хирургии

-    total_TER As Long '  общее число пациентов на клексане в терапии

-    total_ACS As Long '  общее число пациентов на клексане в кардиологии

-    sale_PLAN As Long '  план продаж Авентиса

-End Type

-

-Function GetRGN_COMM_DATA(ByRef reg_data() As tREGION) As Integer

-    Dim q_date() As String

-    Dim q_count As Integer, i As Integer

-    

-    q_count = getAllQTRNames(q_date)

-    If q_count > 0 Then

-        ReDim reg_data(q_count)

-        For i = 1 To q_count

-            Dim current_rep_count As Integer

-            current_rep_count = getREGION_by_QTR(q_date(i), reg_data(i))

-        Next i

-    End If

-    

-    GetRGN_COMM_DATA = q_count

-End Function

-

-Function getAllQTRNames(ByRef qtr_lst() As String) As Integer

-    

-    Dim sql As String

-    Dim i As Integer

-    Dim db As Object, rs As Object

-    

-    

-    sql = "SELECT DISTINCT entry_date FROM lpu_budget"

-    i = 0

-    

-    dbOpenConnection db

-    Set rs = CreateObject("ADODB.Recordset")

-    

-    rs.Open sql, db

-        

-        If Not rs.BOF Then

-            Do While Not rs.EOF

-                i = i + 1

-                ReDim Preserve qtr_lst(i)

-                qtr_lst(i) = rs("entry_date")

-                rs.MoveNext

-            Loop

-        Else

-            getAllQTRNames = 0

-            Exit Function

-        End If

-    getAllQTRNames = i

-    dbCloseConnection db

-End Function

-

-Function getREGION_by_QTR(ent_date As String, treg As tREGION) As Integer

-    Dim rep_count As Integer

-    rep_count = 0

-    

-    Dim reps() As tREPID_COMMON

-    rep_count = Get_REP_CommonList_by_QTR(reps, ent_date)

-    

-    treg.ent_date = ent_date

-    treg.total_BDGT = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.total_BDGT_NMG = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.sale_PLAN = 0 ' quarter.sale_plan

-    treg.total_SALE = 0 'summ of

-    ' hir = (amb40+st40)*pr40 + (amb20+st20)*pr20

-    'ter (amb_clx+stat_clx)*price

-    ' acs xxx

-    'price per rep

-    treg.total_HIR = 0 'patiens clxn

-    treg.total_TER = 0 'patiens clxn

-    treg.total_ACS = 0 'patiens clxn

-    treg.total_LPU = 0 'lpu

-    treg.total_BEDS = 0 'lpu.beds

-    treg.total_REP = 0 '

-    

-    If rep_count > 0 Then

-        Dim i As Integer

-        

-        For i = 1 To UBound(reps)

-            ' current rep is reps(i)

-            With reps(i)

-                treg.total_BDGT = treg.total_BDGT + .qtrs(1).c_bdgt_NFG + .qtrs(1).c_bdgt_NMG

-                treg.total_BDGT_NMG = treg.total_BDGT_NMG + .qtrs(1).c_bdgt_NMG

-                treg.sale_PLAN = treg.sale_PLAN + .qtrs(1).c_sale_PLAN

-                treg.total_SALE = treg.total_SALE + .qtrs(1).c_sale_ALL

-                treg.total_HIR = treg.total_HIR + .qtrs(1).c_pat_HIR

-                treg.total_TER = treg.total_TER + .qtrs(1).c_pat_TER

-                treg.total_ACS = treg.total_ACS + .qtrs(1).c_pat_CRD

-                treg.total_LPU = treg.total_LPU + .qtrs(1).i_lcd

-                treg.total_BEDS = treg.total_BEDS + .qtrs(1).c_beds

-                treg.total_REP = treg.total_REP + 1

-            End With

-            

-        Next i

-        

-    End If

-    

-    getREGION_by_QTR = treg.total_REP

-End Function

-

-<<<<<<
-======================
-mRM_QTR
->>>>>>
-Attribute VB_Name = "mRM_QTR"

-Option Explicit

-

-Sub btRM_QTR_Do_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    

-    idx = Worksheets(VAR_SHEET).Range("RM_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            ImportData

-        Case 2

-            Worksheets("REP_LIST").Select

-        Case 3

-            cmExport

-    End Select

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-End Sub

-

-Sub ImportData()

-    Dim i As Integer

-    Dim def_dir As String

-    Dim flist() As String

-    

-    def_dir = GetWBPath(ThisWorkbook.FullName)

-    If GetImportDirectory(def_dir, flist) Then

-        Dim ImpMask() As String

-        ImpMask = Split(flist(1), Chr(95), Compare:=vbBinaryCompare)

-        flist(1) = ImpMask(0) & "*"

-        Dim db_list() As String

-        i = GetDBList(flist(), db_list)

-        If i > 0 Then

-            Merge_BackUp_All_Data

-            MergeGlobal db_list, GetWBPath(ThisWorkbook.FullName) & "clexane-rm.mdb"

-        End If

-    End If

-    Worksheets(RM_QTR_SHEET).update_history

-End Sub

-<<<<<<
-======================
-mImport
->>>>>>
-Attribute VB_Name = "mImport"

-    Option Explicit

-

-Const OFN_ALLOWMULTISELECT As Long = 512

-Const OFN_EXPLORER As Long = 524288

-Const OFN_HIDEREADONLY As Long = 4

-Const OFN_NONETWORKBUTTON As Long = 131072

-Const OFN_READONLY As Long = 1

-       

-Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _

-    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

-

-Private Type OPENFILENAME

-    lStructSize As Long

-    hWndOwner As Long

-    hInstance As Long

-    lpstrFilter As String

-    lpstrCustomFilter As String

-    nMaxCustFilter As Long

-    nFilterIndex As Long

-    lpstrFile As String

-    nMaxFile As Long

-    lpstrFileTitle As String

-    nMaxFileTitle As Long

-    lpstrInitialDir As String

-    lpstrTitle As String

-    flags As Long

-    nFileOffset As Integer

-    nFileExtension As Integer

-    lpstrDefExt As String

-    lCustData As Long

-    lpfnHook As Long

-    lpTemplateName As String

-End Type

-

-Function GetImportDirectory(DB_dir As String, flist() As String) As Boolean

-    Dim OpenFile As OPENFILENAME

-    Dim lReturn As Long

-    Dim sFilter As String

-    

-    OpenFile.lStructSize = Len(OpenFile)

-    '         OpenFile.hwndOwner = Form1.hWnd

-    '         OpenFile.hInstance = App.hInstance

-    sFilter = "Clexane Data Files" & Chr(0) & "mr*.mdb" & Chr(0)

-    OpenFile.lpstrFilter = sFilter

-    OpenFile.nFilterIndex = 1

-    OpenFile.lpstrFile = String(257, 0)

-    OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1

-    OpenFile.lpstrFileTitle = OpenFile.lpstrFile

-    OpenFile.nMaxFileTitle = OpenFile.nMaxFile

-    OpenFile.lpstrInitialDir = DB_dir

-    OpenFile.lpstrTitle = "Импорт данных"

-    OpenFile.flags = OFN_HIDEREADONLY + OFN_EXPLORER

-    lReturn = GetOpenFileName(OpenFile)

-    If lReturn = 0 Then

-        GetImportDirectory = False

-    Else

-        GetImportDirectory = True

-        flist = Split(OpenFile.lpstrFile, Chr(0), Compare:=vbBinaryCompare)

-        Dim i As Integer

-        i = 0

-        Do While flist(i) <> ""

-            i = i + 1

-        Loop

-        If i = 1 Then

-            flist(1) = flist(0)

-            flist(0) = GetWBPath(flist(1))

-            flist(1) = GetWBName(flist(1))

-        Else

-            flist(0) = flist(0) & "\"

-        End If

-    End If

-End Function

-<<<<<<
-Project Name : 'ClexanePM'
-Quirk - duff tag length======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-

-    Application.EnableEvents = True

-    Set MyAppEvents.app = Application

-    

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    

-    MyAppEvents.CheckWorkBooksArround ThisWorkbook

-    

-    cmSetStandaloneMode

-    

-    Application.ScreenUpdating = True

-'    CheckUser

-

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).Select

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).update_history

-    Application.Calculate

-

-End Sub

-

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    

-    Dim RestMode As Boolean

-    RestMode = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE")

-    

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-'        If RestMode Then

-            ThisWorkbook.Saved = True

-'        Else

-'            ThisWorkbook.Save

-'        End If

-    End If

-    If RestMode Then

-        xlRestoreView

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    End If

-    Application.Caption = Empty

-    Application.CommandBars(STDBAR_NAME).Reset

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-    Dim MaxX, MaxY As Integer

-    With ThisWorkbook.Worksheets(TITLE_SHEET)

-        MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-        MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-    End With

-

-    With ThisWorkbook.Application

-        .ScreenUpdating = False

-        .WindowState = xlNormal

-        .Height = MaxY

-        .Width = MaxX

-    End With

-End Sub

-

-

-

-

-

-<<<<<<
-======================
-REP_QTR
->>>>>>
-Attribute VB_Name = "REP_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CQTR_QT As Integer = 0

-Const CQTR_ID As Integer = 1

-Const CQTR_PLN As Integer = 2

-Const CQTR_FCT As Integer = 3

-Const CQTR_BDG As Integer = 4

-Const CQTR_CNT As Integer = 5

-Const CQTR_BEDS As Integer = 6

-Const CQTR_HIR As Integer = 7

-Const CQTR_TER As Integer = 8

-Const CQTR_CRD As Integer = 9

-Const CQTR_CLXN_BDG As Integer = 10

-Const CQTR_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Const LOCAL_ENT_DATE As String = "QTR_SEL"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("REP_QTR")

-        s = .Range("D5") & " " & .Range("D4") & ", " & .Range("H5") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub update_history()

-    Dim objQTR() As tQTR

-    Dim i As Long

-    Dim r As Range

-    Dim cRep As tREPID

-    Dim rm_id As Long

-

-    rm_id = Range("RM_ID")

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    Range("D4") = cRep.LastName

-    Range("D5") = cRep.FirstName

-

-    Range("H4") = GetRegionName(cRep.Region)

-    Range("H5") = GetCityName(cRep.Region, cRep.City)

-

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetAll_QTR_Records_by_REP(objQTR, "%", cRep.rep_id, rm_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CQTR_QT) = objQTR(i).entry_date

-        Next i

-    End If

-    Dim qcd() As tQTR_COMMON

-    i = Get_QTR_CommonList_by_REP(qcd, "%", cRep.rep_id, rm_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(qcd)

-            r.Offset(i - 1, CQTR_QT) = qcd(i).qtr.entry_date

-            r.Offset(i - 1, CQTR_ID) = qcd(i).qtr.id

-            r.Offset(i - 1, CQTR_PLN) = qcd(i).qtr.sale_PLAN

-            r.Offset(i - 1, CQTR_FCT) = qcd(i).c_sale_ALL

-            r.Offset(i - 1, CQTR_BDG) = qcd(i).c_bdgt_LPU

-            r.Offset(i - 1, CQTR_CNT) = qcd(i).i_lcd

-            r.Offset(i - 1, CQTR_BEDS) = qcd(i).c_beds

-            r.Offset(i - 1, CQTR_HIR) = qcd(i).c_pat_HIR

-            r.Offset(i - 1, CQTR_TER) = qcd(i).c_pat_TER

-            r.Offset(i - 1, CQTR_CRD) = qcd(i).c_pat_CRD

-            If qcd(i).c_bdgt_LPU <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_BDG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_LPU

-            End If

-            If qcd(i).c_bdgt_NMG <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_NMG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CQTR_CRD + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-

-Sub Draw_PLN_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_FCT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PLN_QTR").Range("title") = MakeChartTitle

-End Sub

-

-Sub Draw_BDGT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_CLXN_NMG + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_BDGT_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Public Sub cbxRepQtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CQTR_ID + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    i = currRange.Column - Range(CINP_AREA).Column

-

-    QTR_ID = r

-

-    If QTR_ID = 0 Then

-        Worksheets(VAR_SHEET).Range("USER_ACTION") = 1

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        If i > CQTR_FCT Then

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-            Range("LAST_FOCUS") = currRange.address

-        Else

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 3

-            Range("LAST_FOCUS") = currRange.address

-        End If

-    End If

-    Cancel = True

-    btHomeDo_IT

-End Sub

-

-<<<<<<
-======================
-mRep_QTR
->>>>>>
-Attribute VB_Name = "mRep_QTR"

-Option Explicit

-

-Sub NoFunc()

-    MsgBox "Функция не доступна", vbOKOnly, PROGRAM_NAME

-End Sub

-

-Sub DO_Price_qtr(ent_date As String)

-    Dim qtr As tQTR

-    Dim res As Integer

-    Dim cRep As tREPID

-    Dim rm_id As Long

-

-    rm_id = Worksheets(REP_QTR_SHEET).Range("RM_ID")

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    qtr = Get_QTR_Record_by_REP(ent_date, cRep.rep_id, cRep.rm_id)

-

-    If qtr.id = 0 Then

-        qtr.entry_date = ent_date

-

-        With Worksheets(VAR_SHEET)

-            qtr.ClxnH20mg = .Range("ClxnH20mg")

-            qtr.ClxnH40mg = .Range("ClxnH40mg")

-            qtr.ClxnT40mg = .Range("ClxnT40mg")

-            qtr.ClxnC_ACS = .Range("ClxnC_ACS")

-            qtr.ClxnC_IM = .Range("ClxnC_IM")

-        End With

-    End If

-

-    Dim dlg_nq As dlg_nextQTR

-    Set dlg_nq = New dlg_nextQTR

-

-    With dlg_nq

-        .tb_qtr_name = qtr.entry_date

-        .tb_bdgt_avts = qtr.sale_PLAN

-        .tb_qtr_name = qtr.entry_date

-        .tb_ClxnH20mg = qtr.ClxnH20mg

-        .tb_ClxnH40mg = qtr.ClxnH40mg

-        .tb_ClxnT40mg = qtr.ClxnT40mg

-        .tb_ClxnC_ACS = qtr.ClxnC_ACS

-        .tb_ClxnC_IM = qtr.ClxnC_IM

-    End With

-

-    dlg_nq.Show

-End Sub

-

-Sub DO_Edit_qtr(ent_date As String)

-    If ent_date = "" Then

-        NoFunc

-    Else

-        Dim rep_id As Long

-        rep_id = Worksheets(REP_QTR_SHEET).Range("REP_ID")

-        With ThisWorkbook.Worksheets("LPU_LIST")

-            .Range("VIEW_ONLY") = True

-            .setEnt_date (ent_date)

-            .Range("REP_ID") = rep_id

-            .Select

-        End With

-    End If

-End Sub

-

-Sub DO_Delete_qtr(ent_date As String)

-    If ent_date <> "" Then

-        MsgBox "Удалить данные за период [" & ent_date & "] нельзя ", vbOKOnly, PROGRAM_NAME

-    End If

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-

-Sub btHomeDo_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    idx = Worksheets(VAR_SHEET).Range("USER_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).getEnt_date()

-    Select Case idx

-        Case 1

-            NoFunc

-            ' Обновляем экран

-        Case 2

-            DO_Edit_qtr ent_date

-        Case 3

-            DO_Price_qtr ent_date

-        Case 4

-            NoFunc

-    End Select

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-Sub Delete_qtr()

-'    Dim ent_date As String

-'    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-'    DO_Delete_qtr ent_date

-End Sub

-

-Sub btREP_QTR_RET_IT()

-    Dim s As String

-    With Worksheets("REP_QTR")

-        .Range("LAST_FOCUS") = ""

-        s = .Range("ret_addr")

-        .Range("ret_addr") = ""

-    End With

-    If s <> "" Then

-        ThisWorkbook.Worksheets(s).Select

-    Else

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public ppReport As New cPPReport

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane[PM]"

-Public Const PROGRAM_VERSION As String = "Clexane[PM] ver 1.1"

-Public Const PROGRAM_FILENAME As String = "clexane-pm"

-Public Const PROGRAM_BACKUPNAME As String = "pm-backup-"

-Public Const PROGRAM_EXPORTNAME As String = "pm-ex-"

-Public Const PROGRAM_IMPORTNAME As String = "rm-ex*"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-Public Const CHART_DEF_TITLE As String = "* * *"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20031207

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "O41"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-Public Const RM_QTR_SHEET As String = "RM_QTR"

-Public Const PRJ_QTR_SHEET As String = "PRJ_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-Function time_correct(end_date As Long, ByVal theDate As Date) As Boolean

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-    If end_date = NO_ESTIMATION_DATE Then

-        time_correct = True

-        Exit Function

-    End If

-    

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    

-    time_correct = CurDate <= end_date

-    

-End Function

-

-Sub EnableRun(end_date As Long)

-    If Not time_correct(end_date, Now) Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-Sub t()

-    EnableRun ESTIMATION_DATE

-End Sub

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Sub OpenPPT()

-    ppReport.ReportView

-End Sub

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-

-End Sub

-

-Function Double2Str(ByVal d As Double, ByVal precision As Integer, Optional Delim As String = ".") As String

-    Dim s As String

-    If Not precision > 0 Then

-        s = Round(d)

-    Else

-        Dim i As Integer

-        i = Fix(d)

-        s = i & Delim

-        d = Abs(d - i)

-        Do

-            precision = precision - 1

-            d = d * 10

-            If precision > 0 Then

-                i = Fix(d)

-            Else

-                i = Round(d)

-            End If

-            If i < 1 Then

-                s = s & "0"

-            Else

-                s = s & i

-                d = d - i

-            End If

-        Loop While precision > 0

-    End If

-    Double2Str = s

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetWBName(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBName = Right(FullName, s_len - pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.Name = VAR_SHEET Or sh.Name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-<<<<<<
-======================
-Var
->>>>>>
-Attribute VB_Name = "Var"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-title
->>>>>>
-Attribute VB_Name = "title"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LPU_LIST
->>>>>>
-Attribute VB_Name = "LPU_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Const LOCAL_ENT_DATE As String = "C10"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Function getCurrentLPU_ID() As Long

-    Dim r As Range

-

-    With Worksheets("LPU_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CLPU_ID)

-    End With

-

-    getCurrentLPU_ID = r

-End Function

-

-Public Sub LPU_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectLPU_NAME(lpu_id As Long, ent_date As String)

-    SelectLPU_BDGT lpu_id, ent_date

-End Sub

-

-Sub SelectLPU_BDGT(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    If lpu_id = 0 Then

-        SelectLPU_NAME lpu_id, ent_date

-    Else

-        With ThisWorkbook.Worksheets("LPU_BDGT")

-            .Range("VIEW_ONLY") = vo

-            .Range("ret_addr") = "LPU_LIST"

-            .setEnt_date (ent_date)

-            .Range("lpu_id") = lpu_id

-            .Range("REP_ID") = rep_id

-            .Range("RM_ID") = rm_id

-        End With

-    End If

-End Sub

-

-Sub SelectLPU_HIR(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_HIR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .setEnt_date (ent_date)

-        .Range("lpu_id") = lpu_id

-        .Range("REP_ID") = rep_id

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Sub SelectLPU_TER(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_TER")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .setEnt_date (ent_date)

-        .Range("lpu_id") = lpu_id

-        .Range("REP_ID") = rep_id

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Sub SelectLPU_C_ACS(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_C_ACS")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .setEnt_date (ent_date)

-        .Range("RM_ID") = rm_id

-        .Range("REP_ID") = rep_id

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateLPUList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim lpu_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CINP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CINP_AREA).row, CLPU_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    lpu_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CINP_AREA).Column

-

-    If lpu_id = 0 Then

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    End If

-

-    If lpu_id = 0 Then

-        i = CLPU_NAME

-        Range("JUMP") = ""

-    End If

-    Select Case i

-        Case CLPU_NAME, CLPU_NAME1, CLPU_NAME2, CLPU_BEDS

-            SelectLPU_NAME lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-

-        Case CLPU_NMG, CLPU_NFG, CLPU_PLAN, CLPU_FACT

-            SelectLPU_BDGT lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-

-        Case CLPU_HIR

-            SelectLPU_HIR lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_HIR"

-

-        Case CLPU_TER

-            SelectLPU_TER lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_TER"

-

-        Case CLPU_CAR

-            SelectLPU_C_ACS lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        Case Else

-            Range("JUMP") = ""

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateLPUList()

-    Dim lcd() As tLPU_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-    Dim objQTR As tQTR

-    Dim cRep As tREPID

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    ent_date = getEnt_date

-

-'     ent_date = "%" ' % - all records

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id, cRep.rm_id)

-    i = Get_LPU_CommonQTR(lcd, objQTR)

-

-'     стираем ФИО

-    Range("C3:C4").ClearContents

-

-    Range("C3") = cRep.LastName

-    Range("C4") = cRep.FirstName

-    Range("G3") = GetRegionName(cRep.Region)

-    Range("G4") = GetCityName(cRep.Region, cRep.City)

-    Range("G5") = objQTR.sale_PLAN

-

-

-

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(lcd)

-            r.Offset(i - 1, CLPU_NAME) = lcd(i).lpu.Name

-            r.Offset(i - 1, CLPU_ID) = lcd(i).lpu.id

-            r.Offset(i - 1, CLPU_BEDS) = lcd(i).lpu.beds

-

-

-            r.Offset(i - 1, CLPU_NFG) = lcd(i).bdgt.bdgt_NFG

-            r.Offset(i - 1, CLPU_NMG) = lcd(i).bdgt.bdgt_NMG

-            r.Offset(i - 1, CLPU_PLAN) = lcd(i).bdgt.sale_PLAN

-

-            r.Offset(i - 1, CLPU_HIR) = lcd(i).pat_HIR

-            r.Offset(i - 1, CLPU_TER) = lcd(i).pat_TER

-            r.Offset(i - 1, CLPU_CAR) = lcd(i).pat_CRD

-            r.Offset(i - 1, CLPU_FACT) = lcd(i).sale_ALL

-            r.Offset(i - 1, CLPU_PAT_LPU) = lcd(i).pat_LPU

-            r.Offset(i - 1, CLPU_BDGT) = lcd(i).bdgt_LPU

-            If lcd(i).bdgt_LPU > 0 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = lcd(i).sale_ALL / lcd(i).bdgt_LPU

-            End If

-            If r.Offset(i - 1, CLPU_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{32FB0F3D-6884-41DC-99DB-E2C55B2257C4}{DED79A66-DA60-4CCC-9003-082480235D55}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-dbACS
->>>>>>
-Attribute VB_Name = "dbACS"

-Option Explicit

-

-Public Type tACS

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    patients_with_geparins As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objACS.ID <> 0 then updatre else insert

-Sub Insert_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objACS.id <> 0 Then

-        dbUpdate_ACS_Record dbConnection, objACS

-    Else

-        dbInsert_ACS_Record dbConnection, objACS

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_ACS_RecordsByLPU_ID(ByRef all_ACS_() As tACS, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_ACS_RecordsByLPU_ID = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, all_ACS_, lpu_id, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_ACS_Record dbConnection, objACS

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub dbInsert_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_acs", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objACS

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("patients_with_geparins") = .patients_with_geparins

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objACS.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim Update_SQL As String

-    

-    With objACS

-        Update_SQL = "UPDATE lpu_acs SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "patients_with_geparins=" & .patients_with_geparins & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_ACS_RecordsbyLPU_ID(dbConnection As Object, all_ACS() As tACS, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_ACS_SQL As String

-    Dim getAll_ACS_SQL As String

-    Dim ACS_Count As Long

-    ACS_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    Else

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_ACS_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        ACS_Count = dbRecordset("ACS_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_ACS_RecordsbyLPU_ID = ACS_Count

-    

-    If ACS_Count > 0 Then

-        'we have records

-        ReDim all_ACS(1 To ACS_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_ACS_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_ACS As tACS

-                 With tmp_ACS

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .patients_with_geparins = dbRecordset("patients_with_geparins")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 all_ACS(index) = tmp_ACS

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE ID=" & objACS.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_ACS_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_HIR
->>>>>>
-Attribute VB_Name = "LPU_CLSN_HIR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const LOCAL_ENT_DATE As String = "S38"

-

-Sub PrintCopy()

-    Range("A1:M26").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-

-        Dim objHir As tHIRURGIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objHir

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .operations_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L9")

-                .patients_ambulator_clexan_20mg = Range("L10")

-                .patients_ambulator_clexan_40mg = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L19")

-                .patients_stationar_clexan_20mg = Range("L20")

-                .patients_stationar_clexan_40mg = Range("L21")

-            End With

-            Insert_Hir_Record objHir

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objHir.id = Range("rec_id")

-                    If objHir.id <> 0 Then

-                        Delete_Hir_Record objHir

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-End Sub

-

-Sub SetupData(objHir As tHIRURGIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    With objHir

-        Range("rec_id") = .id

-        Range("F6") = .operations_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L9") = .patients_ambulator_clexan

-        Range("L10") = .patients_ambulator_clexan_20mg

-        Range("I21") = .patients_stationar_nmg

-        Range("L19") = .patients_stationar_clexan

-        Range("L20") = .patients_stationar_clexan_20mg

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id, cRep.rm_id)

-

-        formula = "=" & qtr.ClxnH20mg & "*($L$10+$L$20)+" & qtr.ClxnH40mg & "*($L$11+$L$21)"

-        Range("F11").formula = formula

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id, Range("RM_ID"))

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.Name

-        Range("lpu_addr") = lpu.address

-

-        Dim objHir() As tHIRURGIA

-        Dim i As Integer

-        i = GetAll_Hir_RecordsByLPU_ID(objHir, id, Range("ent_date"), Range("RM_ID"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.3

-        Else

-            SetupData objHir(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-mSapes
->>>>>>
-Attribute VB_Name = "mSapes"

-Option Explicit

-

-Const SHAPE_COLOR As Integer = 1

-Const SHAPE_NAME As Integer = 2

-

-

-Sub ShapeView(r_sh_finite_state As Range)

-    Dim chk As Range

-    Dim s As String

-    Dim c, idx As Integer

-    For Each chk In r_sh_finite_state

-        idx = 0

-        If chk = "+" Then

-            c = chk.Offset(0, idx + SHAPE_COLOR)

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While c <> 0

-                ShapeFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s)), c

-                idx = idx + 2

-                c = chk.Offset(0, idx + SHAPE_COLOR)

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        Else

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While s <> ""

-                ShapeUnFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s))

-                idx = idx + 2

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        End If

-    Next chk

-End Sub

-

-Sub ShapeFill(sh As ShapeRange, ByVal color As Integer)

-    sh.Fill.Visible = msoTrue

-    sh.Fill.Solid

-    sh.Fill.ForeColor.SchemeColor = color

-    sh.Fill.Transparency = 0#

-End Sub

-

-Sub ShapeUnFill(sh As ShapeRange)

-    sh.Fill.Visible = msoFalse

-    sh.Fill.Transparency = 0#

-End Sub

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Public Const INPUT_NO = 0

-Public Const INPUT_NUMBER = 1

-Public Const INPUT_PERCENT = 2

-Public Const INPUT_STRING = 3

-Public Const INPUT_CHECK = 4

-

-Public Const INP_IDX_TYPE = 1

-Public Const INP_IDX_NEXT = 2

-Public Const INP_IDX_MIN = 3

-Public Const INP_IDX_MAX = 4

-Public Const INP_IDX_DEP = 5

-Public Const INP_IDX_ALT = 7

-

-

-Public Type tInputSet

-    vType As Integer

-    vMin As Long

-    vMax As Long

-    rChk As String

-End Type

-

-Function is_input_cell(ByVal Target As Range, inputs As Range) As tInputSet

-    Dim t As Range

-    Dim iset As tInputSet

-    Dim test As Range

-    iset.vType = INPUT_NO

-    iset.vMin = 0

-    iset.vMax = 0

-    iset.rChk = ""

-    is_input_cell = iset

-

-' Закоментировать следующую сточку для работы

-'  Exit Function

-

-    Set test = Target.Cells(1, 1)

-    For Each t In inputs

-        If Range(t).Column = test.Column And Range(t).row = test.row Then

-            iset.vType = t.Offset(0, INP_IDX_TYPE).Value

-            Select Case iset.vType

-                Case INPUT_CHECK

-                    iset.rChk = t.Offset(0, INP_IDX_ALT)

-                Case INPUT_NUMBER, INPUT_PERCENT

-                    iset.vMin = t.Offset(0, INP_IDX_MIN).Value

-                    iset.vMax = t.Offset(0, INP_IDX_MAX).Value

-            End Select

-            is_input_cell = iset

-            Exit Function

-        End If

-    Next t

-End Function

-

-Function GetFocusAddress(ByVal r As Range, f_next As Range) As String

-    Dim chk, t As Range

-    

-    For Each chk In f_next

-        For Each t In r

-            If t.address = chk Then

-                GetFocusAddress = chk

-                Exit Function

-            End If

-            If Range(chk).Column = t.Column - 1 And Range(chk).row = t.row _

-            Or Range(chk).Column = t.Column And Range(chk).row = t.row - 1 _

-            Then

-                If Range(chk) <> "" Then

-                    If Range(chk) = 0 Then

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_ALT)).address

-                    Else

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_NEXT)).address

-                    End If

-                Else

-                    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-                End If

-                Exit Function

-            End If

-        Next t

-    Next chk

-    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-End Function

-

-Sub SetDependet(r As Range, inputs As Range)

-    Dim chk As Range

-    Dim s, serr As String

-    Dim idx As Integer

-    Dim iset As tInputSet

-    Dim err_found As Boolean

-    

-    If r.count > 1 Then

-        Exit Sub

-    End If

-    

-    err_found = False

-    For Each chk In inputs

-        idx = INP_IDX_DEP

-        

-        

-        iset.vType = chk.Offset(0, INP_IDX_TYPE).Value

-        Select Case iset.vType

-            Case INPUT_NUMBER, INPUT_PERCENT

-                iset.vMin = chk.Offset(0, INP_IDX_MIN).Value

-                iset.vMax = chk.Offset(0, INP_IDX_MAX).Value

-                

-                If Range(chk) > iset.vMax Then

-                    err_found = True

-                    Range(chk) = iset.vMax

-                    serr = "Выход за дозволенный диапазон [" & iset.vMin & ".." & iset.vMax & "]! Данные скорректированы."

-                End If

-                

-                If Range(chk) = "" Then

-                    s = chk.Offset(0, idx)

-                    Do While s <> ""

-                        Range(s) = ""

-                        idx = idx + 1

-                        s = chk.Offset(0, idx)

-                    Loop

-                End If

-        End Select

-    Next chk

-    If err_found Then

-        MsgBox serr, vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Function CheckInputData(inputs As Range) As Boolean

-    Dim r As Range

-    

-    CheckInputData = True

-    For Each r In inputs

-        If Range(r) = "" Then

-            CheckInputData = False

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100.", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Sub Check_Int_Number(Target As Range, Def_Val As Long)

-    Dim err As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    err = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                err = True

-            End If

-        End If

-    Next r

-    If err Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_TER
->>>>>>
-Attribute VB_Name = "LPU_CLSN_TER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const LOCAL_ENT_DATE As String = "S38"

-

-Sub PrintCopy()

-    Range("A1:M26").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim objTer As tTERAPIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objTer

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .patients_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L20")

-            End With

-            Insert_Ter_Record objTer

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objTer.id = Range("rec_id")

-                    If objTer.id <> 0 Then

-                        Delete_Ter_Record objTer

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-

-End Sub

-

-Sub SetupData(objTer As tTERAPIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    With objTer

-        Range("rec_id") = .id

-        Range("F6") = .patients_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L11") = .patients_ambulator_clexan

-        Range("I21") = .patients_stationar_nmg

-        Range("L20") = .patients_stationar_clexan

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id, cRep.rm_id)

-        formula = "=" & qtr.ClxnT40mg & "*($L$12+$L$20)"

-        Range("F11").formula = formula

-

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id, Range("RM_ID"))

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.Name

-        Range("lpu_addr") = lpu.address

-

-        Dim objTer() As tTERAPIA

-        Dim i As Integer

-        i = GetAll_Ter_RecordsByLPU_ID(objTer, id, Range("ent_date"), Range("RM_ID"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.25

-        Else

-            SetupData objTer(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{0DC9E035-CE0A-49FF-85A2-A4EC5FF8FE96}{D54DDC8A-1EE2-4BB3-8B94-343B521AF098}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-LPU_BDGT
->>>>>>
-Attribute VB_Name = "LPU_BDGT"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const LOCAL_ENT_DATE As String = "S15"

-

-Sub PrintCopy()

-    Range("B1:K21").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Sub SetDefFocus()

-    Range(Range("DEF_FOCUS")).Select

-End Sub

-

-Public Sub ClearData()

-    ClearSheetData

-End Sub

-

-Sub ClearSheetData()

-    If Range("F10") = 0 And Range("F13") = 0 Then

-        Range("F11:F18") = ""

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("F11:F13") = ""

-    End If

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim bdgt As tBUDGET

-        Dim sum As Long

-        Dim test As Boolean

-        With bdgt

-            .lpu_id = Range("lpu_id")

-            .id = Range("rec_id")

-            .entry_date = Range("ent_date")

-            .bdgt_NMG = Round(Range("F11").Value, 0)

-            .bdgt_NFG = Round(Range("F12").Value, 0)

-            .sale_PLAN = Round(Range("F13").Value, 0)

-

-            sum = .bdgt_NFG + .bdgt_NMG - .sale_PLAN

-            test = .bdgt_NFG <> 0 Or .bdgt_NMG <> 0 Or .sale_PLAN <> 0

-        End With

-        If test Then

-            If sum < 0 Then

-                MsgBox _

-                    "Ваш план превышает выделенный на гепарины бюджет. Сохранить данные?", _

-                    vbOKOnly, PROGRAM_NAME

-            End If

-            If test Then

-                Insert_BDGT_Record bdgt

-            End If

-        Else

-            If bdgt.id <> 0 Then

-                If vbYes = MsgBox("Удалить данные из базы!", vbYesNo, PROGRAM_NAME) Then

-                    Delete_BDGT_Record bdgt

-                End If

-                ret_back Range("DEF_FOCUS").Worksheet

-                Exit Sub

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-    End If

-

-   ClearData

-   ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(cLPU As tLPU_COMMON)

-    Dim t_sum As Long

-    t_sum = 0

-' Setup budget data

-    Range("F11") = cLPU.bdgt.bdgt_NMG

-    Range("F12") = cLPU.bdgt.bdgt_NFG

-    Range("F13") = cLPU.bdgt.sale_PLAN

-

-    With cLPU

-        Range("F14") = .pat_ALL

-        Range("F15") = .pat_HIR

-        Range("F16") = .pat_TER

-        Range("F17") = .pat_CRD

-        Range("F18") = .sale_ALL

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    ws_activate

-End Sub

-

-

-Sub ws_activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Dim cLPU As tLPU_COMMON

-    Dim objQTR As tQTR

-    Dim objLPU As tLPU

-    Dim ent_date As String

-    Dim id As Long

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"), Range("RM_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    id = Range("lpu_id").Value

-    ent_date = Range("ent_date")

-    

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id, cRep.rm_id)

-

-    objLPU = Get_LPU_Record(id, Range("RM_ID"))

-    Get_LPU_Common cLPU, objLPU, objQTR

-

-    If cLPU.lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = cLPU.lpu.beds

-        Range("lpu_name") = cLPU.lpu.Name

-        Range("lpu_addr") = cLPU.lpu.address

-        Range("rec_id") = cLPU.bdgt.id

-

-        SetupData cLPU

-

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-'    MsgBox Target.address

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case INPUT_CHECK

-

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{BFB4547C-96A7-4739-AA0A-CEF1E35E2BDC}{C3D618A3-9410-4BC7-9D93-3B049D361132}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mSheets
->>>>>>
-Attribute VB_Name = "mSheets"

-Option Explicit

-

-Function am_load_now() As Boolean

-    am_load_now = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE")

-End Function

-

-Sub Wks_select(RetSheet As String)

-    Dim sheet As Worksheet

-    For Each sheet In ThisWorkbook.Worksheets

-        If sheet.Name = RetSheet Then

-            ThisWorkbook.Worksheets(RetSheet).Select

-            Exit Sub

-        End If

-    Next sheet

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub ret_back(sh As Worksheet)

-    Dim RetSheet As String

-    RetSheet = sh.Range("ret_addr")

-    sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    sh.Range("rec_id") = ""

-    sh.Range("lpu_id") = ""

-    sh.Range("ent_date") = ""

-    sh.Range("lpu_name") = ""

-    sh.Range("lpu_addr") = ""

-    sh.Range("lpu_beds") = ""

-    Wks_select RetSheet

-    sh.Range("ret_addr") = ""

-End Sub

-

-Sub ClearSheetData(r_start As Range)

-    If r_start <> "" Then

-        r_start.Worksheet.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        r_start = ""

-    Else

-        ret_back r_start.Worksheet

-    End If

-End Sub

-

-Sub wks_sel_chng(iset As tInputSet, ByVal Target As Range, sh As Worksheet)

-    Dim DebugMode As Boolean

-    Dim in_range As Range

-    

-    DebugMode = Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-

-    If DebugMode Then

-        sh.Unprotect

-    Else

-        sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    End If

-

-    If iset.vType = INPUT_CHECK Then

-        Set in_range = Target.Worksheet.Range(iset.rChk)

-    Else

-        Set in_range = Target

-    End If

-    

-    Dim str As String

-    str = GetFocusAddress(in_range, sh.Range("h_inputs"))

-

-'    MsgBox Target.Address & "; " & str

-    If str <> Target.address Then

-        sh.Range(str).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-Dlg_lpu_card
->>>>>>
-Attribute VB_Name = "Dlg_lpu_card"

-Attribute VB_Base = "0{9AAD262F-A6C4-4912-9C58-D7A2071181B8}{9470F4EB-DA9F-4584-9159-D09319548D21}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbLPU_List_Change()

-    Dim src As Range

-    Dim idx_src As Integer

-    

-    Set src = Worksheets(VAR_SHEET).Range(Me.cbLPU_List.RowSource)

-    idx_src = Me.cbLPU_List.ListIndex + 1

-    Me.tb_lpu_name.Text = src.Cells(idx_src, 1)

-    Me.tb_lpu_address.Text = src.Cells(idx_src, 2)

-    Me.tbBedsCount.Text = src.Cells(idx_src, 3)

-End Sub

-

-

-Private Sub cbxLPU_List_Enable_Click()

-    

-    If Me.cbxLPU_List_Enable Then

-        

-        Me.tb_lpu_name.Text = ""

-        Me.tb_lpu_name.Enabled = False

-        

-        Me.tb_lpu_address.Text = ""

-        Me.tb_lpu_address.Enabled = False

-        

-        Me.tbBedsCount.Text = ""

-        Me.tbBedsCount.Enabled = False

-        

-        Me.cbLPU_List.Enabled = True

-        cbLPU_List_Change

-    Else

-        Me.tb_lpu_name.Enabled = True

-        Me.tb_lpu_name.Text = ""

-        

-        Me.tb_lpu_address.Enabled = True

-        Me.tb_lpu_address.Text = ""

-        

-        Me.tbBedsCount.Enabled = True

-        Me.tbBedsCount.Text = ""

-        

-        Me.cbLPU_List.Enabled = False

-    End If

-End Sub

-

-<<<<<<
-======================
-UserInfo
->>>>>>
-Attribute VB_Name = "UserInfo"

-Attribute VB_Base = "0{A8FBEE9C-DE59-49DE-971D-07BC9C0E9BD2}{C712732B-D8E4-4C2D-8E78-AC90968E0CD7}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Tag = vbOK

-End Sub

-

-Private Sub cbCity_Change()

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_CITY") = Me.cbCity.ListIndex

-        .Calculate

-    End With

-End Sub

-

-Private Sub cbRegion_Change()

-    Dim LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        NewRangeOffsetCol = cbRegion.Value * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .Name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).address

-        NewSumRange = .Name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).address

-        .Calculate

-        .Range("IDX_CITY") = 0

-        cbCity.RowSource = NewCbxRange

-

-    End With

-    cbCity.ListIndex = 0

-End Sub

-

-<<<<<<
-======================
-mREGMAN
->>>>>>
-Attribute VB_Name = "mREGMAN"

-Option Explicit

-

-Sub hw_reset()

-    Dim rs As Range

-    Dim re As Object

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    HWReset

-    With Application

-        .DisplayAlerts = False

-        .Quit

-    End With

-End Sub

-

-Sub CheckUser()

-    If Range("HW_Number") = "" Then

-        StoreHWInfo

-    End If

-    If CheckHWInfo <> True Then

-        MsgBox "2"

-        cmAbout

-'        With Application

-'            .DisplayAlerts = False

-'            .Quit

-'        End With

-    Else

-        SetupUser

-    End If

-End Sub

-

-

-Sub SetupUser()

-'    Dim cREGMAN As tREGMAN

-'    Dim idx As Integer

-'    Dim dlg_ui As UserInfo

-'

-'    Set dlg_ui = New UserInfo

-'

-'    cREGMAN = Get_REGMAN_Record()

-'

-'    With ThisWorkbook.Worksheets(REGS_SHEET)

-'        .Range("IDX_REGION") = cREGMAN.Region

-'        .Range("IDX_CITY") = cREGMAN.City

-'    End With

-'

-'    With dlg_ui

-'        .cbRegion = cREGMAN.Region

-'        .cbCity = cREGMAN.City

-'        .tbFName = cREGMAN.FirstName

-'        .tbLName = cREGMAN.LastName

-'    End With

-'

-'    dlg_ui.Show

-'    Worksheets(REGS_SHEET).Calculate

-'

-'    If dlg_ui.Tag = vbOK Then

-'        With cREGMAN

-'            .Region = dlg_ui.cbRegion.Value

-'            .City = dlg_ui.cbCity.Value

-'            .FirstName = dlg_ui.tbFName.Value

-'            .LastName = dlg_ui.tbLName.Value

-'        End With

-'        Set_REGMAN_Record cREGMAN

-'    Else

-'        cmAbout

-'        With Application

-'            .DisplayAlerts = False

-'            .Quit

-'        End With

-'    End If

-End Sub

-

-Sub StoreHWInfo()

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim objHW() As Long

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    Set r = Range("HW_Number")

-    i = 1

-    For Each d In dc

-        If d.drivetype = 2 Then

-            r = d.SerialNumber

-            Set r = r.Offset(1, 0)

-            ReDim Preserve objHW(i)

-            objHW(i) = d.SerialNumber

-            i = i + 1

-        End If

-    Next

-    

-    UpdateHWRecords objHW

-End Sub

-

-Function CheckHWInfo()

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim objHW() As Long

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    

-    CheckHWInfo = False

-    

-    i = GetHWRecords(objHW)

-    If i = 0 And Range("HW_Number") <> 0 Then

-        Exit Function

-    End If

-    For Each d In dc

-        If d.drivetype = 2 Then

-            Set r = Range("HW_Number")

-            Do While r <> ""

-                If r = d.SerialNumber Then

-                    For i = 1 To UBound(objHW)

-                        If d.SerialNumber = objHW(i) Then

-                            CheckHWInfo = True

-                            Exit Function

-                        End If

-                    Next i

-                End If

-                Set r = r.Offset(1, 0)

-            Loop

-        End If

-    Next

-End Function

-<<<<<<
-======================
-dbBudget
->>>>>>
-Attribute VB_Name = "dbBudget"

-Option Explicit

-

-Public Type tBUDGET

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    rm_id As Long

-    bdgt_NMG As Long

-    bdgt_NFG As Long

-    sale_PLAN As Long

-End Type

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function GetAll_BDGT_RecordsByLPU_ID(ByRef allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_BDGT_RecordsByLPU_ID = dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection, allBDGT, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function Get_BDGT_Record(ByVal lpu_id As Long, ByVal ent_date As String, rm_id As Long) As tBUDGET

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    Get_BDGT_Record = dbGet_BDGT_Record(dbConnection, lpu_id, ent_date, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-' if objBDGT.ID <> 0 then updatre else insert

-Public Sub Insert_BDGT_Record(objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    If objBDGT.id <> 0 Then

-        dbUpdate_BDGT_Record dbConnection, objBDGT

-    Else

-        dbInsert_BDGT_Record dbConnection, objBDGT

-    End If

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Public Sub Delete_BDGT_Record(ByRef objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    dbDelete_BDGT_Record dbConnection, objBDGT

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_BDGT_Record(dbConnection As Object, ByVal lpu_id As Long, ent_date As String, rm_id As Long) As tBUDGET

-    

-    Dim sql As String

-    Dim objBDGT As tBUDGET

-    

-    With objBDGT

-        .id = 0

-        .lpu_id = lpu_id

-        .rm_id = rm_id

-        .entry_date = ent_date

-        .bdgt_NMG = 0

-        .bdgt_NFG = 0

-        .sale_PLAN = 0

-    End With

-        

-    

-    sql = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        With objBDGT

-            .entry_date = dbRecordset("entry_date")

-            .id = dbRecordset("id")

-            .lpu_id = dbRecordset("lpu_id")

-            .bdgt_NFG = dbRecordset("bdgt_NFG")

-            .bdgt_NMG = dbRecordset("bdgt_NMG")

-            .sale_PLAN = dbRecordset("sale_PLAN")

-        End With

-    End If

-    

-    dbGet_BDGT_Record = objBDGT

-End Function

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection As Object, allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_BDGT_SQL As String

-    Dim getAll_BDGT_SQL As String

-    Dim BDGT_Count As Long

-    BDGT_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_BDGT_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        BDGT_Count = dbRecordset("BDGT_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_BDGT_RecordsbyLPU_ID = BDGT_Count

-    

-    If BDGT_Count > 0 Then

-        'we have records

-        ReDim allBDGT(1 To BDGT_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_BDGT_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpBDGT As tBUDGET

-                 With tmpBDGT

-                    .entry_date = dbRecordset("entry_date")

-                    .id = dbRecordset("id")

-                    .lpu_id = dbRecordset("lpu_id")

-                    .bdgt_NFG = dbRecordset("bdgt_NFG")

-                    .bdgt_NMG = dbRecordset("bdgt_NMG")

-                    .sale_PLAN = dbRecordset("sale_PLAN")

-                 End With

-                 

-                 allBDGT(index) = tmpBDGT

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbInsert_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "lpu_budget", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    dbRecordset("entry_date") = objBDGT.entry_date

-    dbRecordset("lpu_id") = objBDGT.lpu_id

-    dbRecordset("bdgt_NMG") = objBDGT.bdgt_NMG

-    dbRecordset("bdgt_NFG") = objBDGT.bdgt_NFG

-    dbRecordset("sale_PLAN") = objBDGT.sale_PLAN

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objBDGT.id = dbRecordset("id")

-  

-End Sub

-

-Public Sub dbUpdate_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu_budget SET " & _

-    "entry_date='" & objBDGT.entry_date & "'," & _

-    "lpu_id=" & objBDGT.lpu_id & "," & _

-    "bdgt_NMG=" & objBDGT.bdgt_NMG & "," & _

-    "bdgt_NFG=" & objBDGT.bdgt_NFG & "," & _

-    "sale_PLAN=" & objBDGT.sale_PLAN & _

-    " WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-Public Sub dbDelete_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_BDGT_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbDatabase
->>>>>>
-Attribute VB_Name = "dbDatabase"

-Option Explicit

-

-

-Sub dbOpenConnection(dbConnection As Object)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-<<<<<<
-======================
-dbLPU
->>>>>>
-Attribute VB_Name = "dbLPU"

-Option Explicit

-

-Public Type tLPU

-    id As Long

-    rep_id As Long

-    rm_id As Long

-    Name As String

-    address As String

-    beds As Integer

-End Type

-

-Function Get_LPU_Record(ByVal lpu_id As Long, rm_id As Long) As tLPU

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_LPU_Record = dbGet_LPU_Record(dbConnection, lpu_id, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_LPU_byQTR(allLPU() As tLPU, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_LPU_byQTR = dbGetAll_LPU_byQTR(dbConnection, allLPU, ent_date, rep_id, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_Record(dbConnection As Object, ByVal lpu_id As Long, rm_id As Long) As tLPU

-    

-    Dim sql As String

-    Dim objLPU As tLPU

-    

-    objLPU.id = lpu_id

-    objLPU.Name = ""

-    objLPU.address = ""

-    

-    sql = "SELECT * FROM lpu WHERE id=" & lpu_id & " AND rm_id=" & rm_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objLPU.Name = dbRecordset("name")

-        objLPU.address = dbRecordset("address")

-        objLPU.rep_id = dbRecordset("rep_id")

-        objLPU.rm_id = dbRecordset("rm_id")

-        objLPU.beds = dbRecordset("beds")

-    End If

-    

-    dbGet_LPU_Record = objLPU

-

-End Function

-

-Function dbGetAll_LPU_byQTR(dbConnection As Object, allLPU() As tLPU, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    Dim Where As String

-    Where = "WHERE lpu_budget.entry_date like '" & ent_date & "'" & " AND lpu.id=lpu_budget.lpu_id " & _

-    "AND lpu.rep_id=" & rep_id & " AND lpu.rm_id=lpu_budget.rm_id AND lpu.rm_id=" & rm_id

-

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu_budget, lpu " & Where

-    

-    getAll_LPU_SQL = "SELECT lpu.id as id, lpu.rep_id as rep_id, lpu.name as name, lpu.address as address, lpu.beds AS beds, lpu.rm_id AS rm_id " & _

-    "FROM lpu, lpu_budget " & Where

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_LPU_byQTR = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .Name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-dbREP
->>>>>>
-Attribute VB_Name = "dbREP"

-'Option Explicit

-'

-'Public Type tREP

-'    FirstName As String

-'    LastName As String

-'    Region As Integer

-'    City As Integer

-'End Type

-'

-'Function GetREPRecord() As tREP

-'    Dim dbConnection As Object

-'

-'    dbOpenConnection dbConnection

-'    GetREPRecord = dbGetREPRecord(dbConnection)

-'    dbCloseConnection dbConnection

-'End Function

-'

-'Sub SetREPRecord(cUser As tREP)

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbSetREPRecord dbConnection, cUser

-'    dbCloseConnection dbConnection

-'End Sub

-'

-'Public Function dbGetREPRecord(dbConnection As Object) As tREP

-'

-'    Dim SQL As String

-'    Dim objREP As tREP

-'

-'    objREP.FirstName = ""

-'    objREP.LastName = ""

-'    objREP.Region = 0

-'    objREP.City = 0

-'    SQL = "SELECT firstname, lastname, region, city FROM " & _

-'          "rep"

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open SQL, dbConnection

-'    ', 3, 3

-'    If Not dbRecordset.BOF Then

-'

-'        objREP.FirstName = dbRecordset("firstname")

-'        objREP.LastName = dbRecordset("lastname")

-'        objREP.Region = dbRecordset("region")

-'        objREP.City = dbRecordset("city")

-'

-'    End If

-'

-'    dbGetREPRecord = objREP

-'

-'End Function

-'

-'Public Sub dbSetREPRecord(dbConnection As Object, ByRef objREP As tREP)

-'

-'    Dim DeleteSQL As String

-'    Dim InsertSQL As String

-'

-'    DeleteSQL = "DELETE FROM rep"

-'    InsertSQL = "INSERT INTO rep (firstname, lastname, region, city) VALUES (" & _

-'    "'" & objREP.FirstName & "', " & _

-'    "'" & objREP.LastName & "', " & _

-'    objREP.Region & ", " & _

-'    objREP.City & ")"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-'

-'End Sub

-'

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    CheckWorkBooksArround Wb

-End Sub

-

-

-Sub CheckWorkBooksArround(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If app.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEL сейчас будут закрыты!", vbOKOnly, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub GetState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-        ActiveWorkbook.DisplayDrawingObjects = xlDisplayShapes

-        

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.Name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars(STDBAR_NAME).Visible = False

-End Sub

-

-

-Public Sub RestoreState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars(STDBAR_NAME).Visible = True

-End Sub

-

-

-

-<<<<<<
-======================
-cdbRM
->>>>>>
-Attribute VB_Name = "cdbRM"

-Option Explicit

-

-Public Type tRMID_COMMON

-    rm As tREGMAN

-    rgcd_count As Integer

-    rgcd() As tREGION

-End Type

-

-Function Get_RM_CommonList_by_QTR(ByRef rmcd() As tRMID_COMMON, ent_date As String) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_RM_CommonList_by_QTR = dbGet_RM_CommonList_by_QTR(dbConnection, rmcd(), ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_RM_CommonList_by_QTR(dbConnection As Object, ByRef rmcd() As tRMID_COMMON, ent_date As String) As Integer

-    ' Получить список RM-ов

-    Dim count As Integer

-    count = db_get_All_RM_by_QTR(dbConnection, rmcd(), ent_date)

-    

-    Dim i As Integer

-    For i = 1 To count

-        rmcd(i).rgcd_count = 1

-        ReDim rmcd(i).rgcd(1 To 1)

-        getREGION_by_QTR ent_date, rmcd(i).rgcd(1), rmcd(i).rm.rm_id

-    Next i

-    dbGet_RM_CommonList_by_QTR = count

-End Function

-

-Function db_get_All_RM_by_QTR(dbConnection As Object, rmcd() As tRMID_COMMON, ent_date As String) As Integer

-    

-    Dim count_sql As String

-    Dim get_sql As String

-    Dim rs As Object

-    Dim RM_Count As Integer

-        

-    count_sql = "SELECT COUNT(*) AS RM_TOTAL FROM reg_man"

-    get_sql = "SELECT * FROM reg_man"

-    Set rs = CreateObject("ADODB.Recordset")

-    rs.Open count_sql, dbConnection

-    

-    If Not rs.BOF Then

-        RM_Count = rs("RM_TOTAL")

-    End If

-    

-    rs.Close

-    

-     db_get_All_RM_by_QTR = RM_Count

-    

-    If RM_Count > 0 Then

-        'we have records

-        ReDim rmcd(1 To RM_Count)

-        Dim index As Long

-        index = 1

-        rs.Open get_sql, dbConnection

-        

-        If Not rs.BOF Then

-             Do While Not rs.EOF

-                 Dim tmp_rmcd As tRMID_COMMON

-                 With tmp_rmcd

-                    .rgcd_count = 0

-                    .rm.City = rs("city")

-                    .rm.FirstName = rs("firstname")

-                    .rm.LastName = rs("lastname")

-                    .rm.rm_id = rs("mgr_id")

-                    .rm.Region = rs("region")

-                 End With

-                 

-                 rmcd(index) = tmp_rmcd

-                 index = index + 1

-                 rs.MoveNext

-             Loop

-        End If

-    End If

-    

-End Function

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Public Const STDBAR_NAME = "Worksheet Menu Bar"

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Import data"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmDataImport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-             With .Add(msoControlPopup)

-                .Caption = "&Report"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&New Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 18

-                        .OnAction = "cmNewReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Open Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmOpenReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Close && Save"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseReport"

-                    End With

-                End With

-            End With

-           With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Exit && Restore Excel"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 548

-                        .OnAction = "cmExitRestore"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-        End With

-    End With

-End Sub

-

-Sub CreateExtCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom extendet commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Import data"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmDataImport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-             With .Add(msoControlPopup)

-                .Caption = "&Report"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&New Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 18

-                        .OnAction = "cmNewReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Open Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmOpenReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Close && Save"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseReport"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Add New Slide"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 280

-                .OnAction = "cmAddSlide"

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(flag As Boolean)

-    If flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars(STDBAR_NAME)

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmExport()

-    dbExport

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    Dim dlg As dlgAbout

-    Set dlg = New dlgAbout

-    

-    dlg.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlg.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlg.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlg.Show

-End Sub

-

-Sub cmMail2Support()

-    Dim err_description As String

-    Dim dlg_msg As dlg_Mail

-    Set dlg_msg = New dlg_Mail

-    With dlg_msg

-        .Show

-        If .Tag = vbOK Then

-            ThisWorkbook.Worksheets(VAR_SHEET).Range("ERR_MESSAGE") _

-                = .tbMessage.Text

-            ThisWorkbook.Save

-            ThisWorkbook.SendMail Recipients:="infra@i-rs.ru", Subject:=PROGRAM_NAME & " ver.:" & PROGRAM_VERSION

-            MsgBox "Сообщение об ошибке отправлено. Перезагрузите программу.", vbOKOnly, PROGRAM_NAME

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-    End With

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-'        helppath = "hh.exe " & .Path & "\Telfast.chm"

-'        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub set_work_mode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-End Sub

-

-Sub cmSetStandaloneMode()

-    set_work_mode

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    Dim dlg As dlgGetPwd

-    rp = common_pwd

-    

-    Set dlg = New dlgGetPwd

-    dlg.edPwd = ""

-    dlg.Show

-    

-    If dlg.edPwd = rp Then

-        Application.ScreenUpdating = False

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-        xlRestoreView

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-        Application.ScreenUpdating = True

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmNewReport()

-    ppReport.CreateReport

-    MsgBox "Новый отчет создан", vbInformation + vbOKOnly, PROGRAM_NAME

-    CreateExtCommandBar theApp:=ThisWorkbook.Application

-End Sub

-

-Sub cmOpenReport()

-    Dim fileToOpen

-    Dim s As String

-    fileToOpen = Application _

-        .GetOpenFileName("Report Files (*.ppt), *.ppt", title:="Report OPen", MultiSelect:=False)

-    If fileToOpen <> False Then

-        s = fileToOpen

-        ppReport.OpenReport s

-        CreateExtCommandBar theApp:=ThisWorkbook.Application

-    End If

-End Sub

-

-Sub cmCloseReport()

-    On Error Resume Next

-    ppReport.SaveReport

-    CreateCommandBar theApp:=ThisWorkbook.Application

-End Sub

-

-Sub cmAddSlide()

-    ThisWorkbook.ActiveSheet.PrintCopy

-    ppReport.InsertSlide

-End Sub

-

-Sub cmHomePage()

-    ThisWorkbook.Worksheets("PRJ_QTR").Select

-End Sub

-

-Sub cmExitRestore()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = True

-    Application.Quit

-End Sub

-

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    Dim dlg_prn As dlgPrint

-    

-    Set dlg_prn = New dlgPrint

-    

-    With dlg_prn

-        .cbMainReport = True

-        .cbMainBudget = False

-        .cbSrcData = False

-        .cbAllSheets = False

-    

-        .Show

-    

-        If .Tag = vbCancel Then

-            Exit Sub

-        End If

-    End With

-    

-    Dim PrnIdx As Integer

-    

-    With dlg_prn

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("REP_QTR", "budget", "Final")

-    Case 1111

-        plist = Array("REP_QTR", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("REP_QTR")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Clexane bar"

-Public Const common_pwd As String = "crdjhxtyjr"

-

-

-Sub SetEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    With Application

-        .Caption = PROGRAM_NAME

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .GetState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = False

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Unprotect

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    If cWindow.Type = xlWorkbook Then

-                        cWindow.DisplayHeadings = True

-                    End If

-                Next

-            End If

-        Next

-        If DesignMode Then

-            SetupDesignMenu True

-        End If

-        With mobjAppState

-            .RestoreState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Option Explicit

-

-Sub UpdateHWRecords(objHW() As Long)

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    dbUpdateHWRecords dbConnection, objHW

-    dbCloseConnection dbConnection

-End Sub

-

-Function GetHWRecords(objHW() As Long) As Integer

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    GetHWRecords = dbGetHWRecords(dbConnection, objHW)

-    dbCloseConnection dbConnection

-End Function

-

-Sub HWReset()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbInsertHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    

-    Dim dbRecordset As Object

-    Dim i As Long

-    

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "hw", dbConnection, 2, 2

-    

-    For i = 1 To UBound(objHW)

-        dbRecordset.addnew

-        dbRecordset("num") = objHW(i)

-        dbRecordset.Update

-    Next i

-    

-End Sub

-

-Sub dbUpdateHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    dbDeleteHWRecord dbConnection

-    dbInsertHWRecords dbConnection, objHW

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-dbHir
->>>>>>
-Attribute VB_Name = "dbHir"

-Option Explicit

-

-Public Type tHIRURGIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    operations_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_ambulator_clexan_40mg As Integer

-    patients_ambulator_clexan_20mg As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-    patients_stationar_clexan_40mg As Integer

-    patients_stationar_clexan_20mg As Integer

-End Type

-

-' if objHir.ID <> 0 then updatre else insert

-Sub Insert_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objHir.id <> 0 Then

-        dbUpdate_Hir_Record dbConnection, objHir

-    Else

-        dbInsert_Hir_Record dbConnection, objHir

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Hir_RecordsByLPU_ID(ByRef allHir() As tHIRURGIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Hir_RecordsByLPU_ID = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, allHir, lpu_id, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Hir_Record dbConnection, objHir

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objHir.ID <> 0 then updatre else insert

-

-Sub dbInsert_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_hir", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objHir

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("operations_per_quarter") = .operations_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_ambulator_clexan_20mg") = .patients_ambulator_clexan_20mg

-        dbRecordset("patients_ambulator_clexan_40mg") = .patients_ambulator_clexan_40mg

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-        dbRecordset("patients_stationar_clexan_20mg") = .patients_stationar_clexan_20mg

-        dbRecordset("patients_stationar_clexan_40mg") = .patients_stationar_clexan_40mg

-        

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objHir.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim UpdateSQL As String

-    

-    With objHir

-        UpdateSQL = "UPDATE lpu_hir SET " & _

-            "entry_date='" & objHir.entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "operations_per_quarter=" & .operations_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_ambulator_clexan_20mg=" & .patients_ambulator_clexan_20mg & "," & _

-            "patients_ambulator_clexan_40mg=" & .patients_ambulator_clexan_40mg & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & "," & _

-            "patients_stationar_clexan_20mg=" & .patients_stationar_clexan_20mg & "," & _

-            "patients_stationar_clexan_40mg=" & .patients_stationar_clexan_40mg & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_Hir_RecordsbyLPU_ID(dbConnection As Object, allHir() As tHIRURGIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_Hir_SQL As String

-    Dim getAll_Hir_SQL As String

-    Dim Hir_Count As Long

-    Hir_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    Else

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Hir_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Hir_Count = dbRecordset("HIR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Hir_RecordsbyLPU_ID = Hir_Count

-    

-    If Hir_Count > 0 Then

-        'we have records

-        ReDim allHir(1 To Hir_Count)

-        Dim index As Integer

-        index = 1

-        dbRecordset.Open getAll_Hir_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpHir As tHIRURGIA

-                 With tmpHir

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .operations_per_quarter = dbRecordset("operations_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_ambulator_clexan_20mg = dbRecordset("patients_ambulator_clexan_20mg")

-                    .patients_ambulator_clexan_40mg = dbRecordset("patients_ambulator_clexan_40mg")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                    .patients_stationar_clexan_20mg = dbRecordset("patients_stationar_clexan_20mg")

-                    .patients_stationar_clexan_40mg = dbRecordset("patients_stationar_clexan_40mg")

-                 End With

-                 

-                 allHir(index) = tmpHir

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE ID=" & objHir.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Hir_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbTer
->>>>>>
-Attribute VB_Name = "dbTer"

-Option Explicit

-

-Public Type tTERAPIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objTer.ID <> 0 then updatre else insert

-Sub Insert_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objTer.id <> 0 Then

-        dbUpdate_Ter_Record dbConnection, objTer

-    Else

-        dbInsert_Ter_Record dbConnection, objTer

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Ter_RecordsByLPU_ID(ByRef allTer() As tTERAPIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Ter_RecordsByLPU_ID = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, allTer, lpu_id, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Ter_Record dbConnection, objTer

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objTer.ID <> 0 then updatre else insert

-

-Sub dbInsert_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_ter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objTer

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objTer.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim Update_SQL As String

-    

-    With objTer

-        Update_SQL = "UPDATE lpu_ter SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_Ter_RecordsbyLPU_ID(dbConnection As Object, allTer() As tTERAPIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_Ter_SQL As String

-    Dim getAll_Ter_SQL As String

-    Dim Ter_Count As Long

-    Ter_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    Else

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Ter_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Ter_Count = dbRecordset("TER_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Ter_RecordsbyLPU_ID = Ter_Count

-    

-    If Ter_Count > 0 Then

-        'we have records

-        ReDim allTer(1 To Ter_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_Ter_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpTer As tTERAPIA

-                 With tmpTer

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 allTer(index) = tmpTer

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE ID=" & objTer.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Ter_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-mLPU_LIST
->>>>>>
-Attribute VB_Name = "mLPU_LIST"

-Option Explicit

-

-Public Const CINP_AREA As String = "B12"

-Public Const CLPU_NAME As Integer = 0

-Public Const CLPU_NAME1 As Integer = 1

-Public Const CLPU_NAME2 As Integer = 2

-Public Const CLPU_ID As Integer = 3

-Public Const CLPU_BEDS As Integer = 4

-Public Const CLPU_NFG As Integer = 5

-Public Const CLPU_NMG As Integer = 6

-Public Const CLPU_HIR As Integer = 7

-Public Const CLPU_TER As Integer = 8

-Public Const CLPU_CAR As Integer = 9

-Public Const CLPU_FACT As Integer = 10

-Public Const CLPU_PLAN As Integer = 11

-Public Const CLPU_PAT_LPU As Integer = 16

-Public Const CLPU_BDGT As Integer = 17

-Public Const CLPU_PAT_ALL As Integer = 16

-

-Sub EditLPU(cLPU As tLPU, ent_date As String)

-    NoFunc

-End Sub

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("LPU_LIST")

-        s = .Range("C4") & " " & .Range("C3") & ", " & .Range("G4") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_LPU_BBL").Range("title") = MakeChartTitle

-End Sub

-

-Sub Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PIE").Range("title") = MakeChartTitle

-End Sub

-

-Sub Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU_A").Range("title") = MakeChartTitle

-End Sub

-

-Sub btLPU_DEL_IT()

-'    Dim cLPU As tLPU

-'    Dim ent_date As String

-'    Dim delete_all As Integer

-'    Dim dlg_del As dlg_LPU_delete

-'

-'    With Worksheets("LPU_LIST")

-'        ent_date = .Range("ent_date")

-'        cLPU.id = .getCurrentLPU_ID()

-'    End With

-'

-'    If cLPU.id = 0 Then

-'        MsgBox "Укажите удаляемый объект", vbOKOnly, PROGRAM_NAME

-'        Exit Sub

-'    End If

-'    cLPU = Get_LPU_Record(cLPU.id)

-'

-'    Set dlg_del = New dlg_LPU_delete

-'    With dlg_del

-'        .chbDeleteQTR.Value = True

-'        .chbDeleteAll.Value = False

-'        .lComment = ent_date & ": Удаление ЛПУ '" _

-'        & cLPU.Name & "', расположенного по адресу:" _

-'        & cLPU.address & " не разрешено."

-'        .Show

-'    End With

-End Sub

-

-Sub btLPU_RET_IT()

-    With Worksheets("LPU_LIST")

-        .setEnt_date ("")

-        .Range("LAST_FOCUS") = ""

-        

-        Wks_select .Range("ret_addr")

-    End With

-

-End Sub

-

-

-Sub btLPU_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim lpu_id As Long

-

-    i = Worksheets(VAR_SHEET).Range("QTR_ACTION").Value

-    With Worksheets("LPU_LIST")

-        ent_date = .getEnt_date()

-

-

-        lpu_id = .getCurrentLPU_ID

-        If lpu_id = 0 And i <> 6 Then

-            i = 1

-        End If

-        Select Case i

-            Case 1

-                .SelectLPU_NAME lpu_id, ent_date

-                .Range("JUMP") = "LPU_BDGT"

-            Case 2

-                .SelectLPU_BDGT lpu_id, ent_date

-                .Range("JUMP") = "LPU_BDGT"

-            Case 3

-                .SelectLPU_HIR lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_HIR"

-

-            Case 4

-                .SelectLPU_TER lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_TER"

-

-            Case 5

-                .SelectLPU_C_ACS lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        End Select

-    End With

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-dbQTR
->>>>>>
-Attribute VB_Name = "dbQTR"

-Option Explicit

-

-Public Type tQTR

-    id As Long

-    entry_date As String

-    rep_id As Long

-    rm_id As Long

-    sale_PLAN As Long

-    ClxnH20mg As Long

-    ClxnH40mg As Long

-    ClxnT40mg As Long

-    ClxnC_IM As Long

-    ClxnC_ACS As Long

-End Type

-

-Function Get_QTR_Record(ByVal QTR_ID As Long, rm_id As Long) As tQTR

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_QTR_Record = dbGet_QTR_Record(dbConnection, QTR_ID, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_Record(dbConnection As Object, ByVal QTR_ID As Long, rm_id As Long) As tQTR

-    

-    Dim sql As String

-    Dim objQTR As tQTR

-    

-    With objQTR

-        .ClxnC_ACS = 0

-        .ClxnC_IM = 0

-        .ClxnH20mg = 0

-        .ClxnH40mg = 0

-        .ClxnT40mg = 0

-        .entry_date = ""

-        .id = QTR_ID

-        .rm_id = rm_id

-    End With

-    

-    sql = "SELECT * FROM quarter WHERE id=" & QTR_ID & " AND rm_id=" & rm_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objQTR.entry_date = dbRecordset("entry_date")

-        objQTR.rep_id = dbRecordset("rep_id")

-        objQTR.rm_id = dbRecordset("rm_id")

-        objQTR.sale_PLAN = dbRecordset("sale_plan")

-        objQTR.ClxnH20mg = dbRecordset("ClxnH20mg")

-        objQTR.ClxnH40mg = dbRecordset("ClxnH40mg")

-        objQTR.ClxnT40mg = dbRecordset("ClxnT40mg")

-        objQTR.ClxnC_IM = dbRecordset("ClxnC_IM")

-        objQTR.ClxnC_ACS = dbRecordset("ClxnC_ACS")

-        objQTR.id = dbRecordset("id")

-    End If

-    

-    dbGet_QTR_Record = objQTR

-

-End Function

-

-

-Function Get_QTR_Record_by_REP(ent_date As String, rep_id As Long, rm_id As Long) As tQTR

-    Dim dbConnection As Object

-    Dim allQTR() As tQTR

-    Dim i As Long

-

-    dbOpenConnection dbConnection

-

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id, rm_id)

-    If i <> 0 Then

-        Get_QTR_Record_by_REP = allQTR(1)

-    End If

-

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTR_Records_by_REP(ByRef all_QTR() As tQTR, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-

-    GetAll_QTR_Records_by_REP = dbGetAll_QTR_Records_By_REP(dbConnection, all_QTR, ent_date, rep_id, rm_id)

-

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGetAll_QTR_Records_By_REP(dbConnection As Object, all_QTR() As tQTR, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-

-    Dim getCount_QTR_SQL As String

-    Dim getAll_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    Dim rep_sql As String

-    Dim rm_sql As String

-    

-    rep_sql = ""

-    rm_sql = ""

-    

-    If rep_id <> 0 Then

-        rep_sql = " AND rep_id=" & rep_id

-    End If

-    

-    If rm_id <> 0 Then

-        rm_sql = " AND rm_id=" & rm_id

-    End If

-    

-    

-        getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter " & _

-        "WHERE entry_date like '" & ent_date & "' " & rep_sql & rm_sql

-        getAll_QTR_SQL = "SELECT * FROM quarter " & _

-        "WHERE entry_date like '" & ent_date & "' " & rep_sql & rm_sql & " ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-

-    dbRecordset.Close

-

-    dbGetAll_QTR_Records_By_REP = QTR_Count

-

-    If QTR_Count > 0 Then

-        'we have records

-        ReDim all_QTR(1 To QTR_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTR_SQL, dbConnection

-

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTR As tQTR

-                 With tmp_QTR

-                    .entry_date = dbRecordset("entry_date")

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .ClxnH20mg = dbRecordset("ClxnH20mg")

-                    .ClxnH40mg = dbRecordset("ClxnH40mg")

-                    .ClxnT40mg = dbRecordset("ClxnT40mg")

-                    .ClxnC_IM = dbRecordset("ClxnC_IM")

-                    .ClxnC_ACS = dbRecordset("ClxnC_ACS")

-                    .id = dbRecordset("id")

-                 End With

-

-                 all_QTR(index) = tmp_QTR

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-cdbQTR
->>>>>>
-Attribute VB_Name = "cdbQTR"

-Option Explicit

-

-Public Type tQTR_COMMON

-    qtr As tQTR

-    i_lcd As Long           ' число ЛПУ в СПИСКЕ

-    lcd() As tLPU_COMMON    ' список ЛПУ

-    c_beds As Long          ' сумма коек

-    c_bdgt_NFG As Long      ' общий бюджет на НФГ

-    c_bdgt_NMG As Long      ' общий бюджет на НМГ

-    c_bdgt_LPU As Long      ' общий бюджет на гепарины

-    c_sale_PLAN As Long     ' план продаж репа

-    c_sale_ALL As Long      ' продажи

-    c_sale_HIR As Long      ' в хирургии

-    c_sale_TER  As Long     ' в терапии

-    c_sale_CRD  As Long     ' в кардиологии

-    c_pat_HIR   As Long     ' пациенты

-    c_pat_TER   As Long     '

-    c_pat_CRD   As Long     '

-    c_pat_ALL   As Long     '

-    c_pat_LPU   As Long     ' Всего операций

-End Type

-

-Function Get_QTR_CommonList_by_REP(ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long, rm_id As Long) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_QTR_CommonList_by_REP = dbGet_QTR_CommonList_by_REP(dbConnection, qcd, ent_date, rep_id, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_CommonList_by_REP(dbConnection As Object, ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long, rm_id As Long) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim allQTR() As tQTR

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id, rm_id)

-    dbGet_QTR_CommonList_by_REP = i

-    If i > 0 Then

-        ReDim qcd(i)

-        For i = 1 To UBound(allQTR)

-            With qcd(i)

-                .qtr = allQTR(i)

-                .c_beds = 0

-                .c_bdgt_NFG = 0

-                .c_bdgt_NMG = 0

-                .c_bdgt_LPU = 0

-                .c_sale_PLAN = 0

-                .c_pat_HIR = 0

-                .c_pat_TER = 0

-                .c_pat_CRD = 0

-                .c_pat_ALL = 0

-                .c_sale_HIR = 0

-                .c_sale_TER = 0

-                .c_sale_CRD = 0

-                .c_sale_ALL = 0

-                .c_pat_LPU = 0

-                

-                j = dbGet_LPU_CommonQTR(dbConnection, .lcd, .qtr)

-                .i_lcd = j

-                If j > 0 Then

-                    For j = 1 To UBound(.lcd)

-                        .c_beds = .c_beds + .lcd(j).lpu.beds

-                        .c_bdgt_NFG = .c_bdgt_NFG + .lcd(j).bdgt.bdgt_NFG

-                        .c_bdgt_NMG = .c_bdgt_NMG + .lcd(j).bdgt.bdgt_NMG

-                        .c_bdgt_LPU = .c_bdgt_LPU + .lcd(j).bdgt_LPU

-                        .c_sale_PLAN = .c_sale_PLAN + .lcd(j).bdgt.sale_PLAN

-                        .c_pat_HIR = .c_pat_HIR + .lcd(j).pat_HIR

-                        .c_pat_TER = .c_pat_TER + .lcd(j).pat_TER

-                        .c_pat_CRD = .c_pat_CRD + .lcd(j).pat_CRD

-                        .c_pat_ALL = .c_pat_ALL + .lcd(j).pat_ALL

-                        .c_sale_HIR = .c_sale_HIR + .lcd(j).sale_HIR

-                        .c_sale_TER = .c_sale_TER + .lcd(j).sale_TER

-                        .c_sale_CRD = .c_sale_CRD + .lcd(j).sale_CRD

-                        .c_sale_ALL = .c_sale_ALL + .lcd(j).sale_ALL

-                        .c_pat_LPU = .c_pat_LPU + .lcd(j).pat_LPU

-                    Next j

-                    

-                End If

-            End With

-        Next i

-    End If

-End Function

-

-Function GetLastQtr() As String

-    Dim s As String

-    Dim r As Range

-    Set r = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Do While r.Cells(1, 1) <> ""

-        s = r.Cells(1, 1)

-        Set r = r.Cells.Offset(1, 0)

-    Loop

-    GetLastQtr = s

-End Function

-

-Function GetNextQTR(ent_date As String) As String

-    Dim rd As Range

-    Dim idx As Integer

-    Dim b As Variant

-    Dim dlg As dlg_newQTR

-    Set dlg = New dlg_newQTR

-    

-    If ent_date = "" Then

-        Dim ir As Variant

-        idx = 0

-        dlg.Show

-        b = dlg.Tag

-            

-        If IsNumeric(b) Then

-            GetNextQTR = dlg.cbQTR

-        Else

-            GetNextQTR = ""

-        End If

-    Else

-        Set rd = Worksheets(VAR_SHEET).Range("Date_Lst")

-        idx = WorksheetFunction.Match(ent_date, rd, 0)

-        GetNextQTR = WorksheetFunction.index(rd, idx + 1, 1)

-    End If

-End Function

-<<<<<<
-======================
-mRestView
->>>>>>
-Attribute VB_Name = "mRestView"

-Option Explicit

-

-Sub xlRestoreView()

-Attribute xlRestoreView.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute xlRestoreView.VB_ProcData.VB_Invoke_Func = " \n14"

-    With Application

-        .CommandBars("Standard").Visible = True

-        .CommandBars("Formatting").Visible = True

-        .DisplayFormulaBar = True

-        .DisplayStatusBar = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = True

-    End With

-End Sub

-<<<<<<
-======================
-dlg_newQTR
->>>>>>
-Attribute VB_Name = "dlg_newQTR"

-Attribute VB_Base = "0{92648543-CB84-4B6B-BEB3-539AE7EF9D84}{7E20E3E3-027A-483B-A14D-AA9EA5398ACC}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mDec2TS
->>>>>>
-Attribute VB_Name = "mDec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-CHRT_LPU_BBL
->>>>>>
-Attribute VB_Name = "CHRT_LPU_BBL"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    Unprotect

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Потенциал рынка: " & Range("title")

-    Range("view_key") = False

-    ChangeLabels

-    Range("A1").Select

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Unprotect

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub BCLabelChng_Click()

-    Unprotect

-    If Range("view_key") Then

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать названия"

-    Else

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать объемы"

-    End If

-    Range("view_key") = Not Range("view_key")

-    ChangeLabels

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub ChangeLabels()

-    Dim i As Integer

-    Dim offset_text As Integer

-    Dim src As Range

-    Set src = Range("CHRT_BBL_DATA")

-    

-    offset_text = 3

-    If Range("view_key") Then

-        offset_text = 4

-    End If

-    

-    With ChartObjects(1).Chart

-        With .SeriesCollection(1)

-            For i = 1 To .Points.count

-                On Error GoTo ExitLabel

-                .Points(i).DataLabel.Characters.Text = Format(src.Cells(i, offset_text))

-            Next i

-        End With

-    End With

-ExitLabel:

-End Sub

-<<<<<<
-======================
-CHRT_PAT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PAT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Пациенты на Клексане(чел.): " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-<<<<<<
-======================
-CHRT_PAT_LPU
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Пациенты на Клексане(%): " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_nextQTR
->>>>>>
-Attribute VB_Name = "dlg_nextQTR"

-Attribute VB_Base = "0{067FED69-B41E-427D-AF59-5798B8E2E73A}{4C13CAB1-FDCC-4708-89EB-E92EDC125712}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-cdbLPU
->>>>>>
-Attribute VB_Name = "cdbLPU"

-Option Explicit

-

-Public Type tLPU_COMMON

-    lpu As tLPU

-    bdgt As tBUDGET

-    i_hir As Long

-    hir() As tHIRURGIA

-    i_ter As Long

-    ter() As tTERAPIA

-    i_ACS As Long

-    ACS() As tACS

-    bdgt_LPU As Long

-    sale_HIR As Long

-    sale_TER As Long

-    sale_CRD As Long

-    sale_ALL As Long

-    pat_HIR As Long

-    pat_TER As Long

-    pat_CRD As Long

-    pat_ALL As Long     ' Сумма всех пациентов на клексане

-    pat_LPU As Long     ' Число потенциальных пациентов для продаж клексана

-End Type

-

-Function Get_LPU_CommonQTR(ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    Get_LPU_CommonQTR = dbGet_LPU_CommonQTR(dbConnection, lcd, objQTR)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_CommonQTR(dbConnection As Object, ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    i = dbGetAll_LPU_byQTR(dbConnection, allLPU, objQTR.entry_date, objQTR.rep_id, objQTR.rm_id)

-    dbGet_LPU_CommonQTR = i

-    If i > 0 Then

-        ReDim lcd(i)

-        For i = 1 To UBound(allLPU)

-            dbGet_LPU_Common dbConnection, lcd(i), allLPU(i), objQTR

-        Next i

-    End If

-End Function

-

-Sub Get_LPU_Common(ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    dbGet_LPU_Common dbConnection, lcd, cLPU, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbGet_LPU_Common(dbConnection As Object, ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-

-    lcd.lpu = cLPU

-    lcd.bdgt = dbGet_BDGT_Record(dbConnection, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    lcd.i_hir = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, lcd.hir, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    lcd.i_ter = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, lcd.ter, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    lcd.i_ACS = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, lcd.ACS, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    With lcd

-        .bdgt_LPU = .bdgt.bdgt_NFG + .bdgt.bdgt_NMG

-        .pat_LPU = 0

-        If .i_hir > 0 Then

-            .pat_HIR = .hir(1).patients_ambulator_clexan + .hir(1).patients_stationar_clexan

-            .sale_HIR = objQTR.ClxnH20mg * (.hir(1).patients_ambulator_clexan_20mg + .hir(1).patients_stationar_clexan_20mg)

-            .sale_HIR = .sale_HIR + objQTR.ClxnH40mg * (.hir(1).patients_ambulator_clexan_40mg + .hir(1).patients_stationar_clexan_40mg)

-            .pat_LPU = .pat_LPU + .hir(1).operations_per_quarter

-        End If

-        If .i_ter > 0 Then

-            .pat_TER = .ter(1).patients_ambulator_clexan + .ter(1).patients_stationar_clexan

-            .sale_TER = .pat_TER * objQTR.ClxnT40mg

-            .pat_LPU = .pat_LPU + .ter(1).patients_per_quarter

-        End If

-        If .i_ACS > 0 Then

-            .pat_CRD = .ACS(1).patients_stationar_clexan

-            .sale_CRD = .pat_CRD * objQTR.ClxnC_ACS

-            .pat_LPU = .pat_LPU + .ACS(1).patients_per_quarter

-        End If

-        .pat_ALL = .pat_HIR + .pat_TER + .pat_CRD

-        .sale_ALL = .sale_HIR + .sale_TER + .sale_CRD

-    End With

-End Sub

-

-<<<<<<
-======================
-CHRT_PIE
->>>>>>
-Attribute VB_Name = "CHRT_PIE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Unprotect

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Доля продаж: " & Range("title")

-    

-    On Error Resume Next

-    Range("P5:Q24").Sort _

-        Key1:=Range("Q5"), _

-        Order1:=xlDescending, _

-        Header:=xlGuess, _

-        OrderCustom:=1, _

-        MatchCase:=False, _

-        Orientation:=xlTopToBottom

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PLN_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PLN_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Динамика продаж: " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_BDGT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_BDGT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Бюджеты ЛПУ: " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-dlg_LPU_delete
->>>>>>
-Attribute VB_Name = "dlg_LPU_delete"

-Attribute VB_Base = "0{9C81F4D2-4ECF-46F5-999B-9801D572A12F}{B382508B-7F3D-4747-8407-0F75F6F265F5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlg_Mail
->>>>>>
-Attribute VB_Name = "dlg_Mail"

-Attribute VB_Base = "0{EA8CE4CE-AC2E-45BC-BAF8-1429E6242097}{575F0762-04F4-4F86-B98A-8E87E3424B0D}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dbREP_id
->>>>>>
-Attribute VB_Name = "dbREP_id"

-Public Type tREPID

-    rep_id As Long

-    rm_id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function GetAll_REPID_Records_by_QTR(ByRef all_REPID() As tREPID, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_REPID_Records_by_QTR = dbGetAll_REPID_Records_by_QTR(dbConnection, all_REPID, ent_date, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function Get_REPID_Record(rep_id As Long, rm_id As Long) As tREPID

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REPID_Record = dbGet_REPID_Record(dbConnection, rep_id, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_REPID_Records(ByRef all_REPID() As tREPID) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_REPID_Records = dbGetAll_REPID_Records(dbConnection, all_REPID)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function dbGet_REPID_Record(dbConnection As Object, rep_id As Long, rm_id As Long) As tREPID

-    

-    Dim sql As String

-    Dim objREPID As tREPID

-    

-    objREPID.FirstName = ""

-    objREPID.LastName = ""

-    objREPID.Region = 0

-    objREPID.City = 0

-    sql = "SELECT * FROM " & _

-          "rep WHERE rep_id=" & rep_id & " AND rm_id=" & rm_id

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREPID.rep_id = dbRecordset("rep_id")

-        objREPID.rm_id = dbRecordset("rm_id")

-        objREPID.FirstName = dbRecordset("firstname")

-        objREPID.LastName = dbRecordset("lastname")

-        objREPID.Region = dbRecordset("region")

-        objREPID.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REPID_Record = objREPID

-        

-End Function

-

-Function dbGetAll_REPID_Records_by_QTR(dbConnection As Object, ByRef all_REPID() As tREPID, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    Dim Where As String

-    

-    REPID_Count = 0

-    

-    Where = " WHERE lpu_budget.entry_date like '" & ent_date & "' " & _

-        "AND rep.rep_id=lpu.rep_id AND lpu.id=lpu_budget.lpu_id"

-    If rm_id <> 0 Then

-        Where = Where & " AND rep.rm_id=" & rm_id

-    End If

-    

-    getAll_REPID_SQL = "SELECT distinct rep.* FROM rep, lpu, lpu_budget" & Where

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM (" & getAll_REPID_SQL & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records_by_QTR = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Function dbGetAll_REPID_Records(dbConnection As Object, ByRef all_REPID() As tREPID) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    REPID_Count = 0

-    

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM rep"

-    getAll_REPID_SQL = "SELECT * FROM rep"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-cdbExport
->>>>>>
-Attribute VB_Name = "cdbExport"

-Option Explicit

-

-Function GetDBSN() As String

-    Dim n As Long

-    Randomize Timer

-    n = Int((100000000 - 1000000 + 1) * Rnd + 1000000)

-    GetDBSN = Dec2ThirtySix(n)

-End Function

-

-Sub dbExport()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim old_file As String

-    

-    On Error GoTo ErrHandler

-    

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    old_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & "*.*"

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & GetDBSN() & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.DeleteFile old_file, True

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Данные экспортированы в файл:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для передачи", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-Exit Sub

-

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-<<<<<<
-======================
-mRegs
->>>>>>
-Attribute VB_Name = "mRegs"

-Option Explicit

-

-Function GetRegionName(idx As Integer) As String

-    GetRegionName = Worksheets(REGS_SHEET).Range("LST_REGIONS").Cells(idx + 1, 1).Text

-End Function

-

-Function GetCityName(idx_reg As Integer, idx_city As Integer) As String

-    GetCityName = Worksheets(REGS_SHEET).Range("CITY_TABLES").Offset(idx_city + 1, idx_reg * 2).Text

-End Function

-

-Sub testReg()

-    Dim r As Integer

-    Dim c As Integer

-    Dim s As String

-    

-    r = 3

-    c = 3

-    s = GetRegionName(r)

-    s = s & ", " & GetCityName(r, c)

-    MsgBox s

-End Sub

-

-<<<<<<
-======================
-RM_QTR
->>>>>>
-Attribute VB_Name = "RM_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CRGN_QT As Integer = 0

-Const CRGN_PLN As Integer = 2

-Const CRGN_FCT As Integer = 3

-Const CRGN_BDG As Integer = 4

-Const CRGN_LPU As Integer = 5

-Const CRGN_REP As Integer = 6

-Const CRGN_HIR As Integer = 7

-Const CRGN_TER As Integer = 8

-Const CRGN_CRD As Integer = 9

-Const CRGN_CLXN_BDG As Integer = 10

-Const CRGN_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Const LOCAL_ENT_DATE As String = "B11"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("RM_QTR")

-        s = .Range("D5") & " " & .Range("D4") & ", " & .Range("H4") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub update_history()

-    Dim objRGN() As tREGION

-    Dim i As Long

-    Dim r As Range

-    Dim cRMan As tREGMAN

-

-    cRMan = Get_REGMAN_Record(Range("RM_ID"))

-    

-    Range("D4") = cRMan.LastName

-    Range("D5") = cRMan.FirstName

-

-    Range("H4") = GetRegionName(cRMan.Region)

-    

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetRGN_COMM_DATA(objRGN, Range("RM_ID"))

-    

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objRGN)

-            r.Offset(i - 1, CRGN_QT) = objRGN(i).ent_date

-            r.Offset(i - 1, CRGN_FCT) = objRGN(i).total_SALE

-            r.Offset(i - 1, CRGN_PLN) = objRGN(i).sale_PLAN

-            r.Offset(i - 1, CRGN_BDG) = objRGN(i).total_BDGT

-            r.Offset(i - 1, CRGN_LPU) = objRGN(i).total_LPU

-            r.Offset(i - 1, CRGN_REP) = objRGN(i).total_REP

-            r.Offset(i - 1, CRGN_HIR) = objRGN(i).total_HIR

-            r.Offset(i - 1, CRGN_TER) = objRGN(i).total_TER

-            r.Offset(i - 1, CRGN_CRD) = objRGN(i).total_ACS

-            If objRGN(i).total_BDGT <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_BDG) = objRGN(i).total_SALE / objRGN(i).total_BDGT

-            End If

-            If objRGN(i).total_BDGT_NMG <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_NMG) = objRGN(i).total_SALE / objRGN(i).total_BDGT_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRGN_CRD + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-

-Sub Draw_PLN_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_FCT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PLN_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Draw_BDGT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_CLXN_NMG + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_BDGT_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Public Sub cbxRM_QtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR_RM

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR_RM

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR_RM

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = RM_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CRGN_QT + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    If r = "" Then

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = currRange.address

-    End If

-    Cancel = True

-    btRM_QTR_Do_IT

-End Sub

-

-<<<<<<
-======================
-dbREG_MAN
->>>>>>
-Attribute VB_Name = "dbREG_MAN"

-Option Explicit

-

-Public Type tREGMAN

-    rm_id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function Get_REGMAN_Record(rm_id As Long) As tREGMAN

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REGMAN_Record = dbGet_REGMAN_Record(dbConnection, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Sub Set_REGMAN_Record(cREGMAN As tREGMAN)

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbSet_REGMAN_Record dbConnection, cREGMAN

-'    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_REGMAN_Record(dbConnection As Object, rm_id As Long) As tREGMAN

-    

-    Dim sql As String

-    Dim objREGMAN As tREGMAN

-    

-    objREGMAN.FirstName = ""

-    objREGMAN.LastName = ""

-    objREGMAN.Region = 0

-    objREGMAN.City = 0

-    objREGMAN.rm_id = rm_id

-    sql = "SELECT * FROM " & _

-          "reg_man WHERE mgr_id=" & rm_id

-          

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREGMAN.FirstName = dbRecordset("firstname")

-        objREGMAN.LastName = dbRecordset("lastname")

-        objREGMAN.Region = dbRecordset("region")

-        objREGMAN.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REGMAN_Record = objREGMAN

-        

-End Function

-

-Public Sub dbSet_REGMAN_Record(dbConnection As Object, ByRef objREGMAN As tREGMAN)

-  

-'    Dim DeleteSQL As String

-'    Dim InsertSQL As String

-'

-'    DeleteSQL = "DELETE FROM reg_man"

-'    InsertSQL = "INSERT INTO reg_man (firstname, lastname, region, city) VALUES (" & _

-'    "'" & objREGMAN.FirstName & "', " & _

-'    "'" & objREGMAN.LastName & "', " & _

-'    objREGMAN.Region & ", " & _

-'    objREGMAN.City & ")"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-       

-End Sub

-

-

-

-<<<<<<
-======================
-dbDatabaseMerge
->>>>>>
-Attribute VB_Name = "dbDatabaseMerge"

-Option Explicit

-

-Public Type tDBFIELD

-    Name As String

-End Type

-

-Public Type tDBTABLE

-    Name As String

-    field() As tDBFIELD

-End Type

-

-

-Function dbGetConnection(dbAccessFileFullPath As String) As Object

-    Dim dbConnection As Object

-    Dim dbAccessFilePasswd As String

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFileFullPath & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    Set dbGetConnection = dbConnection

-End Function

-

-Sub dbCloseOpenedConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteOpenedSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-Function dbMergeREP(from_dbConnection As Object, to_dbConnection As Object) As Long

-

-    Dim getRecordset As Object

-    Dim getREPData_SQL As String

-    Dim REP_fn As String

-    Dim REP_ln As String

-    Dim REP_region As String

-    Dim REP_city As String

-

-

-    getREPData_SQL = "SELECT * FROM rep"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getREPData_SQL, from_dbConnection

-        

-        If Not getRecordset.BOF Then

-            REP_fn = getRecordset("firstname")

-            REP_ln = getRecordset("lastname")

-            REP_city = getRecordset("city")

-            REP_region = getRecordset("region")

-        Else

-            MsgBox "There is no information about rep! This database cannot be merged!!!"

-            dbMergeREP = -1

-            Exit Function

-        End If

-    

-    Dim insertRecordset As Object

-    Set insertRecordset = CreateObject("ADODB.Recordset")

-        

-    insertRecordset.Open "rep", to_dbConnection, 2, 2

-    insertRecordset.addnew

-        

-    insertRecordset("firstname") = REP_fn

-    insertRecordset("lastname") = REP_ln

-    insertRecordset("region") = REP_region

-    insertRecordset("city") = REP_city

-    insertRecordset.Update

-    insertRecordset.MoveLast

-    'new ID

-    

-    dbMergeREP = insertRecordset("rep_id")

-    

-End Function

-

-Sub dbMergeLPU(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getLPU_SQL As String

-    Dim getRecordset As Object

-    Dim idx As Long

-    idx = 1

-    

-    getLPU_SQL = "SELECT * FROM lpu"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getLPU_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            ReDim Preserve objLPU(1 To idx)

-            objLPU(idx).old_lpu_id = getRecordset("id")

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "lpu", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("name") = getRecordset("name")

-            insRS("address") = getRecordset("address")

-            insRS("beds") = getRecordset("beds")

-            insRS.Update

-            insRS.MoveLast

-            'new ID

-            

-            objLPU(idx).new_lpu_id = insRS("id")

-                        

-            idx = idx + 1

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about LPU! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-

-Sub dbMergeLPURelated(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object)

-

-    ' 6 tables to change

-    Dim tables(1 To 5) As tDBTABLE

-    

-    'lpu budget

-    tables(1).Name = "lpu_budget"

-    ReDim tables(1).field(1 To 4)

-    

-    tables(1).field(1).Name = "entry_date"

-    tables(1).field(2).Name = "bdgt_NMG"

-    tables(1).field(3).Name = "bdgt_NFG"

-    tables(1).field(4).Name = "sale_PLAN"

-    

-    'lpu hir

-    tables(2).Name = "lpu_hir"

-    ReDim tables(2).field(1 To 13)

-    

-    tables(2).field(1).Name = "entry_date"

-    tables(2).field(2).Name = "operations_per_quarter"

-    tables(2).field(3).Name = "risk_percent"

-    tables(2).field(4).Name = "patients_with_risk_ON"

-    tables(2).field(5).Name = "patients_ambulator"

-    tables(2).field(6).Name = "patients_ambulator_nmg"

-    tables(2).field(7).Name = "patients_ambulator_clexan"

-    tables(2).field(8).Name = "patients_ambulator_clexan_40mg"

-    tables(2).field(9).Name = "patients_ambulator_clexan_20mg"

-    tables(2).field(10).Name = "patients_stationar_nmg"

-    tables(2).field(11).Name = "patients_stationar_clexan"

-    tables(2).field(12).Name = "patients_stationar_clexan_40mg"

-    tables(2).field(13).Name = "patients_stationar_clexan_20mg"

-    

-    

-    'lpu acs

-    tables(3).Name = "lpu_acs"

-    ReDim tables(3).field(1 To 5)

-    

-    tables(3).field(1).Name = "entry_date"

-    tables(3).field(2).Name = "patients_with_geparins"

-    tables(3).field(3).Name = "patients_per_quarter"

-    tables(3).field(4).Name = "patients_stationar_nmg"

-    tables(3).field(5).Name = "patients_stationar_clexan"

-    

-    'lpu acs

-    tables(4).Name = "lpu_im"

-    ReDim tables(4).field(1 To 5)

-    

-    tables(4).field(1).Name = "entry_date"

-    tables(4).field(2).Name = "patients_with_geparins"

-    tables(4).field(3).Name = "patients_per_quarter"

-    tables(4).field(4).Name = "patients_stationar_nmg"

-    tables(4).field(5).Name = "patients_stationar_clexan"

-    

-    

-    'lpu acs

-    tables(5).Name = "lpu_ter"

-    ReDim tables(5).field(1 To 9)

-    

-    tables(5).field(1).Name = "entry_date"

-    tables(5).field(2).Name = "patients_per_quarter"

-    tables(5).field(3).Name = "risk_percent"

-    tables(5).field(4).Name = "patients_with_risk_ON"

-    tables(5).field(5).Name = "patients_ambulator"

-    tables(5).field(6).Name = "patients_ambulator_nmg"

-    tables(5).field(7).Name = "patients_ambulator_clexan"

-    tables(5).field(8).Name = "patients_stationar_nmg"

-    tables(5).field(9).Name = "patients_stationar_clexan"

-    

-    

-    

-    Dim tbl_idx As Integer

-    

-    For tbl_idx = 1 To UBound(tables)

-        

-        Dim getSQL As String

-        Dim getRS As Object

-        

-        

-        

-        Set getRS = CreateObject("ADODB.Recordset")

-        

-        getSQL = "SELECT * FROM " & tables(tbl_idx).Name

-        getRS.Open getSQL, from_db

-        

-        If Not getRS.BOF Then

-            Do While Not getRS.EOF

-                Dim insRS As Object

-                Set insRS = CreateObject("ADODB.Recordset")

-                

-                insRS.Open tables(tbl_idx).Name, to_db, 2, 2

-                insRS.addnew

-                Dim fld_idx As Integer

-    

-                    For fld_idx = 1 To UBound(tables(tbl_idx).field)

-                        insRS(tables(tbl_idx).field(fld_idx).Name) = getRS(tables(tbl_idx).field(fld_idx).Name)

-                        insRS("lpu_id") = findNewLPU_IDByOld(objLPU, getRS("lpu_id"))

-                    Next fld_idx

-                    

-                insRS.Update

-                insRS.MoveLast

-                getRS.MoveNext

-            Loop

-        End If

-        

-        

-    Next tbl_idx

-

-End Sub

-

-Function findNewLPU_IDByOld(objLPU() As tLPUCONVERTION, old_id As Long)

-

-Dim i As Integer

-For i = 1 To UBound(objLPU)

-    If objLPU(i).old_lpu_id = old_id Then

-        findNewLPU_IDByOld = objLPU(i).new_lpu_id

-        Exit Function

-    End If

-Next i

-

-findNewLPU_IDByOld = -1

-End Function

-

-

-

-

-

-Sub dbMergeQTR(from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getQTR_SQL As String

-    Dim getRecordset As Object

-    

-    getQTR_SQL = "SELECT * FROM quarter"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getQTR_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "quarter", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("entry_date") = getRecordset("entry_date")

-            insRS("sale_plan") = getRecordset("sale_plan")

-            insRS("ClxnH20mg") = getRecordset("ClxnH20mg")

-            insRS("ClxnH40mg") = getRecordset("ClxnH40mg")

-            insRS("ClxnT40mg") = getRecordset("ClxnT40mg")

-            insRS("ClxnC_IM") = getRecordset("ClxnC_IM")

-            insRS("ClxnC_ACS") = getRecordset("ClxnC_ACS")

-            

-            

-            insRS.Update

-            

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about quarter budget! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-dbMerge
->>>>>>
-Attribute VB_Name = "dbMerge"

-Option Explicit

-

-Public Type tLPUCONVERTION

-    old_lpu_id As Long

-    new_lpu_id As Long

-End Type

-

-Sub Merge_BackUp_All_Data()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim time_stump As String

-    

-    On Error GoTo ErrHandler

-    

-    time_stump = Format(Date, "yy-mm-dd_") & Format(Time, "hh-mm")

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_BACKUPNAME & time_stump & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Старые данные сохранены в файле:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для восстанеовления данных в случае утери", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-    Exit Sub

-    

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-

-Sub Merge_Clear_All_Data(access_file_full_path As String)

-    

-    Dim db As Object

-    Dim tables_to_clear() As String

-    On Error GoTo ErrHandler

-    

-    ReDim tables_to_clear(1 To 10)

-    tables_to_clear(1) = "rep"

-    tables_to_clear(2) = "lpu"

-    tables_to_clear(3) = "lpu_budget"

-    tables_to_clear(4) = "lpu_hir"

-    tables_to_clear(5) = "lpu_ter"

-    tables_to_clear(6) = "lpu_acs"

-    tables_to_clear(7) = "lpu_im"

-    tables_to_clear(8) = "quarter"

-    tables_to_clear(9) = "quarter_rm"

-    tables_to_clear(10) = "reg_man"

-    

-    Set db = dbGetConnection(access_file_full_path)

-

-    Dim i As Integer

-    

-    For i = 1 To UBound(tables_to_clear)

-        

-        If tables_to_clear(i) <> "" Then

-            Dim Clear_SQL As String

-            Clear_SQL = "DELETE FROM " & tables_to_clear(i)

-            dbExecuteOpenedSQL db, Clear_SQL

-        Else

-            'do nothing or show message

-        End If

-    Next i

-    

-    dbCloseOpenedConnection db

-    Set db = Nothing

-    

-Exit Sub

-

-ErrHandler:

-    MsgBox "something wrong: " & err.Description

-    Resume Next

-    

-End Sub

-

-Function MergeREP(from_file As String, to_file As String) As Long

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    Dim new_rep_id As Long

-

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    MergeREP = dbMergeREP(db1, db2)

-    'MsgBox "new rep ID is " & new_rep_id

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Function

-

-Sub MergeQTR(from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeQTR db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-

-Sub MergeLPU(objLPU() As tLPUCONVERTION, from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeLPU objLPU, db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-Sub MergeLPURelated(objLPU() As tLPUCONVERTION, from_file As String, to_file As String)

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    dbMergeLPURelated objLPU, db1, db2

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-

-End Sub

-

-Sub MergeGlobal(rep_files() As String, rm_file As String)

-

-    Dim i As Integer

-    'clear output file content

-    Merge_Clear_All_Data rm_file

-    

-    For i = 1 To UBound(rep_files)

-        

-        Dim rep_file As String

-        'setup input and output files

-        rep_file = rep_files(i)

-        

-        Dim new_rep_id As Long

-        ' insert REP data and get new rep_id

-        new_rep_id = MergeREP(rep_file, rm_file)

-        

-        Dim objLPU() As tLPUCONVERTION

-        'insert all LPU using new generated rep_id

-        'and populate objLPU old->new relation object

-        

-        MergeLPU objLPU, rep_file, rm_file, new_rep_id

-        'insert quarter data using new rep_id

-        MergeQTR rep_file, rm_file, new_rep_id

-        

-        

-        ' and.... insert all another data (5 tables excl version and hw)

-        'using objLPU old->new relation object

-        MergeLPURelated objLPU, rep_file, rm_file

-    

-    

-    Next i

-    

-End Sub

-

-Function GetDBList(MyPath() As String, ByRef dblist() As String) As Integer

-    Dim i As Integer

-    Dim MyName, MyMask

-    MyMask = MyPath(0) & MyPath(1) & PROGRAM_DATAEXT

-    i = 0

-    MyName = Dir(MyMask)      ' Retrieve the first entry.

-    Do While MyName <> ""    ' Start the loop.

-        ' Ignore the current directory and the encompassing directory.

-        If MyName <> "." And MyName <> ".." Then

-            ' Use bitwise comparison to make sure MyName is a directory.

-            i = i + 1

-            ReDim Preserve dblist(i)

-            dblist(i) = MyPath(0) & MyName

-        End If

-        MyName = Dir    ' Get next entry.

-    Loop

-    GetDBList = i

-End Function

-

-<<<<<<
-======================
-cdbPRJ
->>>>>>
-Attribute VB_Name = "cdbPRJ"

-Option Explicit

-

-Type tPROJECT

-    total_SALE  As Long ' общий объем продаж

-    total_BDGT  As Long ' бюджет всех ЛПУ

-    total_BDGT_NMG As Long ' бюджет всех ЛПУ на НМГ

-    total_LPU   As Long ' число ЛПУ

-    total_REP   As Long ' число репов

-    total_RM    As Long ' число репов

-    total_BEDS  As Long ' общее число коек

-    total_HIR   As Long '  общее число пациентов на клексане в хирургии

-    total_TER   As Long '  общее число пациентов на клексане в терапии

-    total_ACS   As Long '  общее число пациентов на клексане в кардиологии

-    sale_PLAN   As Long '  план продаж Авентиса

-    objRGN() As tREGION

-End Type

-

-Function GetPRJ_COMM_DATA(ByRef prj_data As tPROJECT) As Integer

-    Dim i As Integer

-    i = GetRGN_COMM_DATA(prj_data.objRGN, 0)

-    GetPRJ_COMM_DATA = i

-    If i > 0 Then

-        With prj_data

-            .sale_PLAN = 0

-            .total_ACS = 0

-            .total_BDGT = 0

-            .total_BDGT_NMG = 0

-            .total_BEDS = 0

-            .total_HIR = 0

-            .total_LPU = 0

-            .total_REP = 0

-            .total_RM = 0

-            .total_SALE = 0

-            .total_TER = 0

-            For i = 1 To UBound(prj_data.objRGN)

-                

-            Next i

-        End With

-    End If

-

-End Function

-

-<<<<<<
-======================
-dbQTR_RM
->>>>>>
-Attribute VB_Name = "dbQTR_RM"

-Option Explicit

-

-Public Type tQTRRM

-    id As Long

-    entry_date As String

-    rm_id As Long

-    sale_PLAN As Long

-End Type

-

-

-Sub Insert_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objQTRRM.id <> 0 Then

-        dbUpdate_QTRRM_Record dbConnection, objQTRRM

-    Else

-        dbInsert_QTRRM_Record dbConnection, objQTRRM

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-Function Get_QTRRM_Record(ent_date As String) As tQTRRM

-    Dim dbConnection As Object

-    Dim allQTRRM() As tQTRRM

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    i = dbGetAll_QTRRM_Records(dbConnection, allQTRRM, ent_date)

-    If i <> 0 Then

-        Get_QTRRM_Record = allQTRRM(1)

-    End If

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTRRM_Records(ByRef all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_QTRRM_Records = dbGetAll_QTRRM_Records(dbConnection, all_QTRRM, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_QTRRM_Record dbConnection, objQTRRM

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objQTRRM.ID <> 0 then updatre else insert

-Sub dbInsert_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "quarter_rm", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objQTRRM

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("sale_plan") = .sale_PLAN

-        dbRecordset("rm_id") = .rm_id

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objQTRRM.id = dbRecordset("id")

-

-End Sub

-

-Sub dbUpdate_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim Update_SQL As String

-    

-    With objQTRRM

-        Update_SQL = "UPDATE quarter_rm SET " & _

-            "entry_date='" & .entry_date & "'" & "," & _

-            "rm_id=" & .rm_id & "," & _

-            "sale_plan=" & .sale_PLAN & "," & _

-            " WHERE id=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if ent_date = % then all_records

-Function dbGetAll_QTRRM_Records(dbConnection As Object, all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    

-    Dim getCount_QTRRM_SQL As String

-    Dim getAll_QTRRM_SQL As String

-    Dim QTRRM_Count As Long

-    QTRRM_Count = 0

-    

-    getCount_QTRRM_SQL = "SELECT COUNT(*) AS QTRRM_TOTAL FROM quarter_rm WHERE entry_date like '" & ent_date & "'"

-    getAll_QTRRM_SQL = "SELECT * FROM quarter_rm WHERE entry_date like '" & ent_date & "' ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTRRM_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTRRM_Count = dbRecordset("QTRRM_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_QTRRM_Records = QTRRM_Count

-    

-    If QTRRM_Count > 0 Then

-        'we have records

-        ReDim all_QTRRM(1 To QTRRM_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTRRM_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTRRM As tQTRRM

-                 With tmp_QTRRM

-                    .entry_date = dbRecordset("entry_date")

-                    .rm_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .id = dbRecordset("id")

-                 End With

-                 

-                 all_QTRRM(index) = tmp_QTRRM

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM quarter_rm " & _

-    "WHERE id=" & objQTRRM.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-    

-    'delete related budget entries

-    MsgBox "remember delete related"

-'    dbDelete_BDGT_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Hir_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Ter_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_ACS_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-       

-End Sub

-

-

-<<<<<<
-======================
-REP_LIST
->>>>>>
-Attribute VB_Name = "REP_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Const LOCAL_ENT_DATE As String = "C10"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-

-Public Function getCurrentREP_ID() As Long

-    Dim r As Range

-

-    With Worksheets("REP_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CREP_ID)

-    End With

-

-    getCurrentREP_ID = r

-End Function

-

-Public Sub REP_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Rep_Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Rep_Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Rep_Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Rep_Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectREP_LPU(rep_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    Range("JUMP") = "LPU_LIST"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-        .Range("RM_ID") = rm_id

-        .setEnt_date (getEnt_date())

-    End With

-End Sub

-

-Public Sub SelectREP_QTR(rep_id As Long)

-    Dim vo As Boolean

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    Range("JUMP") = "REP_QTR"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("REP_QTR")

-        .Range("VIEW_ONLY") = vo

-        .Range("RM_ID") = rm_id

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateREPList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim rep_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CREP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CREP_AREA).row, CREP_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    rep_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CREP_AREA).Column

-    

-    If i < 4 Then

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 1

-    Else

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 2

-    End If

-    

-    If rep_id = 0 Then

-        Range("LAST_FOCUS") = Range(CREP_AREA).address

-    End If

-

-    If rep_id = 0 Then

-        i = CREP_NAME

-        Range("JUMP") = ""

-    Else

-        btREP_LIST_DO_IT

-    End If

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateREPList()

-    Dim rcd() As tREPID_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-

-    ent_date = getEnt_date

-

-    Dim rm_struc As tREGMAN

-    

-    i = Range("RM_ID")

-    rm_struc = Get_REGMAN_Record(i)

-    

-    Range("C4") = rm_struc.LastName

-    Range("C5") = rm_struc.FirstName

-

-    Range("G5") = GetRegionName(rm_struc.Region)

-    

-    i = Get_REP_CommonList_by_QTR(rcd, ent_date, Range("RM_ID"))

-

-    

-    With ThisWorkbook.Worksheets("REP_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(rcd)

-            r.Offset(i - 1, CREP_NAME) = rcd(i).rep.FirstName & " " & rcd(i).rep.LastName

-            r.Offset(i - 1, CREP_ID) = rcd(i).rep.rep_id

-            r.Offset(i - 1, CREP_BEDS) = rcd(i).qtrs(1).c_beds

-

-            r.Offset(i - 1, CREP_NFG) = rcd(i).qtrs(1).c_bdgt_NFG

-            r.Offset(i - 1, CREP_NMG) = rcd(i).qtrs(1).c_bdgt_NMG

-

-            r.Offset(i - 1, CREP_PLAN) = rcd(i).qtrs(1).qtr.sale_PLAN

-

-            r.Offset(i - 1, CREP_HIR) = rcd(i).qtrs(1).c_pat_HIR

-            r.Offset(i - 1, CREP_TER) = rcd(i).qtrs(1).c_pat_TER

-            r.Offset(i - 1, CREP_CAR) = rcd(i).qtrs(1).c_pat_CRD

-            r.Offset(i - 1, CREP_FACT) = rcd(i).qtrs(1).c_sale_ALL

-            r.Offset(i - 1, CREP_PAT_LPU) = rcd(i).qtrs(1).c_pat_LPU

-            r.Offset(i - 1, CREP_BDGT) = rcd(i).qtrs(1).c_bdgt_LPU

-            If rcd(i).qtrs(1).c_bdgt_LPU > 0 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = rcd(i).qtrs(1).c_sale_ALL / rcd(i).qtrs(1).c_bdgt_LPU

-            End If

-            If r.Offset(i - 1, CREP_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-

-

-<<<<<<
-======================
-mREP_LIST
->>>>>>
-Attribute VB_Name = "mREP_LIST"

-Option Explicit

-

-Public Const CREP_AREA As String = "B12"

-Public Const CREP_NAME As Integer = 0

-Public Const CREP_NAME1 As Integer = 1

-Public Const CREP_NAME2 As Integer = 2

-Public Const CREP_ID As Integer = 3

-Public Const CREP_BEDS As Integer = 4

-Public Const CREP_NFG As Integer = 5

-Public Const CREP_NMG As Integer = 6

-Public Const CREP_HIR As Integer = 7

-Public Const CREP_TER As Integer = 8

-Public Const CREP_CAR As Integer = 9

-Public Const CREP_FACT As Integer = 10

-Public Const CREP_PLAN As Integer = 11

-Public Const CREP_PAT_LPU As Integer = 16

-Public Const CREP_BDGT As Integer = 17

-

-

-Const LOCAL_ENT_DATE As String = "C10"

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Sub EditREP(cRep As tREPID, ent_date As String)

-    NoFunc

-End Sub

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("REP_LIST")

-        s = .Range("C5") & " " & .Range("C4") & ", " & .Range("G5") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub Rep_Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_LPU_BBL").Range("title") = MakeChartTitle

-End Sub

-

-Sub Rep_Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CREP_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CREP_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CREP_FACT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PIE").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rep_Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CREP_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CREP_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CREP_HIR + 1)

-            psum = psum + src.Cells(i, CREP_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CREP_TER + 1)

-            psum = psum + src.Cells(i, CREP_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CREP_CAR + 1)

-            psum = psum + src.Cells(i, CREP_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CREP_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rep_Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CREP_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CREP_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CREP_HIR + 1)

-            psum = psum + src.Cells(i, CREP_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CREP_TER + 1)

-            psum = psum + src.Cells(i, CREP_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CREP_CAR + 1)

-            psum = psum + src.Cells(i, CREP_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CREP_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU_A").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub btREP_RET_IT()

-    With Worksheets("REP_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = "RM_QTR"

-    End With

-    Dim str As String

-    str = Range("ret_addr")

-    ThisWorkbook.Worksheets(str).Activate

-End Sub

-

-

-Sub btREP_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim rep_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("REP_LST_DETALS")

-    With Worksheets("REP_LIST")

-        rep_id = .getCurrentREP_ID

-        

-        Select Case i

-            Case 1:

-                .SelectREP_QTR rep_id

-            Case 2:

-                ent_date = .getEnt_date()

-                .SelectREP_LPU rep_id, ent_date

-        End Select

-    End With

-    

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-

-

-

-<<<<<<
-======================
-cdbREP
->>>>>>
-Attribute VB_Name = "cdbREP"

-Option Explicit

-

-Public Type tREPID_COMMON

-    rep As tREPID

-    i_qtrs As Integer

-    qtrs() As tQTR_COMMON

-End Type

-

-Function Get_REP_CommonList_by_QTR(ByRef rcd() As tREPID_COMMON, ent_date As String, rm_id As Long) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_REP_CommonList_by_QTR = dbGet_REP_CommonList_by_QTR(dbConnection, rcd, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_REP_CommonList_by_QTR(dbConnection As Object, ByRef rcd() As tREPID_COMMON, ent_date As String, rm_id As Long) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim k As Long

-    Dim allREPID() As tREPID

-    

-    i = dbGetAll_REPID_Records_by_QTR(dbConnection, allREPID, ent_date, rm_id)

-    dbGet_REP_CommonList_by_QTR = i

-    If i > 0 Then

-        ReDim rcd(i)

-        For i = 1 To UBound(allREPID)

-            rcd(i).rep = allREPID(i)

-            rcd(i).i_qtrs = Get_QTR_CommonList_by_REP(rcd(i).qtrs, ent_date, allREPID(i).rep_id, allREPID(i).rm_id)

-        Next i

-    End If

-End Function

-

-

-

-<<<<<<
-======================
-CHRT_PAT_LPU_A
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU_A"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Пациенты на Клексане(чел.): " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-cdbRegion
->>>>>>
-Attribute VB_Name = "cdbRegion"

-Option Explicit

-

-Type tREGION

-    ent_date As String

-    rm_id As Long

-    total_SALE As Long ' общий объем продаж

-    total_BDGT As Long ' бюджет всех ЛПУ

-    total_BDGT_NMG As Long ' бюджет всех ЛПУ на НМГ

-    total_LPU As Long ' число ЛПУ

-    total_REP   As Long ' число репов

-    total_BEDS As Long ' общее число коек

-    total_HIR As Long '  общее число пациентов на клексане в хирургии

-    total_TER As Long '  общее число пациентов на клексане в терапии

-    total_ACS As Long '  общее число пациентов на клексане в кардиологии

-    sale_PLAN As Long '  план продаж Авентиса

-End Type

-

-Function GetRGN_COMM_DATA(ByRef reg_data() As tREGION, rm_id As Long) As Integer

-    Dim q_date() As String

-    Dim q_count As Integer, i As Integer

-    

-    q_count = getAllQTRNames(q_date, rm_id)

-    If q_count > 0 Then

-        ReDim reg_data(q_count)

-        For i = 1 To q_count

-            Dim current_REP_count As Integer

-            reg_data(i).rm_id = rm_id

-            reg_data(i).ent_date = q_date(i)

-            current_REP_count = getREGION_by_QTR(q_date(i), reg_data(i), rm_id)

-        Next i

-    End If

-    

-    GetRGN_COMM_DATA = q_count

-End Function

-

-' if rm_id = 0 then gets all records

-Function getAllQTRNames(ByRef qtr_lst() As String, rm_id As Long) As Integer

-    

-    Dim sql As String

-    Dim i As Integer

-    Dim db As Object, rs As Object

-    

-    sql = "SELECT DISTINCT entry_date FROM lpu_budget"

-    

-    If rm_id <> 0 Then

-        sql = sql & " WHERE rm_id=" & rm_id

-    End If

-    

-    i = 0

-    

-    dbOpenConnection db

-    Set rs = CreateObject("ADODB.Recordset")

-    

-    rs.Open sql, db

-        

-        If Not rs.BOF Then

-            Do While Not rs.EOF

-                i = i + 1

-                ReDim Preserve qtr_lst(i)

-                qtr_lst(i) = rs("entry_date")

-                rs.MoveNext

-            Loop

-        Else

-            getAllQTRNames = 0

-            Exit Function

-        End If

-    getAllQTRNames = i

-    dbCloseConnection db

-End Function

-

-Function getREGION_by_QTR(ent_date As String, treg As tREGION, rm_id As Long) As Integer

-    Dim rep_count As Integer

-    rep_count = 0

-    

-    Dim reps() As tQTR_COMMON

-    rep_count = Get_QTR_CommonList_by_REP(reps, ent_date, 0, rm_id)

-    

-    treg.ent_date = ent_date

-    treg.total_BDGT = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.total_BDGT_NMG = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.sale_PLAN = 0 ' quarter.sale_plan

-    treg.total_SALE = 0 'summ of

-    ' hir = (amb40+st40)*pr40 + (amb20+st20)*pr20

-    'ter (amb_clx+stat_clx)*price

-    ' acs xxx

-    'price per rep

-    treg.total_HIR = 0 'patiens clxn

-    treg.total_TER = 0 'patiens clxn

-    treg.total_ACS = 0 'patiens clxn

-    treg.total_LPU = 0 'lpu

-    treg.total_BEDS = 0 'lpu.beds

-    treg.total_REP = 0 '

-    

-    If rep_count > 0 Then

-        Dim i As Integer

-        

-        For i = 1 To UBound(reps)

-            ' current rep is reps(i)

-            With reps(i)

-                treg.total_BDGT = treg.total_BDGT + .c_bdgt_NFG + .c_bdgt_NMG

-                treg.total_BDGT_NMG = treg.total_BDGT_NMG + .c_bdgt_NMG

-                treg.sale_PLAN = treg.sale_PLAN + .qtr.sale_PLAN

-                treg.total_SALE = treg.total_SALE + .c_sale_ALL

-                treg.total_HIR = treg.total_HIR + .c_pat_HIR

-                treg.total_TER = treg.total_TER + .c_pat_TER

-                treg.total_ACS = treg.total_ACS + .c_pat_CRD

-                treg.total_LPU = treg.total_LPU + .i_lcd

-                treg.total_BEDS = treg.total_BEDS + .c_beds

-                treg.total_REP = treg.total_REP + 1

-            End With

-            

-        Next i

-        

-    End If

-    

-    getREGION_by_QTR = treg.total_REP

-End Function

-

-<<<<<<
-======================
-mRM_QTR
->>>>>>
-Attribute VB_Name = "mRM_QTR"

-Option Explicit

-

-Sub btRM_QTR_Do_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    Dim i As Integer

-    Dim def_dir As String

-    Dim flist() As String

-    

-    idx = Worksheets(VAR_SHEET).Range("RM_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-'            def_dir = GetWBPath(ThisWorkbook.FullName)

-'            If GetImportDirectory(def_dir, flist) Then

-'                Dim db_list() As String

-'                i = GetDBList(flist, db_list)

-'                If i > 0 Then

-'                    ImportFromRegionalManagers db_list, GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-'                End If

-'            End If

-'            Worksheets(RM_QTR_SHEET).update_history

-        Case 2

-            Worksheets("REP_LIST").Range("ret_addr") = "RM_QTR"

-            Worksheets("REP_LIST").setEnt_date (Worksheets(RM_QTR_SHEET).getEnt_date())

-            Worksheets("REP_LIST").Range("RM_ID") = Worksheets(RM_QTR_SHEET).Range("RM_ID")

-            Worksheets("REP_LIST").Range("VIEW_ONLY") = True

-

-            Worksheets("REP_LIST").Select

-        Case 3

-            MsgBox "Функция не доступна", vbOKOnly, PROGRAM_NAME

-    End Select

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-End Sub

-

-Sub btRM_QTR_RET_IT()

-    Dim str As String

-    str = Range("ret_addr")

-    ThisWorkbook.Worksheets(str).Activate

-End Sub

-

-<<<<<<
-======================
-mImport
->>>>>>
-Attribute VB_Name = "mImport"

-    Option Explicit

-

-Const OFN_ALLOWMULTISELECT As Long = 512

-Const OFN_EXPLORER As Long = 524288

-Const OFN_HIDEREADONLY As Long = 4

-Const OFN_NONETWORKBUTTON As Long = 131072

-Const OFN_READONLY As Long = 1

-       

-Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _

-    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

-

-Private Type OPENFILENAME

-    lStructSize As Long

-    hWndOwner As Long

-    hInstance As Long

-    lpstrFilter As String

-    lpstrCustomFilter As String

-    nMaxCustFilter As Long

-    nFilterIndex As Long

-    lpstrFile As String

-    nMaxFile As Long

-    lpstrFileTitle As String

-    nMaxFileTitle As Long

-    lpstrInitialDir As String

-    lpstrTitle As String

-    flags As Long

-    nFileOffset As Integer

-    nFileExtension As Integer

-    lpstrDefExt As String

-    lCustData As Long

-    lpfnHook As Long

-    lpTemplateName As String

-End Type

-

-Function GetImportDirectory(DB_dir As String, flist() As String) As Boolean

-    Dim OpenFile As OPENFILENAME

-    Dim lReturn As Long

-    Dim sFilter As String

-    

-    OpenFile.lStructSize = Len(OpenFile)

-    '         OpenFile.hwndOwner = Form1.hWnd

-    '         OpenFile.hInstance = App.hInstance

-    sFilter = "Clexane Data Files" & Chr(0) & PROGRAM_IMPORTNAME & PROGRAM_DATAEXT & Chr(0)

-    OpenFile.lpstrFilter = sFilter

-    OpenFile.nFilterIndex = 1

-    OpenFile.lpstrFile = String(257, 0)

-    OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1

-    OpenFile.lpstrFileTitle = OpenFile.lpstrFile

-    OpenFile.nMaxFileTitle = OpenFile.nMaxFile

-    OpenFile.lpstrInitialDir = DB_dir

-    OpenFile.lpstrTitle = "Импорт данных"

-    OpenFile.flags = OFN_HIDEREADONLY + OFN_EXPLORER

-    lReturn = GetOpenFileName(OpenFile)

-    If lReturn = 0 Then

-        GetImportDirectory = False

-    Else

-        GetImportDirectory = True

- 

-        flist = Split(OpenFile.lpstrFile, Chr(0), Compare:=vbBinaryCompare)

-        Dim i As Integer

-        i = 0

-        Do While flist(i) <> ""

-            i = i + 1

-        Loop

-        If i = 1 Then

-            flist(1) = flist(0)

-            flist(0) = GetWBPath(flist(1))

-            flist(1) = GetWBName(flist(1))

-        Else

-            flist(0) = flist(0) & "\"

-        End If

-    End If

-End Function

-<<<<<<
-======================
-cPPReport
->>>>>>
-Attribute VB_Name = "cPPReport"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Const PPR_NON As Integer = 0

-Const PPR_NEW As Integer = 1

-Const PPR_OLD As Integer = 2

-

-Dim ReportApp As PowerPoint.Application

-Dim ReportDoc As PowerPoint.Presentation

-Dim ReportState As Integer

-Dim PowerPointPath As String

-

-Private Sub Class_Initialize()

-    Set ReportApp = CreateObject("PowerPoint.Application")

-    PowerPointPath = ReportApp.Path & "\PowerPNT.EXE"

-    ReportState = PPR_NON

-End Sub

-

-Sub OpenReport(FileName As String)

-    If ReportState <> PPR_NON Then

-        SaveReport

-    End If

-    Set ReportDoc = GetObject(FileName)

-    ReportState = PPR_OLD

-End Sub

-

-Sub CreateReport()

-    If ReportState <> PPR_NON Then

-        SaveReport

-    End If

-    Set ReportDoc = ReportApp.Presentations.Add

-    ReportState = PPR_NEW

-End Sub

-

-Sub SaveReport()

-    Select Case ReportState

-        Case PPR_NEW

-            ReportDoc.SaveAs GetWBPath(ThisWorkbook.FullName) + PROGRAM_FILENAME

-        Case PPR_OLD

-            ReportDoc.Save

-    End Select

-    ReportState = PPR_NON

-End Sub

-

-Sub ReportView()

-    Dim CmdName As String

-    CmdName = GetWBPath(ThisWorkbook.FullName) + PROGRAM_FILENAME + ".PPT"

-    CmdName = PowerPointPath & " " & CmdName

-    Shell CmdName, 1

-End Sub

-

-Sub InsertSlide()

-    Dim ReportPage As PowerPoint.Slide

-    Set ReportPage = ReportDoc.Slides.Add(ReportDoc.Slides.count + 1, ppLayoutBlank)

-    

-    ReportPage.Shapes.Paste

-    ReportPage.Shapes.AddLabel(msoTextOrientationHorizontal, 20, 20, 640, 40) _

-      .TextFrame.TextRange.Text = "Slide #" & Format(ReportDoc.Slides.count)

-End Sub

-

-

-Private Sub Class_Terminate()

-    SaveReport

-    ReportApp.Quit

-End Sub

-<<<<<<
-======================
-dlgImprtDB
->>>>>>
-Attribute VB_Name = "dlgImprtDB"

-Attribute VB_Base = "0{36355920-F7A4-44A8-96EF-5D79CF26137D}{F852BDF2-AB3E-468E-89DF-EC5DC0C7C88B}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Private Sub btSelAll_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = True

-    Next i

-End Sub

-

-Private Sub btUnselect_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = False

-    Next i

-End Sub

-<<<<<<
-======================
-rmImport
->>>>>>
-Attribute VB_Name = "rmImport"

-Option Explicit

-

-Public Type dbDESCRIPTION

-    Name As String

-    Fields() As String

-End Type

-

-Sub ImportFromRegionalManagers(rm_files() As String, fm_file As String)

-    Dim db(9) As dbDESCRIPTION

-    

-    '''''data

-    db(1).Name = "rep"

-    

-    db(2).Name = "lpu"

-    db(3).Name = "lpu_acs"

-    db(4).Name = "lpu_budget"

-    db(5).Name = "lpu_hir"

-    db(6).Name = "lpu_im"

-    db(7).Name = "lpu_ter"

-    db(8).Name = "quarter"

-    db(9).Name = "quarter_rm"

-    

-    ReDim db(1).Fields(5)

-    With db(1)

-        .Fields(1) = "rep_id"

-        .Fields(2) = "firstname"

-        .Fields(3) = "lastname"

-        .Fields(4) = "region"

-        .Fields(5) = "city"

-    End With

-    

-    ReDim db(2).Fields(5)

-    With db(2)

-        .Fields(1) = "id"

-        .Fields(2) = "rep_id"

-        .Fields(3) = "name"

-        .Fields(4) = "address"

-        .Fields(5) = "beds"

-    End With

-    

-    ReDim db(3).Fields(7)

-    With db(3)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "patients_with_geparins"

-        .Fields(5) = "patients_per_quarter"

-        .Fields(6) = "patients_stationar_nmg"

-        .Fields(7) = "patients_stationar_clexan"

-    End With

-    

-    ReDim db(4).Fields(6)

-    With db(4)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "bdgt_NMG"

-        .Fields(5) = "bdgt_NFG"

-        .Fields(6) = "sale_PLAN"

-    End With

-    

-    ReDim db(5).Fields(15)

-    With db(5)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "operations_per_quarter"

-        .Fields(5) = "risk_percent"

-        .Fields(6) = "patients_with_risk_ON"

-        .Fields(7) = "patients_ambulator"

-        .Fields(8) = "patients_ambulator_nmg"

-        .Fields(9) = "patients_ambulator_clexan"

-        .Fields(10) = "patients_ambulator_clexan_40mg"

-        .Fields(11) = "patients_ambulator_clexan_20mg"

-        .Fields(12) = "patients_stationar_nmg"

-        .Fields(13) = "patients_stationar_clexan"

-        .Fields(14) = "patients_stationar_clexan_40mg"

-        .Fields(15) = "patients_stationar_clexan_20mg"

-    End With

-    

-    

-    ReDim db(6).Fields(7)

-    With db(6)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "patients_with_geparins"

-        .Fields(5) = "patients_per_quarter"

-        .Fields(6) = "patients_stationar_nmg"

-        .Fields(7) = "patients_stationar_clexan"

-    End With

-    

-    ReDim db(7).Fields(11)

-    With db(7)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "patients_per_quarter"

-        .Fields(5) = "risk_percent"

-        .Fields(6) = "patients_with_risk_ON"

-        .Fields(7) = "patients_ambulator"

-        .Fields(8) = "patients_ambulator_nmg"

-        .Fields(9) = "patients_ambulator_clexan"

-        .Fields(10) = "patients_stationar_nmg"

-        .Fields(11) = "patients_stationar_clexan"

-    End With

-    

-    ReDim db(8).Fields(9)

-    With db(8)

-        .Fields(1) = "ID"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "rep_id"

-        .Fields(4) = "sale_plan"

-        .Fields(5) = "ClxnH20mg"

-        .Fields(6) = "ClxnH40mg"

-        .Fields(7) = "ClxnT40mg"

-        .Fields(8) = "ClxnC_IM"

-        .Fields(9) = "ClxnC_ACS"

-    End With

-    

-    ReDim db(9).Fields(3)

-    With db(9)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "sale_plan"

-    End With

-    

-    Dim rm_idx As Integer

-    Dim to_db As Object

-    'back uo

-    Merge_BackUp_All_Data

-    

-    'clean up

-    Merge_Clear_All_Data fm_file

-    

-    Set to_db = dbGetConnection(fm_file)

-    

-    For rm_idx = 1 To UBound(rm_files)

-        Dim from_db As Object

-        

-        Set from_db = dbGetConnection(rm_files(rm_idx))

-        

-        Dim new_rm_id As Long

-        new_rm_id = dbMergeRM(from_db, to_db)

-

-        Dim i As Integer

-

-        For i = 1 To UBound(db)

-            Dim get_sql As String

-            Dim getRS As Object

-            Dim insRS As Object

-            Dim field_idx As Integer

-                        

-            get_sql = "SELECT * FROM " & db(i).Name

-            Set getRS = CreateObject("ADODB.Recordset")

-            Set insRS = CreateObject("ADODB.Recordset")

-            insRS.Open db(i).Name, to_db, 2, 2

-

-            getRS.Open get_sql, from_db

-            

-            If Not getRS.BOF Then

-                Do While Not getRS.EOF

-                    insRS.addnew

-                    Dim fld_name As String

-                    

-                    For field_idx = 1 To UBound(db(i).Fields)

-                        fld_name = db(i).Fields(field_idx)

-                        insRS(fld_name) = getRS(fld_name)

-                    Next field_idx

-                    

-                    insRS("rm_id") = new_rm_id

-                    insRS.Update

-                    getRS.MoveNext

-                Loop

-            

-            Else

-                'empty table

-                ' do nothing

-            End If

-            

-            

-        Next i

-        

-        dbCloseOpenedConnection from_db

-    Next rm_idx

-    

-    dbCloseOpenedConnection to_db

-End Sub

-

-Function dbMergeRM(from_dbConnection As Object, to_dbConnection As Object) As Long

-

-    Dim getRecordset As Object

-    Dim getREPData_SQL As String

-    Dim REP_fn As String

-    Dim REP_ln As String

-    Dim REP_region As String

-    Dim REP_city As String

-

-

-    getREPData_SQL = "SELECT * FROM reg_man"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getREPData_SQL, from_dbConnection

-        

-        If Not getRecordset.BOF Then

-            REP_fn = getRecordset("firstname")

-            REP_ln = getRecordset("lastname")

-            REP_city = getRecordset("city")

-            REP_region = getRecordset("region")

-        Else

-            MsgBox "There is no information about Regional Manager! This database cannot be merged!!!"

-            dbMergeRM = -1

-            Exit Function

-        End If

-    

-    Dim insertRecordset As Object

-    Set insertRecordset = CreateObject("ADODB.Recordset")

-        

-    insertRecordset.Open "reg_man", to_dbConnection, 2, 2

-    insertRecordset.addnew

-        

-    insertRecordset("firstname") = REP_fn

-    insertRecordset("lastname") = REP_ln

-    insertRecordset("region") = REP_region

-    insertRecordset("city") = REP_city

-    insertRecordset.Update

-    insertRecordset.MoveLast

-    'new ID

-    dbMergeRM = insertRecordset("mgr_id")

-    

-End Function

-

-Sub cmDataImport()

-    Dim def_dir As String

-    Dim flist() As String

-    Dim i As Integer

-

-    def_dir = GetWBPath(ThisWorkbook.FullName)

-    If GetImportDirectory(def_dir, flist) Then

-        Dim ImpMask() As String

-        ImpMask = Split(flist(1), Chr(95), Compare:=vbBinaryCompare)

-        flist(1) = ImpMask(0) & "*"

-        Dim db_list() As String

-        i = GetDBList(flist(), db_list)

-        

-        If i > 0 Then

-            ImportFromRegionalManagers db_list, GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-        End If

-    End If

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).Select

-End Sub

-

-

-<<<<<<
-======================
-PRJ_QTR
->>>>>>
-Attribute VB_Name = "PRJ_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CPRJ_QT As Integer = 0

-Const CPRJ_ID As Integer = 1

-Const CPRJ_PLN As Integer = 2

-Const CPRJ_FCT As Integer = 3

-Const CPRJ_BDG As Integer = 4

-Const CPRJ_CNT As Integer = 5

-Const CPRJ_BEDS As Integer = 6

-Const CPRJ_HIR As Integer = 7

-Const CPRJ_TER As Integer = 8

-Const CPRJ_CRD As Integer = 9

-Const CPRJ_CLXN_BDG As Integer = 10

-Const CPRJ_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Const LOCAL_ENT_DATE As String = "B11"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("PRJ_QTR")

-        s = "Все регионы, " & .getEnt_date()

-    End With

-    

-    MakeChartTitle = s

-End Function

-

-Sub update_history()

-    Dim objQTR() As tREGION

-    Dim i As Long

-    Dim r As Range

-

-

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetRGN_COMM_DATA(objQTR(), 0)

-    

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CPRJ_QT) = objQTR(i).ent_date

-            r.Offset(i - 1, CPRJ_ID) = ""

-            r.Offset(i - 1, CPRJ_PLN) = objQTR(i).sale_PLAN

-            r.Offset(i - 1, CPRJ_FCT) = objQTR(i).total_SALE

-            r.Offset(i - 1, CPRJ_BDG) = objQTR(i).total_BDGT

-            r.Offset(i - 1, CPRJ_CNT) = objQTR(i).total_LPU

-            r.Offset(i - 1, CPRJ_BEDS) = objQTR(i).total_REP

-            r.Offset(i - 1, CPRJ_HIR) = objQTR(i).total_HIR

-            r.Offset(i - 1, CPRJ_TER) = objQTR(i).total_TER

-            r.Offset(i - 1, CPRJ_CRD) = objQTR(i).total_ACS

-            If objQTR(i).total_BDGT <> 0 Then

-                r.Offset(i - 1, CPRJ_CLXN_BDG) = objQTR(i).total_SALE / objQTR(i).total_BDGT

-            End If

-            If objQTR(i).total_BDGT_NMG <> 0 Then

-                r.Offset(i - 1, CPRJ_CLXN_NMG) = objQTR(i).total_SALE / objQTR(i).total_BDGT_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR_PRJ()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(PRJ_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CPRJ_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CPRJ_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CPRJ_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CPRJ_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CPRJ_CRD + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-

-Sub Draw_PLN_QTR_PRJ()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(PRJ_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CPRJ_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CPRJ_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CPRJ_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CPRJ_FCT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PLN_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Draw_BDGT_QTR_PRJ()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(PRJ_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CPRJ_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CPRJ_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CPRJ_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CPRJ_CLXN_NMG + 1)

-        End If

-    Next i

-    Worksheets("CHRT_BDGT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-Public Sub cbxPRJ_QtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR_PRJ

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR_PRJ

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR_PRJ

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = PRJ_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    Protect UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CPRJ_QT + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    If r = "" Then

-        Worksheets(VAR_SHEET).Range("PRJ_ACTION") = 2

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        Worksheets(VAR_SHEET).Range("PRJ_ACTION") = 2

-        Range("LAST_FOCUS") = currRange.address

-        With Worksheets("REP_LIST")

-            .Range("ret_addr") = "PRJ_QTR"

-            .Range("ent_date") = r

-            .Range("VIEW_ONLY") = True

-        End With

-    End If

-    Cancel = True

-    btPRJ_QTR_Do_IT ' old btRM_OTR_DO_IT

-End Sub

-

-<<<<<<
-======================
-RM_LIST
->>>>>>
-Attribute VB_Name = "RM_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Const LOCAL_ENT_DATE As String = "C10"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-

-Public Function getCurrentRM_ID() As Long

-    Dim r As Range

-

-    With Worksheets("RM_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CRM_ID)

-    End With

-

-    getCurrentRM_ID = r

-End Function

-

-Public Sub RM_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("PM_CHR_IDX")

-        Case 1

-            Rm_Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Rm_Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Rm_Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-

-        Case 4

-            Rm_Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectRM_QTR(rm_id As Long)

-    Dim vo As Boolean

-

-    Range("JUMP") = "RM_QTR"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("RM_QTR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "RM_LIST"

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Public Sub SelectREP_LIST(rm_id As Long)

-    Dim vo As Boolean

-

-    Range("JUMP") = "REP_LIST"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("REP_LIST")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "RM_LIST"

-        .setEnt_date (getEnt_date())

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateRMList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Sub UpdateRMList()

-    Dim rmcd() As tRMID_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-

-    ent_date = getEnt_date

-

-    i = Get_RM_CommonList_by_QTR(rmcd(), ent_date)

-

-    With ThisWorkbook.Worksheets("RM_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(rmcd)

-            r.Offset(i - 1, CRM_NAME) = GetRegionName(rmcd(i).rm.Region)

-            r.Offset(i - 1, CRM_ID) = rmcd(i).rm.rm_id

-            r.Offset(i - 1, CRM_BEDS) = rmcd(i).rgcd(1).total_BEDS

-            r.Offset(i - 1, CRM_BDGT) = rmcd(i).rgcd(1).total_BDGT

-            r.Offset(i - 1, CRM_NMG) = rmcd(i).rgcd(1).total_BDGT_NMG

-            r.Offset(i - 1, CRM_HIR) = rmcd(i).rgcd(1).total_HIR

-            r.Offset(i - 1, CRM_TER) = rmcd(i).rgcd(1).total_TER

-            r.Offset(i - 1, CRM_CAR) = rmcd(i).rgcd(1).total_ACS

-            r.Offset(i - 1, CRM_FACT) = rmcd(i).rgcd(1).total_SALE

-            r.Offset(i - 1, CRM_PLAN) = rmcd(i).rgcd(1).sale_PLAN

-            

-            With rmcd(i).rgcd(1)

-                r.Offset(i - 1, CRM_PAT_LPU) = .total_HIR + .total_TER + .total_ACS

-            End With

-            

-            r.Offset(i - 1, CRM_BDGT_1) = rmcd(i).rgcd(1).total_BDGT

-            If rmcd(i).rgcd(1).total_BDGT > 0 Then

-                r.Offset(i - 1, CRM_BDGT_1 + 1) = rmcd(i).rgcd(1).total_SALE / rmcd(i).rgcd(1).total_BDGT

-            End If

-            If r.Offset(i - 1, CRM_BDGT_1 + 1) > 1 Then

-                r.Offset(i - 1, CRM_BDGT_1 + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim rep_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CRM_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CRM_AREA).row, CRM_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    rep_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CRM_AREA).Column

-

-    If i < 4 Then

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 1

-    Else

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 2

-    End If

-

-    If rep_id = 0 Then

-        Range("LAST_FOCUS") = Range(CRM_AREA).address

-    End If

-

-    If rep_id = 0 Then

-        i = CRM_NAME

-        Range("JUMP") = ""

-    Else

-        btRM_LIST_DO_IT

-    End If

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-<<<<<<
-======================
-mPRJ_QTR
->>>>>>
-Attribute VB_Name = "mPRJ_QTR"

-Sub btPRJ_QTR_Do_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    

-    idx = Worksheets(VAR_SHEET).Range("PRJ_ACTION")

-    ent_date = Worksheets(PRJ_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            cmDataImport

-        Case 2

-            Worksheets("RM_LIST").setEnt_date (Worksheets("PRJ_QTR").getEnt_date())

-            Worksheets("RM_LIST").Range("ret_addr") = "PRJ_QTR"

-            Worksheets("RM_LIST").Select

-        Case 3

-            cmNewReport

-    End Select

-    Worksheets(VAR_SHEET).Range("PRJ_ACTION") = 2

-End Sub

-

-

-<<<<<<
-======================
-mRM_LIST
->>>>>>
-Attribute VB_Name = "mRM_LIST"

-Option Explicit

-

-Public Const CRM_AREA As String = "B12"

-Public Const CRM_NAME As Integer = 0

-Public Const CRM_NAME1 As Integer = 1

-Public Const CRM_NAME2 As Integer = 2

-Public Const CRM_ID As Integer = 3

-Public Const CRM_BEDS As Integer = 4

-Public Const CRM_BDGT As Integer = 5

-Public Const CRM_NMG As Integer = 6

-Public Const CRM_HIR As Integer = 7

-Public Const CRM_TER As Integer = 8

-Public Const CRM_CAR As Integer = 9

-Public Const CRM_FACT As Integer = 10

-Public Const CRM_PLAN As Integer = 11

-Public Const CRM_PAT_LPU As Integer = 16

-Public Const CRM_BDGT_1 As Integer = 17

-

-

-Const LOCAL_ENT_DATE As String = "C10"

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Sub EditREP(CRM As tREPID, ent_date As String)

-    NoFunc

-End Sub

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("RM_LIST")

-        s = "Регионы, " & .getEnt_date()

-    End With

-    

-    MakeChartTitle = s

-End Function

-

-Sub Rm_Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_LPU_BBL").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rm_Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRM_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRM_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRM_FACT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PIE").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rm_Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CRM_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRM_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRM_HIR + 1)

-            psum = psum + src.Cells(i, CRM_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRM_TER + 1)

-            psum = psum + src.Cells(i, CRM_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRM_CAR + 1)

-            psum = psum + src.Cells(i, CRM_CAR + 1)

-            dst.Cells(i, 5) = psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU").Range("title") = MakeChartTitle

-    

-End Sub

-

-Sub Rm_Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CRM_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRM_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRM_HIR + 1)

-            psum = psum + src.Cells(i, CRM_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRM_TER + 1)

-            psum = psum + src.Cells(i, CRM_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRM_CAR + 1)

-            psum = psum + src.Cells(i, CRM_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CRM_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU_A").Range("title") = MakeChartTitle

-    

-End Sub

-

-Sub btRM_LIST_RET_IT()

-    With Worksheets("RM_LIST")

-        .setEnt_date ("")

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = "PRJ_QTR"

-    End With

-    ThisWorkbook.Worksheets("PRJ_QTR").Activate

-End Sub

-

-

-Sub btRM_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim rm_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("RM_LIST_ACTION")

-    With Worksheets("RM_LIST")

-        rm_id = .getCurrentRM_ID()

-        

-        Select Case i

-            Case 1:

-                .SelectRM_QTR rm_id

-            Case 2:

-                .SelectREP_LIST rm_id

-            End Select

-    End With

-    

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-

-

-

-

-<<<<<<
-Project Name : 'ClexaneMR'
-Quirk - duff tag length======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).ClearRepName

-    

-    Application.EnableEvents = True

-    Set MyAppEvents.app = Application

-    

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    

-    MyAppEvents.CheckWorkBooksArround ThisWorkbook

-    

-    cmSetStandaloneMode

-    

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-    

-    Application.ScreenUpdating = True

-    

-    If CheckUser Then

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-        ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-        ThisWorkbook.Worksheets(REP_QTR_SHEET).update_history

-        Application.Calculate

-    End If

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    

-    Dim RestMode As Boolean

-    RestMode = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE")

-    

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-'        If RestMode Then

-            ThisWorkbook.Saved = True

-'        Else

-'            ThisWorkbook.Save

-'        End If

-    End If

-    If RestMode Then

-        xlRestoreView

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    End If

-    Application.Caption = Empty

-    Application.CommandBars(STDBAR_NAME).Reset

-    

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-    Dim MaxX, MaxY As Integer

-    With ThisWorkbook.Worksheets(REP_QTR_SHEET)

-        MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-        MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-    End With

-

-    With ThisWorkbook.Application

-        .ScreenUpdating = False

-        .WindowState = xlNormal

-        .Height = MaxY

-        .Width = MaxX

-    End With

-End Sub

-

-

-

-

-

-<<<<<<
-======================
-REP_QTR
->>>>>>
-Attribute VB_Name = "REP_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CQTR_QT As Integer = 0

-Const CQTR_ID As Integer = 1

-Const CQTR_PLN As Integer = 2

-Const CQTR_FCT As Integer = 3

-Const CQTR_BDG As Integer = 4

-Const CQTR_CNT As Integer = 5

-Const CQTR_BEDS As Integer = 6

-Const CQTR_HIR As Integer = 7

-Const CQTR_TER As Integer = 8

-Const CQTR_CRD As Integer = 9

-Const CQTR_CLXN_BDG As Integer = 10

-Const CQTR_CLXN_NMG As Integer = 11

-Const CQTR_PAT_ALL As Integer = 16

-Const CQTR_BDGT_ALL As Integer = 17

-

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub ClearRepName()

-    Unprotect

-    Range("D4") = ""

-    Range("D5") = ""

-    Range("H4") = ""

-    Range("H5") = ""

-End Sub

-

-Sub update_history()

-    Dim objQTR() As tQTR

-    Dim i As Long

-    Dim r As Range

-    Dim cRep As tREP

-    

-    cRep = GetREPRecord

-    Range("D4") = cRep.LastName

-    Range("D5") = cRep.FirstName

-    

-    Range("H4") = GetRegionName(cRep.Region)

-    Range("H5") = GetCityName(cRep.Region, cRep.City)

-    

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    i = GetAll_QTR_Records(objQTR, "%")

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CQTR_QT) = objQTR(i).entry_date

-        Next i

-    End If

-    Dim qcd() As tQTR_COMMON

-    i = Get_QTR_CommonList(qcd)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(qcd)

-            r.Offset(i - 1, CQTR_QT) = qcd(i).qtr.entry_date

-            r.Offset(i - 1, CQTR_ID) = qcd(i).qtr.id

-            r.Offset(i - 1, CQTR_PLN) = qcd(i).qtr.sale_plan

-            r.Offset(i - 1, CQTR_FCT) = qcd(i).c_sale_ALL

-            r.Offset(i - 1, CQTR_BDG) = qcd(i).c_bdgt_LPU

-            r.Offset(i - 1, CQTR_CNT) = qcd(i).i_lcd

-            r.Offset(i - 1, CQTR_BEDS) = qcd(i).c_beds

-            r.Offset(i - 1, CQTR_HIR) = qcd(i).c_pat_HIR

-            r.Offset(i - 1, CQTR_TER) = qcd(i).c_pat_TER

-            r.Offset(i - 1, CQTR_CRD) = qcd(i).c_pat_CRD

-            If qcd(i).c_bdgt_LPU <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_BDG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_LPU

-            End If

-            If qcd(i).c_bdgt_NMG <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_NMG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_BBL_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-

-End Sub

-

-Sub Draw_PAT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CQTR_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRepQtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-

-Private Sub Worksheet_Activate()

-  

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-    

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.Count > 1 And r_sel.Columns.Count < CRow_Width Or r_sel.Rows.Count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.Count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.Count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.Count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CQTR_ID + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    i = currRange.Column - Range(CINP_AREA).Column

-    

-    QTR_ID = r

-

-    If QTR_ID = 0 Then

-        Worksheets(VAR_SHEET).Range("USER_ACTION") = 1

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        If i > CQTR_FCT Then

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-            Range("LAST_FOCUS") = currRange.address

-        Else

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 3

-            Range("LAST_FOCUS") = currRange.address

-        End If

-    End If

-    Cancel = True

-    btHomeDo_IT

-End Sub

-

-<<<<<<
-======================
-mRep_QTR
->>>>>>
-Attribute VB_Name = "mRep_QTR"

-Option Explicit

-

-Sub DO_New_qtr()

-    Dim res As Variant

-    Dim objQTR As tQTR

-    Dim s As String

-    s = GetLastQtr

-    objQTR.entry_date = GetNextQTR(s)

-    

-    If objQTR.entry_date = "" Then

-        Exit Sub

-    End If

-    

-    DO_Price_qtr objQTR.entry_date

-

-End Sub

-

-Sub DO_Price_qtr(ent_date As String)

-    If ent_date = "" Then

-        DO_New_qtr

-    Else

-        Dim qtr As tQTR

-        Dim res As Integer

-        

-        qtr = Get_QTR_Record(ent_date)

-        

-        If qtr.id = 0 Then

-            qtr.entry_date = ent_date

-    

-            With Worksheets(VAR_SHEET)

-                qtr.ClxnH20mg = .Range("ClxnH20mg")

-                qtr.ClxnH40mg = .Range("ClxnH40mg")

-                qtr.ClxnT40mg = .Range("ClxnT40mg")

-                qtr.ClxnC_ACS = .Range("ClxnC_ACS")

-                qtr.ClxnC_IM = .Range("ClxnC_IM")

-            End With

-        End If

-        

-        Dim dlg_nq As dlg_nextQTR

-        Set dlg_nq = New dlg_nextQTR

-        

-        With dlg_nq

-            .tb_qtr_name = qtr.entry_date

-            .tb_bdgt_avts = qtr.sale_plan

-            .tb_qtr_name = qtr.entry_date

-            .tb_ClxnH20mg = qtr.ClxnH20mg

-            .tb_ClxnH40mg = qtr.ClxnH40mg

-            .tb_ClxnT40mg = qtr.ClxnT40mg

-            .tb_ClxnC_ACS = qtr.ClxnC_ACS

-            .tb_ClxnC_IM = qtr.ClxnC_IM

-        End With

-        

-        dlg_nq.Show

-        res = dlg_nq.Tag

-        

-        If res = vbOK Then

-            With dlg_nq

-                If Not IsNumeric(.tb_bdgt_avts) Then

-                    MsgBox "Введите план продаж", vbOK, PROGRAM_NAME

-                Else

-                    If .tb_bdgt_avts = 0 Then

-                        MsgBox "Введите план продаж", vbOK, PROGRAM_NAME

-                        Exit Sub

-                    End If

-                End If

-                Dim bool As Boolean

-                bool = IsNumeric(.tb_ClxnH20mg) _

-                    And IsNumeric(.tb_ClxnH40mg) _

-                    And IsNumeric(.tb_ClxnT40mg) _

-                    And IsNumeric(.tb_ClxnC_ACS) _

-                    And IsNumeric(.tb_ClxnC_IM)

-                If Not bool Then

-                    MsgBox "Вводите правильно цыфры", vbOK, PROGRAM_NAME

-                    Exit Sub

-                End If

-                qtr.sale_plan = .tb_bdgt_avts

-                qtr.entry_date = .tb_qtr_name

-                qtr.ClxnH20mg = .tb_ClxnH20mg

-                qtr.ClxnH40mg = .tb_ClxnH40mg

-                qtr.ClxnT40mg = .tb_ClxnT40mg

-                qtr.ClxnC_ACS = .tb_ClxnC_ACS

-                qtr.ClxnC_IM = .tb_ClxnC_IM

-            End With

-            Insert_QTR_Record qtr

-        End If

-    End If

-End Sub

-

-Sub DO_Edit_qtr(ent_date As String)

-    If ent_date = "" Then

-        DO_New_qtr

-    Else

-        With ThisWorkbook.Worksheets("LPU_LIST")

-            .Range("VIEW_ONLY") = False

-            .Range("ent_date") = ent_date

-            .Select

-        End With

-    End If

-End Sub

-

-Sub DO_Delete_qtr(ent_date As String)

-    If ent_date <> "" Then

-        Dim i As Integer

-        i = MsgBox("Удалить данные за период [" & ent_date & "]?", vbDefaultButton2 + vbOKCancel, PROGRAM_NAME)

-        If i = vbOK Then

-            Dim objQTR As tQTR

-            If ent_date <> "" Then

-                objQTR.entry_date = ent_date

-                objQTR = Get_QTR_Record(ent_date)

-                Delete_QTR_Record objQTR

-                Worksheets(TITLE_SHEET).Select

-                Worksheets(REP_QTR_SHEET).Select

-            End If

-        End If

-    End If

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-

-Sub btHomeDo_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    idx = Worksheets(VAR_SHEET).Range("USER_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            DO_New_qtr

-            ' Обновляем экран

-        Case 2

-            DO_Edit_qtr ent_date

-        Case 3

-            DO_Price_qtr ent_date

-        Case 4

-            dbExport

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    End Select

-    If idx <> 2 Then

-        With ThisWorkbook

-            .Worksheets(TITLE_SHEET).Select

-            .Worksheets(REP_QTR_SHEET).Select

-        End With

-    End If

-End Sub

-

-Sub Delete_qtr()

-    Dim ent_date As String

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    DO_Delete_qtr ent_date

-End Sub

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane[MR]"

-Public Const PROGRAM_VERSION As String = "version 1.6"

-Public Const PROGRAM_FILENAME As String = "clexane-mr"

-Public Const PROGRAM_EXPORTNAME As String = "mr-ex-"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20030329

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "O40"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-End Sub

-

-Function Double2Str(ByVal d As Double, ByVal precision As Integer, Optional Delim As String = ".") As String

-    Dim s As String

-    If Not precision > 0 Then

-        s = Round(d)

-    Else

-        Dim i As Integer

-        i = Fix(d)

-        s = i & Delim

-        d = Abs(d - i)

-        Do

-            precision = precision - 1

-            d = d * 10

-            If precision > 0 Then

-                i = Fix(d)

-            Else

-                i = Round(d)

-            End If

-            If i < 1 Then

-                s = s & "0"

-            Else

-                s = s & i

-                d = d - i

-            End If

-        Loop While precision > 0

-    End If

-    Double2Str = s

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.Count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.name = VAR_SHEET Or sh.name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-<<<<<<
-======================
-Var
->>>>>>
-Attribute VB_Name = "Var"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-title
->>>>>>
-Attribute VB_Name = "title"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LPU_LIST
->>>>>>
-Attribute VB_Name = "LPU_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentLPU_ID() As Long

-    Dim r As Range

-    

-    With Worksheets("LPU_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CLPU_ID)

-    End With

-    

-    getCurrentLPU_ID = r

-End Function

-

-Public Sub LPU_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectLPU_NAME(lpu_id As Long, ent_date As String)

-    If Range("VIEW_ONLY") = True Then

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    Dim cLPU As tLPU

-    If lpu_id = 0 Then

-        cLPU.id = 0

-        cLPU.rep_id = 0

-        cLPU.address = ""

-        cLPU.name = ""

-    Else

-        cLPU = Get_LPU_Record(lpu_id)

-    End If

-    EditLPU cLPU, getEnt_date

-    Worksheet_Activate

-End Sub

-        

-Sub SelectLPU_BDGT(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    If lpu_id = 0 Then

-        SelectLPU_NAME lpu_id, ent_date

-    Else

-        With ThisWorkbook.Worksheets("LPU_BDGT")

-            .Range("VIEW_ONLY") = vo

-            .Range("ret_addr") = "LPU_LIST"

-            .Range("ent_date") = ent_date

-            .Range("lpu_id") = lpu_id

-        End With

-    End If

-End Sub

-

-Sub SelectLPU_HIR(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_CLSN_HIR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-                   

-Sub SelectLPU_TER(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_CLSN_TER")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-       

-Sub SelectLPU_C_ACS(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_CLSN_C_ACS")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateLPUList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.Count > 1 And r_sel.Columns.Count < CINP_WIDTH Or r_sel.Rows.Count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.Count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.Count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.Count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim lpu_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-    

-    ent_date = getEnt_date

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-    

-    Set r = Range(CINP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CINP_AREA).row, CLPU_ID)

-        

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-    

-    lpu_id = r

-    

-    i = Range(Range("LAST_FOCUS")).Column - Range(CINP_AREA).Column

-    

-    If lpu_id = 0 Then

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    End If

-    

-    If lpu_id = 0 Then

-        i = CLPU_NAME

-        Range("JUMP") = ""

-    End If

-    Select Case i

-        Case CLPU_NAME, CLPU_NAME1, CLPU_NAME2, CLPU_BEDS

-            SelectLPU_NAME lpu_id, ent_date

-            Range("JUMP") = ""

-

-        Case CLPU_NMG, CLPU_NFG, CLPU_PLAN, CLPU_FACT

-            SelectLPU_BDGT lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-            

-        Case CLPU_HIR

-            SelectLPU_HIR lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_HIR"

-        

-        Case CLPU_TER

-            SelectLPU_TER lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_TER"

-        

-        Case CLPU_CAR

-            SelectLPU_C_ACS lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_C_ACS"

-        

-        Case Else

-            Range("JUMP") = ""

-    End Select

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-    

-    is_input_range = INPUT_NO

-    

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateLPUList()

-    Dim lcd() As tLPU_COMMON

-    

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-    Dim objQTR As tQTR

-    Dim cRep As tREP

-    

-    ' ent_date = "%" ' % - all records

-    ent_date = getEnt_date

-    

-    objQTR = Get_QTR_Record(ent_date)

-    i = Get_LPU_CommonQTR(lcd, objQTR)

-     

-    ' стираем ФИО

-    Range("C3:C4").ClearContents

-    cRep = GetREPRecord

-    

-    Range("C3") = cRep.LastName

-    Range("C4") = cRep.FirstName

-    Range("G3") = GetRegionName(cRep.Region)

-    Range("G4") = GetCityName(cRep.Region, cRep.City)

-    Range("G5") = objQTR.sale_plan

-    

-

-    

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-        

-        For i = 1 To UBound(lcd)

-            r.Offset(i - 1, CLPU_NAME) = lcd(i).lpu.name

-            r.Offset(i - 1, CLPU_ID) = lcd(i).lpu.id

-            r.Offset(i - 1, CLPU_BEDS) = lcd(i).lpu.beds

-            

-         

-            r.Offset(i - 1, CLPU_NFG) = lcd(i).bdgt.bdgt_NFG

-            r.Offset(i - 1, CLPU_NMG) = lcd(i).bdgt.bdgt_NMG

-            r.Offset(i - 1, CLPU_PLAN) = lcd(i).bdgt.sale_plan

-            

-            r.Offset(i - 1, CLPU_HIR) = lcd(i).pat_HIR

-            r.Offset(i - 1, CLPU_TER) = lcd(i).pat_TER

-            r.Offset(i - 1, CLPU_CAR) = lcd(i).pat_CRD

-            r.Offset(i - 1, CLPU_FACT) = lcd(i).sale_ALL

-            r.Offset(i - 1, CLPU_PAT_LPU) = lcd(i).pat_LPU

-            r.Offset(i - 1, CLPU_BDGT) = lcd(i).bdgt_LPU

-            If lcd(i).bdgt_LPU > 0 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = lcd(i).sale_ALL / lcd(i).bdgt_LPU

-            End If

-            If r.Offset(i - 1, CLPU_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = 1

-            End If

-            

-        Next i

-    End If

-End Sub

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{566B33D6-957A-43E4-8444-D8EA3889700C}{42EE65B8-F8C6-4F95-9F52-7738BF6FCEAD}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-dbACS
->>>>>>
-Attribute VB_Name = "dbACS"

-Option Explicit

-

-Public Type tACS

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    patients_with_geparins As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objACS.ID <> 0 then updatre else insert

-Sub Insert_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objACS.id <> 0 Then

-        dbUpdate_ACS_Record dbConnection, objACS

-    Else

-        dbInsert_ACS_Record dbConnection, objACS

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_ACS_RecordsByLPU_ID(ByRef all_ACS_() As tACS, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_ACS_RecordsByLPU_ID = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, all_ACS_, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_ACS_Record dbConnection, objACS

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub dbInsert_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_acs", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objACS

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("patients_with_geparins") = .patients_with_geparins

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objACS.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim Update_SQL As String

-    

-    With objACS

-        Update_SQL = "UPDATE lpu_acs SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "patients_with_geparins=" & .patients_with_geparins & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_ACS_RecordsbyLPU_ID(dbConnection As Object, all_ACS() As tACS, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_ACS_SQL As String

-    Dim getAll_ACS_SQL As String

-    Dim ACS_Count As Long

-    ACS_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_ACS_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        ACS_Count = dbRecordset("ACS_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_ACS_RecordsbyLPU_ID = ACS_Count

-    

-    If ACS_Count > 0 Then

-        'we have records

-        ReDim all_ACS(1 To ACS_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_ACS_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_ACS As tACS

-                 With tmp_ACS

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .patients_with_geparins = dbRecordset("patients_with_geparins")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 all_ACS(index) = tmp_ACS

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE ID=" & objACS.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_ACS_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_HIR
->>>>>>
-Attribute VB_Name = "LPU_CLSN_HIR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-    

-        Dim objHir As tHIRURGIA

-        

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objHir

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .operations_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L9")

-                .patients_ambulator_clexan_20mg = Range("L10")

-                .patients_ambulator_clexan_40mg = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L19")

-                .patients_stationar_clexan_20mg = Range("L20")

-                .patients_stationar_clexan_40mg = Range("L21")

-            End With

-            Insert_Hir_Record objHir

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objHir.id = Range("rec_id")

-                    If objHir.id <> 0 Then

-                        Delete_Hir_Record objHir

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objHir As tHIRURGIA)

-    Dim qtr As tQTR

-    Dim formula As String

-

-    With objHir

-        Range("rec_id") = .id

-        Range("F6") = .operations_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L9") = .patients_ambulator_clexan

-        Range("L10") = .patients_ambulator_clexan_20mg

-        Range("I21") = .patients_stationar_nmg

-        Range("L19") = .patients_stationar_clexan

-        Range("L20") = .patients_stationar_clexan_20mg

-        

-        qtr = Get_QTR_Record(.entry_date)

-        formula = "=" & qtr.ClxnH20mg & "*($L$10+$L$20)+" & qtr.ClxnH40mg & "*($L$11+$L$21)"

-        Range("F11").formula = formula

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-    

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Range("h_DepFlag") = False

-    

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objHir() As tHIRURGIA

-        Dim i As Integer

-        i = GetAll_Hir_RecordsByLPU_ID(objHir, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.3

-        Else

-            SetupData objHir(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-mSapes
->>>>>>
-Attribute VB_Name = "mSapes"

-Option Explicit

-

-Const SHAPE_COLOR As Integer = 1

-Const SHAPE_NAME As Integer = 2

-

-

-Sub ShapeView(r_sh_finite_state As Range)

-    Dim chk As Range

-    Dim s As String

-    Dim c, idx As Integer

-    For Each chk In r_sh_finite_state

-        idx = 0

-        If chk = "+" Then

-            c = chk.Offset(0, idx + SHAPE_COLOR)

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While c <> 0

-                ShapeFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s)), c

-                idx = idx + 2

-                c = chk.Offset(0, idx + SHAPE_COLOR)

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        Else

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While s <> ""

-                ShapeUnFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s))

-                idx = idx + 2

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        End If

-    Next chk

-End Sub

-

-Sub ShapeFill(sh As ShapeRange, ByVal color As Integer)

-    sh.Fill.Visible = msoTrue

-    sh.Fill.Solid

-    sh.Fill.ForeColor.SchemeColor = color

-    sh.Fill.Transparency = 0#

-End Sub

-

-Sub ShapeUnFill(sh As ShapeRange)

-    sh.Fill.Visible = msoFalse

-    sh.Fill.Transparency = 0#

-End Sub

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Public Const INPUT_NO = 0

-Public Const INPUT_NUMBER = 1

-Public Const INPUT_PERCENT = 2

-Public Const INPUT_STRING = 3

-Public Const INPUT_CHECK = 4

-

-Public Const INP_IDX_TYPE = 1

-Public Const INP_IDX_NEXT = 2

-Public Const INP_IDX_MIN = 3

-Public Const INP_IDX_MAX = 4

-Public Const INP_IDX_DEP = 5

-Public Const INP_IDX_ALT = 7

-

-

-Public Type tInputSet

-    vType As Integer

-    vMin As Long

-    vMax As Long

-    rChk As String

-End Type

-

-Function is_input_cell(ByVal Target As Range, inputs As Range) As tInputSet

-    Dim t As Range

-    Dim iset As tInputSet

-    Dim test As Range

-    iset.vType = INPUT_NO

-    iset.vMin = 0

-    iset.vMax = 0

-    iset.rChk = ""

-    is_input_cell = iset

-

-' Закоментировать следующую сточку для работы

-'  Exit Function

-

-    Set test = Target.Cells(1, 1)

-    For Each t In inputs

-        If Range(t).Column = test.Column And Range(t).row = test.row Then

-            iset.vType = t.Offset(0, INP_IDX_TYPE).Value

-            Select Case iset.vType

-                Case INPUT_CHECK

-                    iset.rChk = t.Offset(0, INP_IDX_ALT)

-                Case INPUT_NUMBER, INPUT_PERCENT

-                    iset.vMin = t.Offset(0, INP_IDX_MIN).Value

-                    iset.vMax = t.Offset(0, INP_IDX_MAX).Value

-            End Select

-            is_input_cell = iset

-            Exit Function

-        End If

-    Next t

-End Function

-

-Function GetFocusAddress(ByVal r As Range, f_next As Range) As String

-    Dim chk, t As Range

-    

-    For Each chk In f_next

-        For Each t In r

-            If t.address = chk Then

-                GetFocusAddress = chk

-                Exit Function

-            End If

-            If Range(chk).Column = t.Column - 1 And Range(chk).row = t.row _

-            Or Range(chk).Column = t.Column And Range(chk).row = t.row - 1 _

-            Then

-                If Range(chk) <> "" Then

-                    If Range(chk) = 0 Then

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_ALT)).address

-                    Else

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_NEXT)).address

-                    End If

-                Else

-                    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-                End If

-                Exit Function

-            End If

-        Next t

-    Next chk

-    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-End Function

-

-Sub SetDependet(r As Range, inputs As Range)

-    Dim chk As Range

-    Dim s, serr As String

-    Dim idx As Integer

-    Dim iset As tInputSet

-    Dim err_found As Boolean

-    

-    If r.Count > 1 Then

-        Exit Sub

-    End If

-    

-    err_found = False

-    For Each chk In inputs

-        idx = INP_IDX_DEP

-        

-        

-        iset.vType = chk.Offset(0, INP_IDX_TYPE).Value

-        Select Case iset.vType

-            Case INPUT_NUMBER, INPUT_PERCENT

-                iset.vMin = chk.Offset(0, INP_IDX_MIN).Value

-                iset.vMax = chk.Offset(0, INP_IDX_MAX).Value

-                

-                If Range(chk) > iset.vMax Then

-                    err_found = True

-                    Range(chk) = iset.vMax

-                    serr = "Выход за дозволенный диапазон [" & iset.vMin & ".." & iset.vMax & "]! Данные скорректированы."

-                End If

-                

-                If Range(chk) = "" Then

-                    s = chk.Offset(0, idx)

-                    Do While s <> ""

-                        Range(s) = ""

-                        idx = idx + 1

-                        s = chk.Offset(0, idx)

-                    Loop

-                End If

-        End Select

-    Next chk

-    If err_found Then

-        MsgBox serr, vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Function CheckInputData(inputs As Range) As Boolean

-    Dim r As Range

-    

-    CheckInputData = True

-    For Each r In inputs

-        If Range(r) = "" Then

-            CheckInputData = False

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100.", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Sub Check_Int_Number(Target As Range, Def_Val As Long)

-    Dim err As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    err = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                err = True

-            End If

-        End If

-    Next r

-    If err Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_TER
->>>>>>
-Attribute VB_Name = "LPU_CLSN_TER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim objTer As tTERAPIA

-        

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objTer

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .patients_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L20")

-            End With

-            Insert_Ter_Record objTer

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objTer.id = Range("rec_id")

-                    If objTer.id <> 0 Then

-                        Delete_Ter_Record objTer

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objTer As tTERAPIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    With objTer

-        Range("rec_id") = .id

-        Range("F6") = .patients_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L11") = .patients_ambulator_clexan

-        Range("I21") = .patients_stationar_nmg

-        Range("L20") = .patients_stationar_clexan

-        

-        qtr = Get_QTR_Record(.entry_date)

-        formula = "=" & qtr.ClxnT40mg & "*($L$12+$L$20)"

-        Range("F11").formula = formula

-        

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-    

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Range("h_DepFlag") = False

-    

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objTer() As tTERAPIA

-        Dim i As Integer

-        i = GetAll_Ter_RecordsByLPU_ID(objTer, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.25

-        Else

-            SetupData objTer(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-    

-    Dim s As String

-    Dim iset As tInputSet

-    

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    

-    Select Case iset.vType

-        Case INPUT_NO

-        

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-            

-            Application.ScreenUpdating = False

-            

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-            

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-        

-        Case INPUT_STRING

-        

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{EBA94131-180E-4709-A2A3-B60D48987620}{47A860A1-BF92-4EBB-A333-AB7E83FAB868}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-LPU_BDGT
->>>>>>
-Attribute VB_Name = "LPU_BDGT"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub SetDefFocus()

-    Range(Range("DEF_FOCUS")).Select

-End Sub

-

-Public Sub ClearData()

-    ClearSheetData

-End Sub

-

-Sub ClearSheetData()

-    If Range("F10") = 0 And Range("F13") = 0 Then

-        Range("F11:F18") = ""

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("F11:F13") = ""

-    End If

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim bdgt As tBUDGET

-        Dim sum As Long

-        Dim test As Boolean

-        With bdgt

-            .lpu_id = Range("lpu_id")

-            .id = Range("rec_id")

-            .entry_date = Range("ent_date")

-            .bdgt_NMG = Round(Range("F11").Value, 0)

-            .bdgt_NFG = Round(Range("F12").Value, 0)

-            .sale_plan = Round(Range("F13").Value, 0)

-            

-            sum = .bdgt_NFG + .bdgt_NMG - .sale_plan

-            test = .bdgt_NFG <> 0 Or .bdgt_NMG <> 0 Or .sale_plan <> 0

-        End With

-        If test Then

-            If sum < 0 Then

-                MsgBox _

-                    "Ваш план превышает выделенный на гепарины бюджет. Сохранить данные?", _

-                    vbOKOnly, PROGRAM_NAME

-            End If

-            If test Then

-                Insert_BDGT_Record bdgt

-            End If

-        Else

-            If bdgt.id <> 0 Then

-                If vbYes = MsgBox("Сохранить нулевые значения?", vbYesNo, PROGRAM_NAME) Then

-                    Insert_BDGT_Record bdgt

-                End If

-                ret_back Range("DEF_FOCUS").Worksheet

-                Exit Sub

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-    End If

-    

-   ClearData

-   ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(cLPU As tLPU_COMMON)

-    Dim t_sum As Long

-    t_sum = 0

-' Setup budget data

-    Range("F11") = cLPU.bdgt.bdgt_NMG

-    Range("F12") = cLPU.bdgt.bdgt_NFG

-    Range("F13") = cLPU.bdgt.sale_plan

-    

-    With cLPU

-        Range("F14") = .pat_ALL

-        Range("F15") = .pat_HIR

-        Range("F16") = .pat_TER

-        Range("F17") = .pat_CRD

-        Range("F18") = .sale_ALL

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    ws_activate

-End Sub

-

-

-Sub ws_activate()

-    Dim cLPU As tLPU_COMMON

-    Dim objQTR As tQTR

-    Dim objLPU As tLPU

-    Dim ent_date As String

-    Dim id As Long

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    id = Range("lpu_id").Value

-    ent_date = Range("ent_date")

-    objQTR = Get_QTR_Record(ent_date)

-    objLPU = Get_LPU_Record(id)

-    Get_LPU_Common cLPU, objLPU, objQTR

-    

-    If cLPU.lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = cLPU.lpu.beds

-        Range("lpu_name") = cLPU.lpu.name

-        Range("lpu_addr") = cLPU.lpu.address

-        Range("rec_id") = cLPU.bdgt.id

-        

-        SetupData cLPU

-        

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-'    MsgBox Target.address

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Dim s As String

-    Dim iset As tInputSet

-    

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    

-    Select Case iset.vType

-        Case INPUT_NO

-        

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-            

-        Case INPUT_PERCENT

-        

-        Case INPUT_STRING

-        

-        Case INPUT_CHECK

-            

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{E3F10C5A-A4B4-42FF-A2C9-6F8198210A07}{563D0F3D-F79D-48F1-AFE4-A2136809B982}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mSheets
->>>>>>
-Attribute VB_Name = "mSheets"

-Option Explicit

-

-Function am_load_now() As Boolean

-    am_load_now = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE")

-End Function

-

-Sub Wks_select(RetSheet As String)

-    Dim sheet As Worksheet

-    For Each sheet In ThisWorkbook.Worksheets

-        If sheet.name = RetSheet Then

-            ThisWorkbook.Worksheets(RetSheet).Select

-            Exit Sub

-        End If

-    Next sheet

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub ret_back(sh As Worksheet)

-    Dim RetSheet As String

-    RetSheet = sh.Range("ret_addr")

-    sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    sh.Range("ret_addr") = ""

-    sh.Range("rec_id") = ""

-    sh.Range("lpu_id") = ""

-    sh.Range("ent_date") = ""

-    sh.Range("lpu_name") = ""

-    sh.Range("lpu_addr") = ""

-    sh.Range("lpu_beds") = ""

-    Wks_select RetSheet

-End Sub

-

-Sub ClearSheetData(r_start As Range)

-    If r_start <> "" Then

-        r_start.Worksheet.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        r_start = ""

-    Else

-        ret_back r_start.Worksheet

-    End If

-End Sub

-

-Sub wks_sel_chng(iset As tInputSet, ByVal Target As Range, sh As Worksheet)

-    Dim DebugMode As Boolean

-    Dim in_range As Range

-    

-    DebugMode = Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-

-    If DebugMode Then

-        sh.Unprotect

-    Else

-        sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    End If

-

-    If iset.vType = INPUT_CHECK Then

-        Set in_range = Target.Worksheet.Range(iset.rChk)

-    Else

-        Set in_range = Target

-    End If

-    

-    Dim str As String

-    str = GetFocusAddress(in_range, sh.Range("h_inputs"))

-

-'    MsgBox Target.Address & "; " & str

-    If str <> Target.address Then

-        sh.Range(str).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-Dlg_lpu_card
->>>>>>
-Attribute VB_Name = "Dlg_lpu_card"

-Attribute VB_Base = "0{137EDDE5-3DB4-4BAD-A245-324DC31ABB36}{3BD7159A-BF6C-403F-B3DF-4834FA9E4D92}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbLPU_List_Change()

-    Dim src As Range

-    Dim idx_src As Integer

-    

-    Set src = Worksheets(VAR_SHEET).Range(Me.cbLPU_List.RowSource)

-    idx_src = Me.cbLPU_List.ListIndex + 1

-    Me.tb_lpu_name.Text = src.Cells(idx_src, 1)

-    Me.tb_lpu_address.Text = src.Cells(idx_src, 2)

-    Me.tbBedsCount.Text = src.Cells(idx_src, 3)

-End Sub

-

-

-Private Sub cbxLPU_List_Enable_Click()

-    

-    If Me.cbxLPU_List_Enable Then

-        

-        Me.tb_lpu_name.Text = ""

-        Me.tb_lpu_name.Enabled = False

-        

-        Me.tb_lpu_address.Text = ""

-        Me.tb_lpu_address.Enabled = False

-        

-        Me.tbBedsCount.Text = ""

-        Me.tbBedsCount.Enabled = False

-        

-        Me.cbLPU_List.Enabled = True

-        cbLPU_List_Change

-    Else

-        Me.tb_lpu_name.Enabled = True

-        Me.tb_lpu_name.Text = ""

-        

-        Me.tb_lpu_address.Enabled = True

-        Me.tb_lpu_address.Text = ""

-        

-        Me.tbBedsCount.Enabled = True

-        Me.tbBedsCount.Text = ""

-        

-        Me.cbLPU_List.Enabled = False

-    End If

-End Sub

-

-<<<<<<
-======================
-UserInfo
->>>>>>
-Attribute VB_Name = "UserInfo"

-Attribute VB_Base = "0{8EB80D4C-3476-421A-A370-6332A07DE509}{A7542905-C9F8-4F39-AD67-B62A88F8F4E6}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Tag = vbOK

-End Sub

-

-Private Sub cbCity_Change()

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_CITY") = Me.cbCity.ListIndex

-        .Calculate

-    End With

-End Sub

-

-Private Sub cbRegion_Change()

-    Dim LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        NewRangeOffsetCol = cbRegion.Value * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).address

-        NewSumRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).address

-        .Calculate

-        .Range("IDX_CITY") = 0

-        cbCity.RowSource = NewCbxRange

-

-    End With

-    cbCity.ListIndex = 0

-End Sub

-

-<<<<<<
-======================
-mREP
->>>>>>
-Attribute VB_Name = "mREP"

-Option Explicit

-

-Sub hwnew()

-    Dim rs As Range

-    Dim re As Object

-    

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    HWReset

-    ReSetREPRecord

-    With Worksheets("REP_QTR")

-        .ClearRepName

-        .Range("REP_QTR_INPUT_DATA").ClearContents

-        .Range("QTR_SEL") = ""

-    End With

-    Worksheets(TITLE_SHEET).Select

-    With Application

-        .DisplayAlerts = False

-        .ThisWorkbook.Save

-        .Quit

-    End With

-End Sub

-

-Function CheckUser() As Boolean

-    Dim objHW() As Long

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    

-    GetHWInfo objHW()

-    i = GetHWRecords(objHW_DB)

-    

-    If i = 0 Then ' First time

-        StoreHWInfo objHW()

-        Worksheets("REP_QTR").Range("QTR_SEL") = ""

-    End If

-    If CheckHWInfo(objHW()) <> True Then

-        CheckUser = False

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    Else

-        CheckUser = SetupUser

-    End If

-End Function

-

-Function SetupUser() As Boolean

-    Dim cUser As tREP

-    Dim idx As Integer

-    Dim dlg_ui As UserInfo

-    

-    Set dlg_ui = New UserInfo

-    

-    cUser = GetREPRecord()

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_REGION") = cUser.Region

-        .Range("IDX_CITY") = cUser.City

-    End With

-        

-    With dlg_ui

-        .cbRegion = cUser.Region

-        .cbCity = cUser.City

-        .tbFName = cUser.FirstName

-        .tbLName = cUser.LastName

-    End With

-    

-    Worksheets(REGS_SHEET).Calculate

-    

-    Dim test_Ok As Boolean

-    test_Ok = False

-    

-    On Error GoTo l1

-

-    Do

-        dlg_ui.Show

-        If dlg_ui.Tag = vbOK Then

-            test_Ok = dlg_ui.tbFName.Value <> "" And dlg_ui.tbLName <> ""

-            If test_Ok Then

-                Exit Do

-            Else

-                MsgBox "Введите имя и фамилию", vbOKOnly, PROGRAM_NAME

-            End If

-        Else

-            Exit Do

-        End If

-    Loop Until False

-l1:

-    If test_Ok Then

-        With cUser

-            .Region = dlg_ui.cbRegion.Value

-            .City = dlg_ui.cbCity.Value

-            .FirstName = dlg_ui.tbFName.Value

-            .LastName = dlg_ui.tbLName.Value

-        End With

-        SetREPRecord cUser

-    Else

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .ThisWorkbook.Saved = True

-            .Quit

-        End With

-    End If

-    SetupUser = test_Ok

-End Function

-

-Sub GetHWInfo(objHW() As Long)

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    i = 1

-    For Each d In dc

-        If d.drivetype = 2 Then ' 2 - HardDisk

-            ReDim Preserve objHW(i)

-            objHW(i) = d.SerialNumber

-            i = i + 1

-        End If

-    Next

-    SortHW objHW

-End Sub

-

-Sub StoreHWInfo(objHW() As Long)

-    UpdateHWRecords objHW

-End Sub

-

-Sub SortHW(objHW() As Long)

-    Dim r As Range

-    Dim rs As Range

-    Dim re As Object

-    Dim i As Integer

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    For i = 1 To UBound(objHW)

-        r = objHW(i)

-        Set r = r.Offset(1, 0)

-    Next i

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).Sort _

-            Key1:=.Range("HW_Number"), _

-            Order1:=xlDescending, _

-            Header:=xlGuess, _

-            OrderCustom:=1, _

-            MatchCase:=False, _

-            Orientation:=xlTopToBottom

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    i = 1

-    Do While r <> ""

-        objHW(i) = r

-        Set r = r.Offset(1, 0)

-        i = i + 1

-    Loop

-End Sub

-

-Function CheckHWInfo(objHW() As Long)

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    CheckHWInfo = False

-        

-    i = GetHWRecords(objHW_DB)

-    If i > 0 Then

-        SortHW objHW_DB

-    End If

-    If UBound(objHW) = UBound(objHW_DB) Then

-        For i = 1 To UBound(objHW)

-            If objHW(i) <> objHW_DB(i) Then

-                Exit Function

-            End If

-        Next i

-        CheckHWInfo = True

-    End If

-End Function

-<<<<<<
-======================
-dbBudget
->>>>>>
-Attribute VB_Name = "dbBudget"

-Option Explicit

-

-Public Type tBUDGET

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    bdgt_NMG As Long

-    bdgt_NFG As Long

-    sale_plan As Long

-End Type

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function GetAll_BDGT_RecordsByLPU_ID(ByRef allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_BDGT_RecordsByLPU_ID = dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection, allBDGT, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function Get_BDGT_Record(ByVal lpu_id As Long, ByVal ent_date As String) As tBUDGET

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    Get_BDGT_Record = dbGet_BDGT_Record(dbConnection, lpu_id, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objBDGT.ID <> 0 then updatre else insert

-Public Sub Insert_BDGT_Record(objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    If objBDGT.id <> 0 Then

-        dbUpdate_BDGT_Record dbConnection, objBDGT

-    Else

-        dbInsert_BDGT_Record dbConnection, objBDGT

-    End If

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Public Sub Delete_BDGT_Record(ByRef objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    dbDelete_BDGT_Record dbConnection, objBDGT

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_BDGT_Record(dbConnection As Object, ByVal lpu_id As Long, ent_date As String) As tBUDGET

-    

-    Dim SQL As String

-    Dim objBDGT As tBUDGET

-    

-    With objBDGT

-        .id = 0

-        .lpu_id = lpu_id

-        .entry_date = ent_date

-        .bdgt_NMG = 0

-        .bdgt_NFG = 0

-        .sale_plan = 0

-    End With

-        

-    

-    SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        With objBDGT

-            .entry_date = dbRecordset("entry_date")

-            .id = dbRecordset("id")

-            .lpu_id = dbRecordset("lpu_id")

-            .bdgt_NFG = dbRecordset("bdgt_NFG")

-            .bdgt_NMG = dbRecordset("bdgt_NMG")

-            .sale_plan = dbRecordset("sale_PLAN")

-        End With

-    End If

-    

-    dbGet_BDGT_Record = objBDGT

-End Function

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection As Object, allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_BDGT_SQL As String

-    Dim getAll_BDGT_SQL As String

-    Dim BDGT_Count As Long

-    BDGT_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_BDGT_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        BDGT_Count = dbRecordset("BDGT_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_BDGT_RecordsbyLPU_ID = BDGT_Count

-    

-    If BDGT_Count > 0 Then

-        'we have records

-        ReDim allBDGT(1 To BDGT_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_BDGT_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpBDGT As tBUDGET

-                 With tmpBDGT

-                    .entry_date = dbRecordset("entry_date")

-                    .id = dbRecordset("id")

-                    .lpu_id = dbRecordset("lpu_id")

-                    .bdgt_NFG = dbRecordset("bdgt_NFG")

-                    .bdgt_NMG = dbRecordset("bdgt_NMG")

-                    .sale_plan = dbRecordset("sale_PLAN")

-                 End With

-                 

-                 allBDGT(index) = tmpBDGT

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbInsert_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "lpu_budget", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    dbRecordset("entry_date") = objBDGT.entry_date

-    dbRecordset("lpu_id") = objBDGT.lpu_id

-    dbRecordset("bdgt_NMG") = objBDGT.bdgt_NMG

-    dbRecordset("bdgt_NFG") = objBDGT.bdgt_NFG

-    dbRecordset("sale_PLAN") = objBDGT.sale_plan

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objBDGT.id = dbRecordset("id")

-  

-End Sub

-

-Public Sub dbUpdate_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu_budget SET " & _

-    "entry_date='" & objBDGT.entry_date & "'," & _

-    "lpu_id=" & objBDGT.lpu_id & "," & _

-    "bdgt_NMG=" & objBDGT.bdgt_NMG & "," & _

-    "bdgt_NFG=" & objBDGT.bdgt_NFG & "," & _

-    "sale_PLAN=" & objBDGT.sale_plan & _

-    " WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-Public Sub dbDelete_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_BDGT_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbDatabase
->>>>>>
-Attribute VB_Name = "dbDatabase"

-Option Explicit

-

-

-Sub dbOpenConnection(dbConnection As Object)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, SQL As String)

-    dbConnection.Execute (SQL)

-End Sub

-

-<<<<<<
-======================
-dbLPU
->>>>>>
-Attribute VB_Name = "dbLPU"

-Option Explicit

-

-Public Type tLPU

-    id As Long

-    rep_id As Long

-    name As String

-    address As String

-    beds As Integer

-End Type

-

-Function Get_LPU_Record(ByVal lpu_id As Long) As tLPU

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_LPU_Record = dbGet_LPU_Record(dbConnection, lpu_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAllLPU(allLPU() As tLPU) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAllLPU = dbGetAllLPU(dbConnection, allLPU)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAllLPUbyQTR(allLPU() As tLPU, ent_date As String) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAllLPUbyQTR = dbGetAllLPUbyQTR(dbConnection, allLPU, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objLPU.id = 0 then insert else update

-Sub Insert_LPU_Record(ByRef objLPU As tLPU)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    If objLPU.id = 0 Then

-        dbInsert_LPU_Record dbConnection, objLPU

-    Else

-        dbUpdate_LPU_Record dbConnection, objLPU

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub Delete_LPU_Record(ByRef objLPU As tLPU)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDelete_LPU_Record dbConnection, objLPU

-    dbCloseConnection dbConnection

-End Sub

-

-Sub Delete_LPU_RecordQTR(ByRef objLPU As tLPU, ent_date As String)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Hir_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Ter_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_ACS_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    

-    dbCloseConnection dbConnection

-    

-End Sub

-

-Function dbGet_LPU_Record(dbConnection As Object, ByVal lpu_id As Long) As tLPU

-    

-    Dim SQL As String

-    Dim objLPU As tLPU

-    

-    objLPU.id = lpu_id

-    objLPU.name = ""

-    objLPU.address = ""

-    

-    SQL = "SELECT * FROM lpu WHERE id=" & lpu_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objLPU.name = dbRecordset("name")

-        objLPU.address = dbRecordset("address")

-        objLPU.rep_id = dbRecordset("rep_id")

-        objLPU.beds = dbRecordset("beds")

-    End If

-    

-    dbGet_LPU_Record = objLPU

-

-End Function

-

-Sub dbInsert_LPU_Record(dbConnection As Object, ByRef objLPU As tLPU)

-  

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu", dbConnection, 2, 2

-    dbRecordset.addnew

-    dbRecordset("name") = objLPU.name

-    dbRecordset("address") = objLPU.address

-    dbRecordset("rep_id") = objLPU.rep_id

-    dbRecordset("beds") = objLPU.beds

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objLPU.id = dbRecordset("id")

-  

-End Sub

-

-Sub dbUpdate_LPU_Record(dbConnection As Object, ByRef objLPU As tLPU)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu SET " & _

-    "name='" & objLPU.name & "'," & _

-    "address='" & objLPU.address & "'," & _

-    "beds=" & objLPU.beds & "," & _

-    "rep_id=" & objLPU.rep_id& & _

-    " WHERE id=" & objLPU.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-

-Function dbGetAllLPU(dbConnection As Object, allLPU() As tLPU) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu"

-    getAll_LPU_SQL = "SELECT * FROM lpu"

-

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAllLPU = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-Function dbGetAllLPUbyQTR(dbConnection As Object, allLPU() As tLPU, ent_date As String) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    Dim where As String

-    where = "WHERE lpu_budget.entry_date like '" & ent_date & "'"

-    

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu_budget " & where

-    

-    getAll_LPU_SQL = "SELECT lpu.id as id, lpu.rep_id as rep_id, lpu.name as name, lpu.address as address, lpu.beds AS beds " & _

-    "FROM lpu, lpu_budget " & where & " AND lpu.id=lpu_budget.lpu_id"

-    

-

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAllLPUbyQTR = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-Sub dbDelete_LPU_Record(dbConnection As Object, ByRef objLPU As tLPU)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu " & _

-    "WHERE id=" & objLPU.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByLPU_ID dbConnection, objLPU.id

-    dbDelete_Hir_RecordsByLPU_ID dbConnection, objLPU.id

-    dbDelete_Ter_RecordsByLPU_ID dbConnection, objLPU.id

-    dbDelete_ACS_RecordsByLPU_ID dbConnection, objLPU.id

-    

-End Sub

-

-Sub dbDelete_LPU_RecordQTR(dbConnection As Object, ByRef objLPU As tLPU, ent_date As String)

-    

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Hir_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Ter_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_ACS_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    

-End Sub

-

-<<<<<<
-======================
-dbREP
->>>>>>
-Attribute VB_Name = "dbREP"

-Option Explicit

-

-Public Type tREP

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function GetREPRecord() As tREP

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetREPRecord = dbGetREPRecord(dbConnection)

-    dbCloseConnection dbConnection

-End Function

-

-Sub SetREPRecord(cUser As tREP)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbSetREPRecord dbConnection, cUser

-    dbCloseConnection dbConnection

-End Sub

-

-Sub ReSetREPRecord()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbReSetREPRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGetREPRecord(dbConnection As Object) As tREP

-    

-    Dim SQL As String

-    Dim objREP As tREP

-    

-    objREP.FirstName = ""

-    objREP.LastName = ""

-    objREP.Region = 0

-    objREP.City = 0

-    SQL = "SELECT firstname, lastname, region, city FROM " & _

-          "rep"

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open SQL, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREP.FirstName = dbRecordset("firstname")

-        objREP.LastName = dbRecordset("lastname")

-        objREP.Region = dbRecordset("region")

-        objREP.City = dbRecordset("city")

-        

-    End If

-    

-    dbGetREPRecord = objREP

-        

-End Function

-

-Public Sub dbSetREPRecord(dbConnection As Object, ByRef objREP As tREP)

-  

-    Dim DeleteSQL As String

-    Dim InsertSQL As String

-    

-    DeleteSQL = "DELETE FROM rep"

-    InsertSQL = "INSERT INTO rep (firstname, lastname, region, city) VALUES (" & _

-    "'" & objREP.FirstName & "', " & _

-    "'" & objREP.LastName & "', " & _

-    objREP.Region & ", " & _

-    objREP.City & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    dbRecordset.Open InsertSQL, dbConnection

-End Sub

-

-Public Sub dbReSetREPRecord(dbConnection As Object)

-  

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM rep"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    CheckWorkBooksArround Wb

-End Sub

-

-

-Sub CheckWorkBooksArround(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If app.Workbooks.Count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKOnly, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-        Exit Sub

-    End If

-

-End Sub

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub SaveExcelState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-        ActiveWorkbook.DisplayDrawingObjects = xlDisplayShapes

-        

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.Count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars(STDBAR_NAME).Visible = False

-End Sub

-

-

-Public Sub RestoreExcelState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars(STDBAR_NAME).Visible = True

-End Sub

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Public Const STDBAR_NAME = "Worksheet Menu Bar"

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Export"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 620

-                        .OnAction = "cmExport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Exit && Restore Excel"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 548

-                        .OnAction = "cmExitRestore"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(flag As Boolean)

-    If flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars(STDBAR_NAME)

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmExport()

-    dbExport

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    Dim dlg As dlgAbout

-    Set dlg = New dlgAbout

-    

-    dlg.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlg.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlg.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlg.Show

-End Sub

-

-Sub cmMail2Support()

-    Dim err_description As String

-    Dim dlg_msg As dlg_Mail

-    Set dlg_msg = New dlg_Mail

-    With dlg_msg

-        .Show

-        If .Tag = vbOK Then

-            ThisWorkbook.Worksheets(VAR_SHEET).Range("ERR_MESSAGE") _

-                = .tbMessage.Text

-            ThisWorkbook.Save

-            ThisWorkbook.SendMail Recipients:="infra@i-rs.ru", Subject:=PROGRAM_NAME & " ver.:" & PROGRAM_VERSION

-            MsgBox "Сообщение об ошибке отправлено. Перезагрузите программу.", vbOKOnly, PROGRAM_NAME

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-    End With

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-'        helppath = "hh.exe " & .Path & "\Telfast.chm"

-'        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub set_work_mode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetupEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-End Sub

-

-Sub cmSetStandaloneMode()

-    set_work_mode

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    Dim dlg As dlgGetPwd

-    rp = common_pwd

-    

-    Set dlg = New dlgGetPwd

-    dlg.edPwd = ""

-    dlg.Show

-    

-    If dlg.edPwd = rp Then

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmHomePage()

-    ThisWorkbook.Worksheets("REP_QTR").Select

-End Sub

-

-Sub cmExitRestore()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = True

-    Application.Quit

-End Sub

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    Dim dlg_prn As dlgPrint

-    

-    Set dlg_prn = New dlgPrint

-    

-    With dlg_prn

-        .cbMainReport = True

-        .cbMainBudget = False

-        .cbSrcData = False

-        .cbAllSheets = False

-    

-        .Show

-    

-        If .Tag = vbCancel Then

-            Exit Sub

-        End If

-    End With

-    

-    Dim PrnIdx As Integer

-    

-    With dlg_prn

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("REP_QTR", "budget", "Final")

-    Case 1111

-        plist = Array("REP_QTR", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("REP_QTR")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Clexane bar"

-Public Const common_pwd As String = "crdjhxtyjr"

-

-

-Sub SetupEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    Wb.Worksheets(TITLE_SHEET).Select

-    With Application

-        .Caption = PROGRAM_NAME & " " & PROGRAM_VERSION

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .SaveExcelState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = False

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Wb.Worksheets(TITLE_SHEET).Select

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-'                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    If cWindow.Type = xlWorkbook Then

-                        cWindow.DisplayHeadings = True

-                    End If

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu True

-        End If

-        With mobjAppState

-            .RestoreExcelState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Worksheets(TITLE_SHEET).Select

-'        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Option Explicit

-

-Sub UpdateHWRecords(objHW() As Long)

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    dbUpdateHWRecords dbConnection, objHW

-    dbCloseConnection dbConnection

-End Sub

-

-Function GetHWRecords(objHW() As Long) As Integer

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    GetHWRecords = dbGetHWRecords(dbConnection, objHW)

-    dbCloseConnection dbConnection

-End Function

-

-Sub HWReset()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbInsertHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    

-    Dim dbRecordset As Object

-    Dim i As Long

-    

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "hw", dbConnection, 2, 2

-    

-    For i = 1 To UBound(objHW)

-        dbRecordset.addnew

-        dbRecordset("num") = objHW(i)

-        dbRecordset.Update

-    Next i

-    

-End Sub

-

-Sub dbUpdateHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    dbDeleteHWRecord dbConnection

-    dbInsertHWRecords dbConnection, objHW

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-dbHir
->>>>>>
-Attribute VB_Name = "dbHir"

-Option Explicit

-

-Public Type tHIRURGIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    operations_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_ambulator_clexan_40mg As Integer

-    patients_ambulator_clexan_20mg As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-    patients_stationar_clexan_40mg As Integer

-    patients_stationar_clexan_20mg As Integer

-End Type

-

-' if objHir.ID <> 0 then updatre else insert

-Sub Insert_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objHir.id <> 0 Then

-        dbUpdate_Hir_Record dbConnection, objHir

-    Else

-        dbInsert_Hir_Record dbConnection, objHir

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Hir_RecordsByLPU_ID(ByRef allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Hir_RecordsByLPU_ID = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, allHir, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Hir_Record dbConnection, objHir

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objHir.ID <> 0 then updatre else insert

-

-Sub dbInsert_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_hir", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objHir

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("operations_per_quarter") = .operations_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_ambulator_clexan_20mg") = .patients_ambulator_clexan_20mg

-        dbRecordset("patients_ambulator_clexan_40mg") = .patients_ambulator_clexan_40mg

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-        dbRecordset("patients_stationar_clexan_20mg") = .patients_stationar_clexan_20mg

-        dbRecordset("patients_stationar_clexan_40mg") = .patients_stationar_clexan_40mg

-        

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objHir.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim UpdateSQL As String

-    

-    With objHir

-        UpdateSQL = "UPDATE lpu_hir SET " & _

-            "entry_date='" & objHir.entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "operations_per_quarter=" & .operations_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_ambulator_clexan_20mg=" & .patients_ambulator_clexan_20mg & "," & _

-            "patients_ambulator_clexan_40mg=" & .patients_ambulator_clexan_40mg & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & "," & _

-            "patients_stationar_clexan_20mg=" & .patients_stationar_clexan_20mg & "," & _

-            "patients_stationar_clexan_40mg=" & .patients_stationar_clexan_40mg & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_Hir_RecordsbyLPU_ID(dbConnection As Object, allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Hir_SQL As String

-    Dim getAll_Hir_SQL As String

-    Dim Hir_Count As Long

-    Hir_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Hir_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Hir_Count = dbRecordset("HIR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Hir_RecordsbyLPU_ID = Hir_Count

-    

-    If Hir_Count > 0 Then

-        'we have records

-        ReDim allHir(1 To Hir_Count)

-        Dim index As Integer

-        index = 1

-        dbRecordset.Open getAll_Hir_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpHir As tHIRURGIA

-                 With tmpHir

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .operations_per_quarter = dbRecordset("operations_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_ambulator_clexan_20mg = dbRecordset("patients_ambulator_clexan_20mg")

-                    .patients_ambulator_clexan_40mg = dbRecordset("patients_ambulator_clexan_40mg")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                    .patients_stationar_clexan_20mg = dbRecordset("patients_stationar_clexan_20mg")

-                    .patients_stationar_clexan_40mg = dbRecordset("patients_stationar_clexan_40mg")

-                 End With

-                 

-                 allHir(index) = tmpHir

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE ID=" & objHir.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Hir_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbTer
->>>>>>
-Attribute VB_Name = "dbTer"

-Option Explicit

-

-Public Type tTERAPIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objTer.ID <> 0 then updatre else insert

-Sub Insert_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objTer.id <> 0 Then

-        dbUpdate_Ter_Record dbConnection, objTer

-    Else

-        dbInsert_Ter_Record dbConnection, objTer

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Ter_RecordsByLPU_ID(ByRef allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Ter_RecordsByLPU_ID = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, allTer, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Ter_Record dbConnection, objTer

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objTer.ID <> 0 then updatre else insert

-

-Sub dbInsert_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_ter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objTer

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("risk_percent") = Double2Str(.risk_percent, 3)

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objTer.id = dbRecordset("ID")

-

-End Sub

-

-Sub test()

-    Dim s As String

-    Dim d As Single

-    d = 1235.6789

-    s = Format(d, "####0,00")

-    MsgBox s

-End Sub

-

-Sub dbUpdate_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim Update_SQL As String

-    

-    With objTer

-        Update_SQL = "UPDATE lpu_ter SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_Ter_RecordsbyLPU_ID(dbConnection As Object, allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Ter_SQL As String

-    Dim getAll_Ter_SQL As String

-    Dim Ter_Count As Long

-    Ter_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Ter_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Ter_Count = dbRecordset("TER_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Ter_RecordsbyLPU_ID = Ter_Count

-    

-    If Ter_Count > 0 Then

-        'we have records

-        ReDim allTer(1 To Ter_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_Ter_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpTer As tTERAPIA

-                 With tmpTer

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 allTer(index) = tmpTer

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE ID=" & objTer.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Ter_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-mLPU_LIST
->>>>>>
-Attribute VB_Name = "mLPU_LIST"

-Option Explicit

-

-Public Const CINP_AREA As String = "B12"

-Public Const CLPU_NAME As Integer = 0

-Public Const CLPU_NAME1 As Integer = 1

-Public Const CLPU_NAME2 As Integer = 2

-Public Const CLPU_ID As Integer = 3

-Public Const CLPU_BEDS As Integer = 4

-Public Const CLPU_NFG As Integer = 5

-Public Const CLPU_NMG As Integer = 6

-Public Const CLPU_HIR As Integer = 7

-Public Const CLPU_TER As Integer = 8

-Public Const CLPU_CAR As Integer = 9

-Public Const CLPU_FACT As Integer = 10

-Public Const CLPU_PLAN As Integer = 11

-Public Const CLPU_PAT_LPU As Integer = 16

-Public Const CLPU_BDGT As Integer = 17

-Public Const CLPU_PAT_ALL As Integer = 16

-

-

-

-Sub EditLPU(cLPU As tLPU, ent_date As String)

-    Dim del_request As Integer

-    Dim allLPU() As tLPU

-    Dim lpu_count As Integer

-    Dim i As Integer

-    Dim tmp_LPU_List As Range

-    Dim tmp_LPU_List_Addr As String

-    Dim r_end As Range

-    Dim dlg As Dlg_lpu_card

-    

-    Set dlg = New Dlg_lpu_card

-    

-    lpu_count = GetAllLPU(allLPU)

-    With Worksheets(VAR_SHEET)

-        Set tmp_LPU_List = .Range("tmp_LPU_List")

-        Set r_end = .Range(tmp_LPU_List, tmp_LPU_List.End(xlDown))

-        Set r_end = .Range(r_end, r_end.End(xlToRight))

-        .Range(tmp_LPU_List, r_end).ClearContents

-    End With

-        

-    If lpu_count <> 0 Then

-        dlg.cbxLPU_List_Enable.Enabled = True

-        For i = 1 To UBound(allLPU)

-            tmp_LPU_List.Cells(i, 1) = allLPU(i).name

-            tmp_LPU_List.Cells(i, 2) = allLPU(i).address

-            tmp_LPU_List.Cells(i, 3) = allLPU(i).beds

-            tmp_LPU_List.Cells(i, 4) = allLPU(i).id

-        Next i

-    Else

-        dlg.cbxLPU_List_Enable.Enabled = False

-    End If

-    

-    tmp_LPU_List_Addr = Worksheets(VAR_SHEET).name & "!" & _

-            Worksheets(VAR_SHEET).Range(tmp_LPU_List, tmp_LPU_List.End(xlDown)).address

-

-    With dlg

-        .cbLPU_List.RowSource = tmp_LPU_List_Addr

-        .cbLPU_List.ListIndex = 0

-        .cbxLPU_List_Enable = False

-        .cbLPU_List.Enabled = False

-        If cLPU.id <> 0 Then

-            .cbxLPU_List_Enable.Enabled = False

-        Else

-            If lpu_count <> 0 Then

-                .cbxLPU_List_Enable.Enabled = True

-            Else

-                .cbxLPU_List_Enable.Enabled = False

-            End If

-        End If

-        .tb_lpu_name.Text = cLPU.name

-        .tb_lpu_address.Text = cLPU.address

-        .tbBedsCount = cLPU.beds

-

-        .Tag = vbCancel

-    End With

-    

-    dlg.Show

-    

-    If Not IsNumeric(dlg.Tag) Then

-        Exit Sub

-    End If

-    

-    If dlg.Tag = vbOK Then

-        Dim n As Variant

-        Dim test As Integer

-        test = 0

-        n = dlg.tbBedsCount.Value

-        If Not IsNumeric(n) Then

-            test = 1

-        Else

-            If n = 0 Then

-                test = 1

-            End If

-        End If

-        If test = 0 Then

-            

-            cLPU.name = dlg.tb_lpu_name.Text

-            cLPU.address = dlg.tb_lpu_address.Text

-            cLPU.beds = dlg.tbBedsCount.Value

-                                    

-            If cLPU.name = "" Or cLPU.address = "" Then

-                test = 2

-            End If

-        End If

-        Select Case test

-            Case 0

-                If dlg.cbxLPU_List_Enable.Value = True Then

-                    cLPU.id = tmp_LPU_List.Cells(dlg.cbLPU_List.ListIndex + 1, 4)

-                End If

-                Insert_LPU_Record cLPU

-                ' Проверить наличие данных для ЛПУ в квартале

-                Dim bdgt As tBUDGET

-                bdgt = Get_BDGT_Record(cLPU.id, ent_date)

-                ' Записи нет: создать пустую запись в lpu_budget

-                If bdgt.id = 0 Then

-                    bdgt.lpu_id = cLPU.id

-                    bdgt.entry_date = ent_date

-                    Insert_BDGT_Record bdgt

-                End If

-            Case 1

-                MsgBox "Коечная мощьность измеряется числом более чем 1!", vbOKOnly, PROGRAM_NAME

-            Case 2

-                MsgBox "Наименование и адрес ЛПУ не должны быть пустыми!", vbOKOnly, PROGRAM_NAME

-        End Select

-    End If

-End Sub

-

-Sub Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-

-End Sub

-

-Sub Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btLPU_DEL_IT()

-    Dim cLPU As tLPU

-    Dim ent_date As String

-    Dim delete_all As Integer

-    Dim dlg_del As dlg_LPU_delete

-    

-    With Worksheets("LPU_LIST")

-        ent_date = .Range("ent_date")

-        cLPU.id = .getCurrentLPU_ID()

-    End With

-    

-    If cLPU.id = 0 Then

-        MsgBox "Укажите удаляемый объект", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    cLPU = Get_LPU_Record(cLPU.id)

-    

-    Set dlg_del = New dlg_LPU_delete

-    With dlg_del

-        .chbDeleteQTR.Value = True

-        .chbDeleteAll.Value = False

-        .lComment = ent_date & ": Удаление ЛПУ '" _

-        & cLPU.name & "', расположенного по адресу:" _

-        & cLPU.address & "."

-        .Show

-        

-        If .Tag = vbOK Then

-            If .chbDeleteAll.Value Then

-                delete_all = _

-                    MsgBox("Все записи об ЛПУ с именем '" & cLPU.name & _

-                    "' будут удалены навсегда.", vbOK, PROGRAM_NAME)

-                If delete_all = vbOK Then

-                    Delete_LPU_Record cLPU

-                End If

-            Else

-                Delete_LPU_RecordQTR cLPU, ent_date

-            End If

-        End If

-    End With

-    

-    With ThisWorkbook

-        .Worksheets(TITLE_SHEET).Select

-        .Worksheets("LPU_LIST").Select

-    End With

-End Sub

-

-Sub btLPU_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Activate

-End Sub

-

-

-Sub btLPU_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim lpu_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("QTR_ACTION").Value

-    With Worksheets("LPU_LIST")

-        ent_date = .getEnt_date()

-        

-    

-        lpu_id = .getCurrentLPU_ID

-        If lpu_id <> 0 And i = 1 Then

-            lpu_id = 0

-        End If

-        If lpu_id = 0 Then

-            i = 1

-        End If

-        Select Case i

-            Case 1, 6

-                .SelectLPU_NAME lpu_id, ent_date

-                .Range("JUMP") = ""

-            Case 2

-                If lpu_id <> 0 Then

-                    .SelectLPU_BDGT lpu_id, ent_date

-                    .Range("JUMP") = "LPU_BDGT"

-                End If

-            Case 3

-                If lpu_id <> 0 Then

-                    .SelectLPU_HIR lpu_id, ent_date

-                    .Range("JUMP") = "LPU_CLSN_HIR"

-                End If

-            Case 4

-                If lpu_id <> 0 Then

-                    .SelectLPU_TER lpu_id, ent_date

-                    .Range("JUMP") = "LPU_CLSN_TER"

-                End If

-            Case 5

-                If lpu_id <> 0 Then

-                    .SelectLPU_C_ACS lpu_id, ent_date

-                    .Range("JUMP") = "LPU_CLSN_C_ACS"

-                End If

-        End Select

-    End With

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-dbQTR
->>>>>>
-Attribute VB_Name = "dbQTR"

-Option Explicit

-

-Public Type tQTR

-    id As Long

-    entry_date As String

-    rep_id As Long

-    sale_plan As Long

-    ClxnH20mg As Long

-    ClxnH40mg As Long

-    ClxnT40mg As Long

-    ClxnC_IM As Long

-    ClxnC_ACS As Long

-End Type

-

-

-Function GetLastQTR_fromDB() As String

-    Dim dbConnection As Object

-    Dim getCount_QTR_SQL As String

-    Dim getLast_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter"

-    getLast_QTR_SQL = "SELECT MAX(entry_date) as ent_date FROM quarter"

-    

-    dbOpenConnection dbConnection

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    If QTR_Count > 0 Then

-        'we have records

-        dbRecordset.Open getLast_QTR_SQL, dbConnection

-        getLast_QTR_SQL = dbRecordset("ent_date")

-    Else

-        getLast_QTR_SQL = ""

-    End If

-    

-    GetLastQTR_fromDB = getLast_QTR_SQL

-    dbCloseConnection dbConnection

-End Function

-

-Sub Insert_QTR_Record(ByRef objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objQTR.id <> 0 Then

-        dbUpdate_QTR_Record dbConnection, objQTR

-    Else

-        dbInsert_QTR_Record dbConnection, objQTR

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-Function Get_QTR_Record(ent_date As String) As tQTR

-    Dim dbConnection As Object

-    Dim allQTR() As tQTR

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    i = dbGetAll_QTR_Records(dbConnection, allQTR, ent_date)

-    If i <> 0 Then

-        Get_QTR_Record = allQTR(1)

-    End If

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTR_Records(ByRef All_QTR() As tQTR, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_QTR_Records = dbGetAll_QTR_Records(dbConnection, All_QTR, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_QTR_Record(ByRef objQTR As tQTR)

-    Dim dbConnection As Object

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_QTR_Record dbConnection, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objQTR.ID <> 0 then updatre else insert

-Sub dbInsert_QTR_Record(dbConnection As Object, ByRef objQTR As tQTR)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "quarter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objQTR

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("sale_plan") = .sale_plan

-        dbRecordset("rep_id") = .rep_id

-        dbRecordset("ClxnH20mg") = .ClxnH20mg

-        dbRecordset("ClxnH40mg") = .ClxnH40mg

-        dbRecordset("ClxnT40mg") = .ClxnT40mg

-        dbRecordset("ClxnC_IM") = .ClxnC_IM

-        dbRecordset("ClxnC_ACS") = .ClxnC_ACS

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objQTR.id = dbRecordset("id")

-

-End Sub

-

-Sub dbUpdate_QTR_Record(dbConnection As Object, ByRef objQTR As tQTR)

-    Dim Update_SQL As String

-    

-    With objQTR

-        Update_SQL = "UPDATE quarter SET " & _

-            "entry_date='" & .entry_date & "'" & "," & _

-            "rep_id=" & .rep_id & "," & _

-            "sale_plan=" & .sale_plan & "," & _

-            "ClxnH20mg=" & .ClxnH20mg & "," & _

-            "ClxnH40mg=" & .ClxnH40mg & "," & _

-            "ClxnT40mg=" & .ClxnT40mg & "," & _

-            "ClxnC_IM=" & .ClxnC_IM & "," & _

-            "ClxnC_ACS=" & .ClxnC_ACS & _

-            " WHERE id=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if ent_date = % then all_records

-Function dbGetAll_QTR_Records(dbConnection As Object, All_QTR() As tQTR, ent_date As String) As Integer

-    

-    Dim getCount_QTR_SQL As String

-    Dim getAll_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter WHERE entry_date like '" & ent_date & "'"

-    getAll_QTR_SQL = "SELECT * FROM quarter WHERE entry_date like '" & ent_date & "' ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_QTR_Records = QTR_Count

-    

-    If QTR_Count > 0 Then

-        'we have records

-        ReDim All_QTR(1 To QTR_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTR_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTR As tQTR

-                 With tmp_QTR

-                    .entry_date = dbRecordset("entry_date")

-                    .rep_id = dbRecordset("rep_id")

-                    .sale_plan = dbRecordset("sale_plan")

-                    .ClxnH20mg = dbRecordset("ClxnH20mg")

-                    .ClxnH40mg = dbRecordset("ClxnH40mg")

-                    .ClxnT40mg = dbRecordset("ClxnT40mg")

-                    .ClxnC_IM = dbRecordset("ClxnC_IM")

-                    .ClxnC_ACS = dbRecordset("ClxnC_ACS")

-                    .id = dbRecordset("id")

-                 End With

-                 

-                 All_QTR(index) = tmp_QTR

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_QTR_Record(dbConnection As Object, ByRef objQTR As tQTR)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM quarter " & _

-    "WHERE id=" & objQTR.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByQTR dbConnection, objQTR.entry_date

-    dbDelete_Hir_RecordsByQTR dbConnection, objQTR.entry_date

-    dbDelete_Ter_RecordsByQTR dbConnection, objQTR.entry_date

-    dbDelete_ACS_RecordsByQTR dbConnection, objQTR.entry_date

-       

-End Sub

-<<<<<<
-======================
-cdbQTR
->>>>>>
-Attribute VB_Name = "cdbQTR"

-Option Explicit

-

-Public Type tQTR_COMMON

-    qtr As tQTR

-    i_lcd As Long           ' число ЛПУ в СПИСКЕ

-    lcd() As tLPU_COMMON    ' список ЛПУ

-    c_beds As Long          ' сумма коек

-    c_bdgt_NFG As Long      ' общий бюджет на НФГ

-    c_bdgt_NMG As Long      ' общий бюджет на НМГ

-    c_bdgt_LPU As Long      ' общий бюджет на гепарины

-    c_sale_PLAN As Long     ' план продаж репа

-    c_sale_ALL As Long      ' продажи

-    c_sale_HIR As Long      ' в хирургии

-    c_sale_TER  As Long     ' в терапии

-    c_sale_CRD  As Long     ' в кардиологии

-    c_pat_HIR   As Long     ' пациенты

-    c_pat_TER   As Long     '

-    c_pat_CRD   As Long     '

-    c_pat_ALL   As Long     '

-    c_pat_LPU   As Long     ' Всего операций

-End Type

-

-Function Get_QTR_CommonList(ByRef qcd() As tQTR_COMMON) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_QTR_CommonList = dbGet_QTR_CommonList(dbConnection, qcd)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_CommonList(dbConnection As Object, ByRef qcd() As tQTR_COMMON) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim allQTR() As tQTR

-    i = dbGetAll_QTR_Records(dbConnection, allQTR, "%")

-    dbGet_QTR_CommonList = i

-    If i > 0 Then

-        ReDim qcd(i)

-        For i = 1 To UBound(allQTR)

-            With qcd(i)

-                .qtr = allQTR(i)

-                .c_beds = 0

-                .c_bdgt_NFG = 0

-                .c_bdgt_NMG = 0

-                .c_bdgt_LPU = 0

-                .c_sale_PLAN = 0

-                .c_pat_HIR = 0

-                .c_pat_TER = 0

-                .c_pat_CRD = 0

-                .c_pat_ALL = 0

-                .c_sale_HIR = 0

-                .c_sale_TER = 0

-                .c_sale_CRD = 0

-                .c_sale_ALL = 0

-                .c_pat_LPU = 0

-                

-                j = dbGet_LPU_CommonQTR(dbConnection, .lcd, .qtr)

-                .i_lcd = j

-                If j > 0 Then

-                    For j = 1 To UBound(.lcd)

-                        .c_beds = .c_beds + .lcd(j).lpu.beds

-                        .c_bdgt_NFG = .c_bdgt_NFG + .lcd(j).bdgt.bdgt_NFG

-                        .c_bdgt_NMG = .c_bdgt_NMG + .lcd(j).bdgt.bdgt_NMG

-                        .c_bdgt_LPU = .c_bdgt_LPU + .lcd(j).bdgt_LPU

-                        .c_sale_PLAN = .c_sale_PLAN + .lcd(j).bdgt.sale_plan

-                        .c_pat_HIR = .c_pat_HIR + .lcd(j).pat_HIR

-                        .c_pat_TER = .c_pat_TER + .lcd(j).pat_TER

-                        .c_pat_CRD = .c_pat_CRD + .lcd(j).pat_CRD

-                        .c_pat_ALL = .c_pat_ALL + .lcd(j).pat_ALL

-                        .c_sale_HIR = .c_sale_HIR + .lcd(j).sale_HIR

-                        .c_sale_TER = .c_sale_TER + .lcd(j).sale_TER

-                        .c_sale_CRD = .c_sale_CRD + .lcd(j).sale_CRD

-                        .c_sale_ALL = .c_sale_ALL + .lcd(j).sale_ALL

-                        .c_pat_LPU = .c_pat_LPU + .lcd(j).pat_LPU

-                    Next j

-                    

-                End If

-            End With

-        Next i

-    End If

-End Function

-

-Function GetLastQtr() As String

-    Dim s As String

-    Dim r As Range

-    Set r = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Do While r.Cells(1, 1) <> ""

-        s = r.Cells(1, 1)

-        Set r = r.Cells.Offset(1, 0)

-    Loop

-    GetLastQtr = s

-End Function

-

-Function GetNextQTR(ent_date As String) As String

-    Dim rd As Range

-    Dim idx As Integer

-    Dim b As Variant

-    Dim dlg As dlg_newQTR

-    Set dlg = New dlg_newQTR

-    

-    On Error GoTo l_exit

-    If ent_date = "" Then

-        Dim ir As Variant

-        idx = 0

-        dlg.Show

-        b = dlg.Tag

-            

-        If IsNumeric(b) Then

-            GetNextQTR = dlg.cbQTR

-        Else

-            GetNextQTR = ""

-        End If

-    Else

-        Set rd = Worksheets(VAR_SHEET).Range("Date_Lst")

-        idx = WorksheetFunction.Match(ent_date, rd, 0)

-        GetNextQTR = WorksheetFunction.index(rd, idx + 1, 1)

-    End If

-l_exit:

-End Function

-<<<<<<
-======================
-mRestView
->>>>>>
-Attribute VB_Name = "mRestView"

-Option Explicit

-

-Sub xlRestoreView()

-Attribute xlRestoreView.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute xlRestoreView.VB_ProcData.VB_Invoke_Func = " \n14"

-    With Application

-        .CommandBars("Standard").Visible = True

-        .CommandBars("Formatting").Visible = True

-        .DisplayFormulaBar = True

-        .DisplayStatusBar = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = True

-        .EditDirectlyInCell = True

-    End With

-End Sub

-<<<<<<
-======================
-dlg_newQTR
->>>>>>
-Attribute VB_Name = "dlg_newQTR"

-Attribute VB_Base = "0{2FC04B4C-EB99-433E-ACDB-A920D02B9B5B}{777B85CC-ADE3-4188-94C8-9E07DA8B5076}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mDec2TS
->>>>>>
-Attribute VB_Name = "mDec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-CHRT_LPU_BBL
->>>>>>
-Attribute VB_Name = "CHRT_LPU_BBL"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Unprotect

-    Range("view_key") = True

-    On Error Resume Next

-    ChangeLabels

-    Range("A1").Select

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Unprotect

-    Dim s As String

-    s = Range("ret_addr")

-    Protect UserInterfaceOnly:=True

-    Wks_select (s)

-End Sub

-

-Sub BCLabelChng_Click()

-    Unprotect

-    If Range("view_key") Then

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать названия"

-    Else

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать объемы"

-    End If

-    Range("view_key") = Not Range("view_key")

-    ChangeLabels

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub ChangeLabels()

-    Dim i As Integer

-    Dim offset_text As Integer

-    Dim src As Range

-    Set src = Range("CHRT_BBL_DATA")

-    

-    offset_text = 3

-    If Range("view_key") Then

-        offset_text = 4

-    End If

-    

-    On Error GoTo ExitLabel

-    

-    With ChartObjects(1).Chart

-        With .SeriesCollection(1)

-            For i = 1 To .Points.Count

-                On Error Resume Next

-                .Points(i).DataLabel.Characters.Text = Format(src.Cells(i, offset_text))

-            Next i

-        End With

-    End With

-ExitLabel:

-End Sub

-

-<<<<<<
-======================
-CHRT_PAT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PAT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-<<<<<<
-======================
-CHRT_PAT_LPU
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_nextQTR
->>>>>>
-Attribute VB_Name = "dlg_nextQTR"

-Attribute VB_Base = "0{3F7D7D75-90F6-4829-9E24-CA5391BB2A03}{A1A0F296-0D28-4123-8E38-82FA6EE6F2EF}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-

-<<<<<<
-======================
-cdbLPU
->>>>>>
-Attribute VB_Name = "cdbLPU"

-Option Explicit

-

-Public Type tLPU_COMMON

-    lpu As tLPU

-    bdgt As tBUDGET

-    i_hir As Long

-    hir() As tHIRURGIA

-    i_ter As Long

-    ter() As tTERAPIA

-    i_ACS As Long

-    ACS() As tACS

-    bdgt_LPU As Long

-    sale_HIR As Long

-    sale_TER As Long

-    sale_CRD As Long

-    sale_ALL As Long

-    pat_HIR As Long

-    pat_TER As Long

-    pat_CRD As Long

-    pat_ALL As Long     ' Сумма всех пациентов на клексане

-    pat_LPU As Long     ' Число потенциальных пациентов для продаж клексана

-End Type

-

-Function Get_LPU_CommonQTR(ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    Get_LPU_CommonQTR = dbGet_LPU_CommonQTR(dbConnection, lcd, objQTR)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_CommonQTR(dbConnection As Object, ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    i = dbGetAllLPUbyQTR(dbConnection, allLPU, objQTR.entry_date)

-    dbGet_LPU_CommonQTR = i

-    If i > 0 Then

-        ReDim lcd(i)

-        For i = 1 To UBound(allLPU)

-            dbGet_LPU_Common dbConnection, lcd(i), allLPU(i), objQTR

-        Next i

-    End If

-End Function

-

-Sub Get_LPU_Common(ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    dbGet_LPU_Common dbConnection, lcd, cLPU, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbGet_LPU_Common(dbConnection As Object, ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-

-    lcd.lpu = cLPU

-    lcd.bdgt = dbGet_BDGT_Record(dbConnection, cLPU.id, objQTR.entry_date)

-    lcd.i_hir = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, lcd.hir, cLPU.id, objQTR.entry_date)

-    lcd.i_ter = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, lcd.ter, cLPU.id, objQTR.entry_date)

-    lcd.i_ACS = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, lcd.ACS, cLPU.id, objQTR.entry_date)

-    With lcd

-        .bdgt_LPU = .bdgt.bdgt_NFG + .bdgt.bdgt_NMG

-        .pat_LPU = 0

-        If .i_hir > 0 Then

-            .pat_HIR = .hir(1).patients_ambulator_clexan + .hir(1).patients_stationar_clexan

-            .sale_HIR = objQTR.ClxnH20mg * (.hir(1).patients_ambulator_clexan_20mg + .hir(1).patients_stationar_clexan_20mg)

-            .sale_HIR = .sale_HIR + objQTR.ClxnH40mg * (.hir(1).patients_ambulator_clexan_40mg + .hir(1).patients_stationar_clexan_40mg)

-            .pat_LPU = .pat_LPU + .hir(1).operations_per_quarter

-        End If

-        If .i_ter > 0 Then

-            .pat_TER = .ter(1).patients_ambulator_clexan + .ter(1).patients_stationar_clexan

-            .sale_TER = .pat_TER * objQTR.ClxnT40mg

-            .pat_LPU = .pat_LPU + .ter(1).patients_per_quarter

-        End If

-        If .i_ACS > 0 Then

-            .pat_CRD = .ACS(1).patients_stationar_clexan

-            .sale_CRD = .pat_CRD * objQTR.ClxnC_ACS

-            .pat_LPU = .pat_LPU + .ACS(1).patients_per_quarter

-        End If

-        .pat_ALL = .pat_HIR + .pat_TER + .pat_CRD

-        .sale_ALL = .sale_HIR + .sale_TER + .sale_CRD

-    End With

-End Sub

-

-<<<<<<
-======================
-CHRT_PIE
->>>>>>
-Attribute VB_Name = "CHRT_PIE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-   

-    Unprotect

-    On Error Resume Next

-    Range("P5:Q24").Sort _

-        Key1:=Range("Q5"), _

-        Order1:=xlDescending, _

-        Header:=xlGuess, _

-        OrderCustom:=1, _

-        MatchCase:=False, _

-        Orientation:=xlTopToBottom

-        

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PLN_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PLN_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_BDGT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_BDGT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_LPU_delete
->>>>>>
-Attribute VB_Name = "dlg_LPU_delete"

-Attribute VB_Base = "0{91AE5FA0-01C7-4C10-9E5F-D1D2DDF29401}{5726592A-BC0A-4E79-A963-35D354045716}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlg_Mail
->>>>>>
-Attribute VB_Name = "dlg_Mail"

-Attribute VB_Base = "0{FB055133-927F-41FF-BC90-442833A40591}{11BCAB43-1EDD-440B-AB0E-20CD6E42E11A}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dbREP_id
->>>>>>
-Attribute VB_Name = "dbREP_id"

-Public Type tID_REP

-    id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Public Type tID_REP_COMMON

-    id_rep As tID_REP

-    i_qtr As Long

-    qtrs As tQTR_COMMON

-End Type

-<<<<<<
-======================
-cdbExport
->>>>>>
-Attribute VB_Name = "cdbExport"

-Option Explicit

-

-Function GetDBSN() As String

-    Dim n As Long

-    Randomize Timer

-    n = Int((100000000 - 1000000 + 1) * Rnd + 1000000)

-    GetDBSN = Dec2ThirtySix(n)

-End Function

-

-Sub dbExport()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim last_qtr As String

-    

-    On Error GoTo ErrHandler

-    

-    last_qtr = GetLastQTR_fromDB

-    If last_qtr = "" Then

-        MsgBox "Нет записей в базе данных. Экспорт невозможен.", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & last_qtr & "_" & GetDBSN() & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Данные экспортированы в файл:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для передачи", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-Exit Sub

-

-ErrHandler:

-    If err.number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-<<<<<<
-======================
-mRegs
->>>>>>
-Attribute VB_Name = "mRegs"

-Option Explicit

-

-Function GetRegionName(idx As Integer) As String

-    GetRegionName = Worksheets(REGS_SHEET).Range("LST_REGIONS").Cells(idx + 1, 1).Text

-End Function

-

-Function GetCityName(idx_reg As Integer, idx_city As Integer) As String

-    GetCityName = Worksheets(REGS_SHEET).Range("CITY_TABLES").Offset(idx_city + 1, idx_reg * 2).Text

-End Function

-

-Sub t()

-    Dim r As Integer

-    Dim c As Integer

-    Dim s As String

-    

-    r = 3

-    c = 3

-    s = GetRegionName(r)

-    s = s & ", " & GetCityName(r, c)

-    MsgBox s

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-<<<<<<
-======================
-xTEST_NUM
->>>>>>
-Attribute VB_Name = "xTEST_NUM"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mSerialTNT
->>>>>>
-Attribute VB_Name = "mSerialTNT"

-Option Explicit

-Const MAX_NUM1 As Integer = ThirtySixBase

-Const MAX_NUM2 As Integer = ThirtySixBase ^ 2 / 2

-Const MAX_NUM3 As Integer = ThirtySixBase

-

-Const USERID_BASE As Long = ThirtySixBase ^ 3

-

-Const SRVC_BASE As Integer = 1000

-Const SRVC_MAX As Integer = 1999

-

-Const ORG_BASE As Integer = 100

-Const ORG_MAX As Integer = 199

-

-Sub test()

-    Dim user() As String

-    Dim i

-    Dim r As Range

-    Dim s As String

-    

-    Application.ScreenUpdating = False

-    

-    Dim calc_type As Integer

-    calc_type = Application.Calculation

-    Application.Calculation = xlCalculationManual

-   

-    Set r = Worksheets("TEST_SN").Range("B3")

-    For i = 0 To 50000

-        user = getNextSerial(1000, 100)

-        r = "'" & user(1)

-        r.Offset(0, 1) = "'" & user(2)

-        r.Offset(0, 2) = Len(user(1))

-        r.Offset(0, 3) = Len(user(2))

-        If i <> 0 Then

-            s = "=IF(" & r.Address & "=" & r.Offset(-1, 0).Address & ",1,0)"

-            r.Offset(0, 4).Formula = s

-        End If

-        Set r = r.Offset(1, 0)

-    Next i

-    

-    Application.Calculation = calc_type

-    Application.ScreenUpdating = False

-

-End Sub

-

-Function getNextSerial(srv As Integer, org As Integer) As String()

-    Dim num1 As Integer

-    Dim num2 As Integer

-    Dim num3 As Integer

-    Dim rdate As Long

-    Dim userID As Long

-    

-    num1 = nextNumber(MAX_NUM1)

-    num2 = nextNumber(MAX_NUM2)

-    num3 = nextNumber(MAX_NUM3)

-    

-    rdate = get_sn_date

-    

-    userID = nextUserID

-    

-    Dim serial As String

-    

-    serial = "" & srv & org & rdate & userID & num1 & num2 & num3

-    

-    Dim serial_SN As Integer

-    

-    serial_SN = get_serial_check_sum(serial)

-    

-    Dim login_1 As Long

-    Dim login_2 As Long

-    

-    Dim pass_1 As Long

-    Dim pass_2 As Long

-    

-    login_1 = "" & userID & serial_SN

-    login_2 = "" & num3 & rdate

-    

-    pass_1 = "" & num1 & srv

-    pass_2 = "" & num2 & org

-    

-    Dim out(2) As String

-    out(1) = Dec2ThirtySix(login_1) & Dec2ThirtySix(login_2)

-    out(2) = Dec2ThirtySix(pass_1) & Dec2ThirtySix(pass_2)

-    

-    getNextSerial = out

-End Function

-

-Function get_serial_check_sum(id_sn As String) As Integer

-    Dim i As Integer

-    Dim s As String

-    Dim chk As Integer

-    

-    s = id_sn

-    chk = 0

-    While s <> ""

-        i = Left(s, 1)

-        chk = (chk + i) Mod 10

-        s = Right(s, Len(s) - 1)

-    Wend

-    get_serial_check_sum = chk

-End Function

-

-Function get_sn_date() As Long

-    Dim d_date As Long

-    d_date = (Year(Now()) Mod 10)

-    d_date = d_date * 10000

-    d_date = d_date + Month(Now()) * 100

-    d_date = d_date + Day(Now())

-    get_sn_date = d_date

-End Function

-

-Function nextUserID() As Long

-    nextUserID = USERID_BASE + Int(Rnd() * USERID_BASE)

-End Function

-

-Function nextNumber(base As Integer) As Integer

-    nextNumber = base + Int(Rnd() * base)

-End Function

-

-Function serial_check_id_sum(id_sn As String) As Integer

-    Dim i As Integer

-    Dim s As String

-    Dim chk As Integer

-    

-    s = id_sn

-    chk = 0

-    While s <> ""

-        i = Left(s, 1)

-        chk = (chk + i) Mod 10

-        s = Right(s, Len(s) - 1)

-    Wend

-    serial_check_id_sum = chk

-End Function

-

-<<<<<<
-======================
-xTEST_SER
->>>>>>
-Attribute VB_Name = "xTEST_SER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Dec2TS
->>>>>>
-Attribute VB_Name = "Dec2TS"

-Option Explicit

-

-'Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-'Const ThirtySixBase As Integer = 36

-

-Public Const ThirtySixNumbers As String = "123456789ABCDEFGHIJKLMNPQRSTUVWXYZ"

-Public Const ThirtySixBase As Integer = 34

-

-Function randSN(Optional n As Integer = 34) As String

-    Dim t(ThirtySixBase) As String

-    Dim i As Integer

-    Dim j, k As Integer

-    Dim r As String

-    

-    For i = 1 To UBound(t)

-        t(i) = Mid(ThirtySixNumbers, i, 1)

-    Next i

-    For i = 1 To n

-        j = Int((ThirtySixBase * Rnd) + 1)

-        k = i Mod ThirtySixBase + 1

-        r = t(k)

-        t(k) = t(j)

-        t(j) = r

-    Next i

-    r = ""

-    For i = 1 To UBound(t)

-        r = r + t(i)

-    Next i

-    randSN = r

-End Function

-Function Dec2ThirtySix(ByVal Dec As Long) As String

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Double

-    

-    ThirtySixStr = TS

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If ThirtySixStr = "" Then

-        Dec = 0

-    Else

-        While ThirtySixStr <> ""

-            lastdigit = Right(ThirtySixStr, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            ThirtySixStr = Mid(ThirtySixStr, 1, Len(ThirtySixStr) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-

-Sub test()

-    Dim l As Long

-    l = ThirtySix2Dec("2HPI")

-    l = ThirtySix2ChkSum("2HPI")

-End Sub

-

-Function ThirtySix2ChkSum(TS As String) As Integer

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim chksum As Integer

-    

-    ThirtySixStr = TS

-

-    chksum = 0

-    

-    If ThirtySixStr = "" Then

-        chksum = 0

-    Else

-        While ThirtySixStr <> ""

-            lastdigit = Right(ThirtySixStr, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit) - 1

-            chksum = (chksum + idx) Mod ThirtySixBase

-            ThirtySixStr = Left(ThirtySixStr, Len(ThirtySixStr) - 1)

-        Wend

-    End If

-

-    ThirtySix2ChkSum = chksum

-End Function

-<<<<<<
-======================
-newItemDlg
->>>>>>
-Attribute VB_Name = "newItemDlg"

-Attribute VB_Base = "0{0B5E9521-7808-446E-9E61-7D38E1C2651A}{1C691B41-AC71-4558-927D-1487F1C50C72}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub AddSYS_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub resetSYS_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-<<<<<<
-======================
-Dec2Hex
->>>>>>
-Attribute VB_Name = "Dec2Hex"

-Option Explicit

-

-

-Const HexNumbers As String = "0123456789ABCDEF"

-Const HexBase As Integer = 16

-Const ThirtyNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRST"

-Const ThirtyBase As Integer = 30

-

-Function sDec2Hex(Dec As Long) As String

-    Dim HexStr As String

-    Dim idx As Integer

-    

-    HexStr = ""

-    

-    If Dec = 0 Then

-        HexStr = Mid(HexNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod HexBase

-            HexStr = Mid(HexNumbers, idx + 1, 1) + HexStr

-            Dec = Dec \ HexBase

-        Wend

-    End If

-    sDec2Hex = HexStr

-End Function

-

-Function Hex2Dec(HexString As String) As Long

-    Dim digit As Integer

-    Dim ch As String

-    Dim hexpower As Integer

-    Dim hexnum As String

-    Dim decnumber As Long

-    

-    hexnum = UCase(HexString)

-    hexpower = 0

-    decnumber = 0

-    

-    While hexnum <> ""

-        ch = Right(hexnum, 1)

-        hexnum = Left(hexnum, Len(hexnum) - 1)

-        digit = InStr(1, HexNumbers, ch, vbBinaryCompare)

-        decnumber = decnumber + digit ' power(hexbase, hexpower)

-        hexpower = hexpower + 1

-    Wend

-    Hex2Dec = decnumber

-End Function

-

-

-

-Function Dec2Thirty(Dec As Long) As String

-    

-    Dim ThirtyStr As String

-    Dim idx As Integer

-    

-    ThirtyStr = ""

-    

-    If Dec = 0 Then

-        ThirtyStr = Mid(ThirtyNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtyBase

-            ThirtyStr = Mid(ThirtyNumbers, idx + 1, 1) + ThirtyStr

-            Dec = Dec \ ThirtyBase

-        Wend

-    End If

-    Dec2Thirty = ThirtyStr

-End Function

-

-<<<<<<
-======================
-TEST_SN
->>>>>>
-Attribute VB_Name = "TEST_SN"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ETIME
->>>>>>
-Attribute VB_Name = "ETIME"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Tools
->>>>>>
-Attribute VB_Name = "Tools"

-Option Explicit

-

-Function GetLinesCount(ByVal Location As Range) As Long

-    Dim n As Long

-    n = 0

-    Do While Location.Offset(n, 0) <> ""

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Sub hide_sheets()

-    Dim ws As Worksheet

-    Dim wsname As String

-    For Each ws In ThisWorkbook.Worksheets

-        wsname = ws.Name

-        ws.Protect UserInterfaceonly:=True

-        If Left(wsname, 1) = "x" Then

-            ws.EnableCalculation = False

-            ws.Visible = xlSheetVeryHidden

-        End If

-    Next ws

-End Sub

-

-Sub show_sheets()

-    Dim ws As Worksheet

-    Dim wsname As String

-    For Each ws In ThisWorkbook.Worksheets

-        ws.Unprotect

-        wsname = ws.Name

-        If Left(wsname, 1) = "x" Then

-            ws.EnableCalculation = True

-            ws.Visible = xlSheetVisible

-        End If

-    Next ws

-End Sub

-

-Sub check_sn_seria()

-    Dim r1 As Range

-    Dim r2 As Range

-    Dim i As Long

-    Dim j As Long

-    

-    Dim calc_type As Integer

-    calc_type = Application.Calculation

-    Application.Calculation = xlCalculationManual

-    

-    Set r1 = Worksheets("OEM_100").Range("B7")

-    Set r2 = Worksheets("OEM_100").Range("C7")

-        

-    i = GetLinesCount(r1)

-    j = GetLinesCount(r2)

-    

-    Dim as1() As String

-    Dim as2() As String

-    

-    ReDim as1(i)

-    ReDim as2(j)

-    

-    i = 1

-    While r1 <> ""

-        as1(i) = r1

-        as2(i) = r2

-        Set r1 = r1.Offset(1, 0)

-        Set r2 = r2.Offset(1, 0)

-        i = i + 1

-    Wend

-    

-    Set r1 = Worksheets("OEM_100").Range("E6")

-    Set r2 = Worksheets("OEM_100").Range("E7")

-    

-    r1.EntireColumn.ClearContents

-    r1.Offset(0, 1).EntireColumn.ClearContents

-    r1.Select

-    

-    For i = 1 To UBound(as1)

-        r1 = i

-        For j = 1 To UBound(as2)

-            If as1(i) = as2(j) Then

-                r2 = i

-                r2.Offset(0, 1) = j

-                r1.Offset(0, 1) = r1.Offset(0, 1) + 1

-            End If

-        Next j

-    Next i

-    If r2.Row = 7 Then

-        r2 = ";-)"

-    End If

-    Application.Calculation = calc_type

-    Application.Calculate

-End Sub

-

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Tools
->>>>>>
-Attribute VB_Name = "Tools"

-Option Explicit

-

-Sub Dom2_Stat()

-    Dim sr As Range

-    

-    Set sr = Worksheets("DOM2-Stat1w").Range("c7:e54")

-    

-    DelAllBlanks sr

-End Sub

-

-Sub Dom2_Stat2()

-    Dim sr As Range

-    

-    Set sr = Worksheets("DOM2-Stat2w").Range("e7:e92")

-    

-    DelAllPercentage sr

-End Sub

-

-Sub DelAllBlanks(ByRef r As Range)

-    Dim c As Range

-    Dim s_in As String

-    Dim s_out As String

-    Dim spaceIdx As Integer

-    

-    For Each c In r

-        s_in = c.Value2

-        s_out = Left(s_in, Len(s_in) - 4) + Right(s_in, 3)

-        c = s_out

-        c.NumberFormat = "###"

-    Next c

-End Sub

-

-Sub DelAllPercentage(ByRef r As Range)

-    Dim c As Range

-    Dim s_in As String

-    Dim s_out As String

-    Dim spaceIdx As Integer

-    

-    For Each c In r

-        s_in = c.Value2

-        s_in = Left(s_in, InStr(s_in, "(") - 2)

-        If Len(s_in) > 4 Then

-            s_out = Left(s_in, Len(s_in) - 4) + Right(s_in, 3)

-        Else

-            s_out = s_in

-        End If

-        c = s_out

-        c.NumberFormat = "###"

-    Next c

-End Sub

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Digit2String
->>>>>>
-Attribute VB_Name = "Digit2String"

-Sub main()

-

-Dim dd As Double

-Dim st As String

-

-dd = 21.2234

-

-' 0 - rub

-' 1 - y.e.

-

-st = Digit2String(dd, 1)

-

-End Sub

-

-Function Digit2String(digit As Double, p As Integer) As String

-

-' Макрос записан 18.06.01 mikle-2

-Dim W1(20) As String

-Dim W1a(20) As String

-Dim W10(10) As String

-Dim W100(10) As String

-Dim W1000(10) As String

-

-W1(0) = ""

-W1(1) = "один"

-W1(2) = "два"

-W1(3) = "три"

-W1(4) = "четыре"

-W1(5) = "пять"

-W1(6) = "шесть"

-W1(7) = "семь"

-W1(8) = "восемь"

-W1(9) = "девять"

-W1(10) = "десять"

-W1(11) = "одинадцать"

-W1(12) = "двенадцать"

-W1(13) = "тринадцать"

-W1(14) = "четырнадцать"

-W1(15) = "пятнадцать"

-W1(16) = "шестнадцать"

-W1(17) = "семнадцать"

-W1(18) = "восемнадцать"

-W1(19) = "девятнадцать"

-W1a(0) = ""

-W1a(1) = "одна"

-W1a(2) = "две"

-W1a(3) = "три"

-W1a(4) = "четыре"

-W1a(5) = "пять"

-W1a(6) = "шесть"

-W1a(7) = "семь"

-W1a(8) = "восемь"

-W1a(9) = "девять"

-W1a(10) = "десять"

-W1a(11) = "одинадцать"

-W1a(12) = "двенадцать"

-W1a(13) = "тринадцать"

-W1a(14) = "четырнадцать"

-W1a(15) = "пятнадцать"

-W1a(16) = "шестнадцать"

-W1a(17) = "семнадцать"

-W1a(18) = "восемнадцать"

-W1a(19) = "девятнадцать"

-W10(0) = ""

-W10(1) = "десять"

-W10(2) = "двадцать"

-W10(3) = "тридцать"

-W10(4) = "сорок"

-W10(5) = "пятьдесят"

-W10(6) = "шестьдесят"

-W10(7) = "семьдесят"

-W10(8) = "восемьдесят"

-W10(9) = "девяносто"

-W100(0) = ""

-W100(1) = "сто"

-W100(2) = "двести"

-W100(3) = "триста"

-W100(4) = "четыреста"

-W100(5) = "пятьсот"

-W100(6) = "шестьсот"

-W100(7) = "семьсот"

-W100(8) = "восемьсот"

-W100(9) = "девятьсот"

-

-Result = ""

-

-e = Int((digit - Int(digit)) * 100) ' decimal

-digit_long = Int(digit)

-a = Int(digit_long / 1000000) '32123456/1000000 = 32 -> 10^6

-b = digit_long - (a * 1000000) '32123456-32000000 = 123456

-c = Int(b / 1000) '123456/1000 = 123 -> 10^3

-d = b - (c * 1000) '123456-123*1000 = 456 -> 1

-

-Add = ""

-For i = 2 To 0 Step -1

-    m = Int(a / (10 ^ i))

-    If i = 2 Then

-        If m <> 0 Then

-            R = W100(m) + " "

-            Add = "миллионов "

-        End If

-    End If

-    If i = 1 Then

-        If m <> 0 Then

-            If a < 20 Then

-                Result = Result + W1(a) + " миллионов "

-                GoTo con_0

-            End If

-            R = W10(m) + " "

-            Add = "миллионов "

-        End If

-    End If

-    If i = 0 Then

-        If m <> 0 Then

-            If m >= 5 Then

-                R = W1(m) + " "

-                Add = "миллионов "

-            End If

-            If m <= 4 Then

-                R = W1(m) + " "

-                Add = "миллиона "

-            End If

-            If m = 1 Then

-                R = "один "

-                Add = "миллион "

-            End If

-        End If

-        

-    End If

-    a = a - (m * (10 ^ i))

-    Result = Result + R

-    R = ""

-Next i

-Result = Result + Add

-con_0:

-

-Add = ""

-For i = 2 To 0 Step -1

-    m = Int(c / (10 ^ i))

-    If i = 2 Then

-        If m <> 0 Then

-            R = W100(m) + " "

-            Add = "тысяч "

-        End If

-    End If

-    If i = 1 Then

-        If m <> 0 Then

-            If c < 20 Then

-                Result = Result + W1(c) + " тысяч "

-                GoTo con_1

-            End If

-            R = W10(m) + " "

-            Add = "тысяч "

-        End If

-    End If

-    If i = 0 Then

-        If m <> 0 Then

-            If m >= 5 Then

-                R = W1(m) + " "

-                Add = "тысяч "

-            End If

-            If m <= 4 Then

-                R = W1(m) + " "

-                Add = "тысячи "

-            End If

-            If m = 2 Then

-                R = "две "

-                Add = "тысячи "

-            End If

-            If m = 1 Then

-                R = "одна "

-                Add = "тысяча "

-            End If

-        End If

-    End If

-    c = c - (m * (10 ^ i))

-    Result = Result + R

-    R = ""

-Next i

-Result = Result + Add

-con_1:

-

-Add = ""

-For i = 2 To 0 Step -1

-    m = Int(d / (10 ^ i))

-    If i = 2 Then

-        If m <> 0 Then

-            R = W100(m) + " "

-        End If

-    End If

-    If i = 1 Then

-        If m <> 0 Then

-            If d < 20 Then

-                R = W1(d) + " "

-                Result = Result + R

-                GoTo con_2

-            End If

-            R = W10(m) + " "

-        End If

-    End If

-    If i = 0 Then

-        If m <> 0 Then

-            If p = 0 Then

-                R = W1(m) + " "

-            Else

-                R = W1a(m) + " "

-            End If

-        End If

-    End If

-    

-    d = d - (m * (10 ^ i))

-    Result = Result + R

-    R = ""

-Next i

-con_2:

-

-

-If p = 0 Then       ' rub

-    Result = Result + "руб. "

-End If

-

-For i = 1 To 0 Step -1

-    m = Int(e / (10 ^ i))

-    Result = Result + Chr$(m + Asc("0"))

-    e = e - (m * (10 ^ i))

-Next i

-

-If p = 0 Then       ' rub

-    Result = Result + " коп."

-Else                ' y.e.

-    Result = Result + "/100 у.е"

-End If

-

-Result(1) = Result(1) + Chr(Asc("A")) - Chr(Asc("a"))

-

-Digit2String = Result

-

-End Function

-

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag lengthProject Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    Call CleanUp

-End Sub

-

-Private Sub Workbook_Open()

-    Call CreateFormBar

-    frmFaceID.Show

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-'Global variables hold preious choices

-'for begining and ending FaceID numbers

-Public glbLastFirstID As Long

-Public glbLastLastID As Long

-

-

-Function CBShowButtonFaceIDs(lngIDStart As Long, _

-                             lngIDStop As Long)

-    ' This procedure creates a toolbar with buttons that display the

-    ' images associated with the values starting at lngIDStart and

-    ' ending at lngIDStop.

-    

-    Dim cbrNewToolbar   As CommandBar

-    Dim cmdNewButton    As CommandBarButton

-    Dim intCntr         As Integer

-    

-    ' Delete existing ShowFaceIds toolbar if it exists.

-    On Error Resume Next

-    Application.CommandBars("ShowFaceIds").Delete

-    frmFaceID.MousePointer = fmMousePointerHourGlass

-    ' Create a new toolbar.

-    Set cbrNewToolbar = Application.CommandBars.Add _

-        (Name:="ShowFaceIds", temporary:=True)

-    

-    ' Create a new button with an image matching the FaceId property value

-    ' indicated by intCntr.

-    For intCntr = lngIDStart To lngIDStop

-        Set cmdNewButton = cbrNewToolbar.Controls.Add(Type:=msoControlButton)

-        With cmdNewButton

-            ' Setting the FaceId property value specifies the appearance

-            ' but not the functionality of the button.

-            .FaceId = intCntr

-            .Caption = "FaceId = " & intCntr

-        End With

-    Next intCntr

-    

-    ' Show the images on the toolbar.

-    With cbrNewToolbar

-        .Width = 600

-        .Left = 100

-        .Top = 200

-        .Visible = True

-    End With

-    frmFaceID.MousePointer = fmMousePointerDefault

-End Function

-

-

-

-Public Function Validate()

-Dim lngTempNumber As Long

-

-'Procedure to check data entered by user

-With frmFaceID

-'If the first number requested < last number

-'then reverse them and rationalize

-'display next time form opens

-    If .txtFirstID Or .txtLastID > 0 Then

-        If CLng(.txtFirstID) > CLng(.txtLastID) Then

-           lngTempNumber = .txtFirstID

-           .txtFirstID = .txtLastID

-           .txtLastID = lngTempNumber

-         glbLastFirstID = .txtFirstID

-         glbLastLastID = .txtLastID

-        End If

- 'Only allow 200 FaceIDs per operation

- 'Call procedure to create FaceID values

- 'Take form out of memory

- 

-        If (.txtLastID - .txtFirstID) <= 200 Then

-            Call CBShowButtonFaceIDs(.txtFirstID, .txtLastID)

-            Unload frmFaceID

-        Else

-            MsgBox "Please request less than 200 FaceID's ", , "FaceID Number Finder"

-        End If

-    Else

-            .txtFirstID.SetFocus

-    End If

-End With

-End Function

-

-Public Function CleanUp()

-    On Error Resume Next

-   

-    Application.CommandBars("ShowFaceIds").Delete

-    Application.CommandBars("ShowForm").Delete

-      

-        

-End Function

-

-Public Function CreateFormBar()

-    Dim cmdBar As CommandBar

-    Dim btnForm As CommandBarButton

-'Delete the object if it already exists

-    On Error Resume Next

-    Application.CommandBars("ShowForm").Delete

-'Set the commandbar object variable

-    Set cmdBar = Application.CommandBars.Add

-        cmdBar.Name = "ShowForm"

-'Add a button

-    With cmdBar.Controls

-        

-        Set btnForm = .Add(msoControlButton)

-        

-    End With

-'Set the new button's properties

-    With btnForm

-        .Style = msoButtonIconAndCaption

-        .Caption = "Show FaceId Finder Form"

-        .FaceId = 2104

-        .OnAction = "OpenForm"

-        .TooltipText = "Show FaceID Form"

-    End With

-  ' Made visible in the form terminate event

-

-End Function

-

-Public Function OpenForm()

-'OnAction event procedure of ShowForm toolbar

-    frmFaceID.Show

-End Function

-

-

-<<<<<<
-======================
-frmFaceID
->>>>>>
-Attribute VB_Name = "frmFaceID"

-Attribute VB_Base = "0{5F1D3654-0CF0-11D2-B619-00AA00BBB974}{5F1D3641-0CF0-11D2-B619-00AA00BBB974}"

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-

-Private Sub cmdFaceId_Click()

-  

-  Dim strDefaultStatus As String

- 'Set up global variables with current requested values

-    glbLastFirstID = txtFirstID

-    glbLastLastID = txtLastID

- 'Detect current status bar value

- 'Set status bar message while FaceId's are generated

-    strDefaultStatus = Application.DisplayStatusBar

-    Application.DisplayStatusBar = True

-    Application.StatusBar = "Working on FaceID display please wait"

-    

-'Call validation procedure

-   

-    Call Validate

- 'Put Status bar back as it was

-    Application.DisplayStatusBar = False

-    Application.StatusBar = strDefaultStatus

-End Sub

-

-

-Private Sub txtFirstID_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)

-   'Test for non numeric entry then cancel or convert to long

-    If IsNumeric(txtFirstID) = False Then

-       txtFirstID = ""

-       Cancel = True

-    Else

-        txtFirstID = CLng(txtFirstID)

-    End If

-    

-End Sub

-

-

-Private Sub txtLastID_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)

-    'Test for non numeric entry then cancel or convert to long

-    If IsNumeric(txtLastID) = False Then

-       txtLastID = ""

-       Cancel = True

-    Else

-        txtLastID = CLng(txtLastID)

-    End If

-    

-End Sub

-

-Private Sub UserForm_Activate()

- 'Set up form with last requested values

- 'Make toolbar not visible

- On Error Resume Next

-    txtFirstID = glbLastFirstID

-    txtLastID = glbLastLastID

-    Application.CommandBars("ShowForm").Visible = False

-End Sub

-

-

-

-Private Sub UserForm_Terminate()

-    'Show toolbar if form is unloaded in

-    'Validate procedure of if X is clicked

-    Application.CommandBars("ShowForm").Visible = True

-End Sub

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Function GetRegion(idx As Integer) As String

-    GetRegion = Range("LST_REGIONS").Offset(i, 0)

-End Function

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Workbook_Activate()

-    Worksheets("Home").Select

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub ExportCopy()

-    ChartObjects("Chart 1").CopyPicture xlScreen, xlBitmap

-End Sub

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub ExportCopy()

-    Range("C4:G30").CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub ExportCopy()

-    Range("D44:H59").CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-PPExport
->>>>>>
-Attribute VB_Name = "PPExport"

-Option Explicit

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Sub ViewReport()

-    Dim ReportDoc As PowerPoint.Presentation

-    Set ReportDoc = GetObject(GetWBPath(ThisWorkbook.FullName) + "report.ppt")

-    ReportDoc.Application.Visible = True

-End Sub

-

-Sub CreateReportSlide(ReportDoc As PowerPoint.Presentation, Title As String)

-    Dim ReportPage As PowerPoint.Slide

-    

-    Set ReportPage = ReportDoc.Slides.Add(ReportDoc.Slides.Count + 1, ppLayoutBlank)

-    ReportPage.Shapes.Paste

-    ReportPage.Shapes.AddLabel(msoTextOrientationHorizontal, 20, 20, 640, 40) _

-      .TextFrame.TextRange.Text = Title

-End Sub

-

-Sub CreateReport()

-    Dim ReportApp As PowerPoint.Application

-    Dim ReportDoc As PowerPoint.Presentation

-    

-    Set ReportApp = CreateObject("PowerPoint.Application")

-    Set ReportDoc = ReportApp.Presentations.Add

-    

-    Dim i As Integer

-    For i = 1 To 4

-        ThisWorkbook.Worksheets("Sheet" + Format(i)).ExportCopy

-        CreateReportSlide ReportDoc, "Create slide name #" + Format(i)

-    Next i

-    

-    ReportDoc.SaveAs GetWBPath(ThisWorkbook.FullName) + "report"

-    ReportApp.Quit

-End Sub

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub ExportCopy()

-    ChartObjects("Chart 1").CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Workbook_Activate()

-    Worksheets("Home").Select

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub ExportCopy()

-    ChartObjects("Chart 1").CopyPicture xlScreen, xlBitmap

-End Sub

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub ExportCopy()

-    Range("C4:G30").CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub ExportCopy()

-    Range("D44:H59").CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-PPExport
->>>>>>
-Attribute VB_Name = "PPExport"

-Option Explicit

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Sub ViewReport()

-    Dim ReportDoc As PowerPoint.Presentation

-    Set ReportDoc = GetObject(GetWBPath(ThisWorkbook.FullName) + "report.ppt")

-    ReportDoc.Application.Visible = True

-End Sub

-

-Sub CreateReportSlide(ReportDoc As PowerPoint.Presentation, Title As String)

-    Dim ReportPage As PowerPoint.Slide

-    

-    Set ReportPage = ReportDoc.Slides.Add(ReportDoc.Slides.Count + 1, ppLayoutBlank)

-    ReportPage.Shapes.Paste

-    ReportPage.Shapes.AddLabel(msoTextOrientationHorizontal, 20, 20, 640, 40) _

-      .TextFrame.TextRange.Text = Title

-End Sub

-

-Sub CreateReport()

-    Dim ReportApp As PowerPoint.Application

-    Dim ReportDoc As PowerPoint.Presentation

-    

-    Set ReportApp = CreateObject("PowerPoint.Application")

-    Set ReportDoc = ReportApp.Presentations.Add

-    

-    Dim i As Integer

-    For i = 1 To 4

-        ThisWorkbook.Worksheets("Sheet" + Format(i)).ExportCopy

-        CreateReportSlide ReportDoc, "Create slide name #" + Format(i)

-    Next i

-    

-    ReportDoc.SaveAs GetWBPath(ThisWorkbook.FullName) + "report"

-    ReportApp.Quit

-End Sub

-

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub ExportCopy()

-    ChartObjects("Chart 1").CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-Sheet26
->>>>>>
-Attribute VB_Name = "Sheet26"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'Telfast_marketing'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    Set MyAppEvents.app = Application

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    If Application.Workbooks.Count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEL сейчас будут закрыты!", vbOKCancel, "$" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close Savechanges:=False

-            Exit Sub

-        End If

-    End If

-    cmSetStandaloneMode

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    Dim res

-    res = MsgBox( _

-        prompt:="Вы желаете завершить программу? Не правда ли?", _

-        Buttons:=vbQuestion + vbYesNo, _

-        Title:=PROGRAM_NAME _

-    )

-    If res <> vbYes Then

-        Cancel = True

-        Exit Sub

-    End If

-    

-    

-    Dim NewFileName, DefFileName, WBPath As String

-    NewFileName = MakeNewFileName( _

-                        Worksheets("home").Range("USER_NAME_F"), _

-                        Worksheets("home").Range("USER_NAME_S"), _

-                        Worksheets("data").Range("CITY_TABLES") _

-                        .Offset( _

-                            Worksheets("data").Range("IDX_CITY"), _

-                            (Worksheets("data").Range("IDX_REGION") - 1) * 2 _

-                        ) _

-                    )

-    DefFileName = MakeNewFileName( _

-                        DEF_USER_NAME_F, _

-                        DEF_USER_NAME_S, _

-                        Worksheets("data").Range("CITY_TABLES") _

-                        .Offset(DEF_IDX_CITY, (DEF_IDX_REGION - 1) * 2) _

-                    )

-    WBPath = GetWBPath(ThisWorkbook.FullName)

-    

-    If ThisWorkbook.Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-        If ThisWorkbook.Saved = False Then

-            If NewFileName <> DefFileName Then

-                dlgFname.Caption = PROGRAM_NAME

-                dlgFname.lbFName = NewFileName

-                dlgFname.lbFPath = WBPath

-                dlgFname.Show

-                NewFileName = WBPath & NewFileName

-                ThisWorkbook.SaveAs FileName:=NewFileName

-            Else

-                ThisWorkbook.Save

-            End If

-        End If

-    End If

-    Application.Caption = Empty

-    Application.CommandBars("Worksheet Menu Bar").Reset

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-        Dim MaxX, MaxY As Integer

-        With ThisWorkbook.Worksheets(HOME_SHEET)

-            MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-            MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-        End With

-

-        With ThisWorkbook.Application

-            .ScreenUpdating = False

-            .WindowState = xlNormal

-            .Height = MaxY

-            .Width = MaxX

-        End With

-End Sub

-

-

-

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INP_NO As Integer = 0

-Const INP_DAT As Integer = 1

-Const INP_TXT As Integer = 2

-Const INP_NUM As Integer = 3

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Select Case is_InputRange(Target)

-    Case INP_NUM

-        Check_Number Target, 1

-    Case INP_TXT

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE")

-

-    If is_InputRange(Target) <> INP_NO Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-Function is_InputRange(r As Range) As Integer

-    Dim test As Boolean

-    

-    is_InputRange = INP_NO

-    

-    If r.Column = Range("USER_NAME_F").Column Then

-        test = r.Row = Range("USER_NAME_S").Row _

-                        Or r.Row = Range("USER_NAME_F").Row

-        If test Then

-            is_InputRange = INP_TXT

-        End If

-    Else

-        If r.Column = Range("USER_PLAN").Column Then

-            test = r.Row = Range("USER_PLAN").Row _

-                            Or r.Row = Range("USER_FACT").Row _

-                            Or r.Row = Range("USER_BUDGET").Row _

-                            Or r.Row = Range("USER_SVNORM").Row

-            

-            Dim idx As Integer

-            idx = Worksheets(DATA_SHEET).Range("IDX_PERSONE")

-            

-            If test Then

-                is_InputRange = INP_NUM

-            Else

-                If r.Row = Range("USER_STAF").Row Then

-                    If idx = 1 Then

-                        is_InputRange = INP_NUM

-                    End If

-                End If

-            End If

-        End If

-    End If

-End Function

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INP_DOC As String = "C9"

-Const INP_APT As String = "C11"

-Const INP_ADV As String = "C13"

-Const INP_ACT As String = "C15"

-Const INP_VIP As String = "C17"

-Const INP_SUM As String = "C19"

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("C9").Select

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    

-    If is_InputRange(Target) Then

-        GoalSeekNow Range(INP_SUM), Target

-    Else

-        If Target.Row = Range(INP_SUM).Row And Target.Column = Range(INP_SUM).Column Then

-            Dim Addr As String

-            

-            Addr = INP_DOC & "," & INP_APT & "," & INP_ADV & "," & INP_ACT & "," & INP_VIP

-            RangeNormalize Range(Addr), Target

-            

-        End If

-    End If

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If is_InputRange(Target) Then

-        Check_Percent Target, 0.2

-    End If

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE")

-    

-    If is_InputRange(Target) Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-Function is_InputRange(r As Range) As Boolean

-    is_InputRange = r.Column = Range(INP_DOC).Column _

-                And ( _

-                    r.Row = Range(INP_DOC).Row _

-                    Or r.Row = Range(INP_APT).Row _

-                    Or r.Row = Range(INP_ADV).Row _

-                    Or r.Row = Range(INP_ACT).Row _

-                    Or r.Row = Range(INP_VIP).Row _

-                )

-End Function

-

-

-<<<<<<
-======================
-mHome
->>>>>>
-Attribute VB_Name = "mHome"

-Option Explicit

-

-Sub cboxPersone_Change()

-    With ThisWorkbook.Worksheets(HOME_SHEET)

-        Dim r As Range

-        Range("A1").Select

-        If .Shapes("cboxPersone").ControlFormat.ListIndex = 2 Then

-            .Unprotect

-            .Range("G15") = 1

-            If Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") Then

-                .Protect

-            End If

-        End If

-    End With

-End Sub

-

-Sub cboxArea_Change()

-    Dim GroupIdx, LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    With ThisWorkbook.Worksheets(DATA_SHEET)

-        GroupIdx = .Range("IDX_REGION")

-        .Range("IDX_CITY") = 1

-        NewRangeOffsetCol = (GroupIdx - 1) * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .Name & "!" & .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).Address

-        NewSumRange = .Name & "!" & .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).Address

-    End With

-    With ThisWorkbook.Worksheets(HOME_SHEET)

-        .Shapes("cboxCity").ControlFormat.ListFillRange = NewCbxRange

-        .Unprotect

-        .Range("G10").Formula = "=sum(" & NewSumRange & ")"

-        If Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") Then

-            .Protect

-        End If

-    End With

-End Sub

-

-Sub cboxCity_Change()

-    

-End Sub

-

-<<<<<<
-======================
-mCommands
->>>>>>
-Attribute VB_Name = "mCommands"

-Option Explicit

-

-Sub btHome_Click()

-    Worksheets(HOME_SHEET).Select

-    Worksheets(DATA_SHEET).Range("CUR_STATE") = 0

-End Sub

-

-Sub bt2Budget_Click()

-    Sheets("budget").Select

-End Sub

-

-

-Sub btBdgtPrev_Click()

-    btHome_Click

-End Sub

-

-Sub btBdgtNext_Click()

-    If check_budget(Range("BDGT_TOTAL")) Then

-        Sheets("Final").Select

-    End If

-End Sub

-

-Sub btDoc_Click()

-    If check_budget(Range("BDGT_TOTAL")) Then

-        Sheets("Doc").Select

-    End If

-End Sub

-

-Sub btDocVisit_Click()

-    Sheets("Doc.Visit").Select

-End Sub

-

-Sub btDocConf_Click()

-    Sheets("Doc.Conf").Select

-End Sub

-

-Sub btApt_Click()

-    If check_budget(Range("BDGT_TOTAL")) Then

-        Sheets("Apt").Select

-    End If

-End Sub

-

-Sub btAptVisit_Click()

-    Sheets("Apt.Visit").Select

-End Sub

-

-

-Sub btAptConf_Click()

-    Sheets("Apt.Conf").Select

-End Sub

-

-Sub btAdv_Click()

-    If check_budget(Range("BDGT_TOTAL")) Then

-        Sheets("Adv").Select

-    End If

-End Sub

-

-Sub btAdvPrev_Click()

-    If check_Adv Then

-        bt2Budget_Click

-    End If

-End Sub

-

-Sub btAct_Click()

-    If check_budget(Range("BDGT_TOTAL")) Then

-        Sheets("Act").Select

-    End If

-End Sub

-

-Sub btCost_Click()

-    If check_budget(Range("BDGT_TOTAL")) Then

-        Sheets("Cost").Select

-    End If

-End Sub

-

-Sub btCostPrev_Click()

-    If check_budget(Range("Cost!C17")) Then

-        Sheets("budget").Select

-    End If

-End Sub

-

-<<<<<<
-======================
-Sheet40
->>>>>>
-Attribute VB_Name = "Sheet40"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("C9").Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If is_InputRange(Target) Then

-        Check_Percent Target, 0.7

-    End If

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = True

-    If is_InputRange(Target) Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-

-Function is_InputRange(r As Range) As Boolean

-    is_InputRange = r.Column = Range("C9").Column _

-                    And r.Row = Range("C9").Row

-End Function

-

-

-<<<<<<
-======================
-Tools
->>>>>>
-Attribute VB_Name = "Tools"

-Option Explicit

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub test()

-    Dim str As String

-    str = GetWBPath(ThisWorkbook.FullName)

-End Sub

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-Attribute SetDesignFlagOn.VB_ProcData.VB_Invoke_Func = "E\n14"

-    Dim Sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each Sh In Worksheets

-        Sh.Unprotect

-        Sh.Visible = xlSheetVisible

-    Next Sh

-    Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-Attribute SetDesignFlagOff.VB_ProcData.VB_Invoke_Func = " \n14"

-    Application.ScreenUpdating = False

-    Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim Sh As Worksheet

-    For Each Sh In Worksheets

-        If Sh.Name <> "data" Then

-            Sh.Protect

-        Else

-            Sh.Visible = xlSheetVeryHidden

-        End If

-    Next Sh

-    Application.ScreenUpdating = True

-End Sub

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma training"

-Public Const PROGRAM_VERSION As String = "version 1.0"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-

-'Public Const ESTIMATION_DATE As Long = 20030329

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "N35"

-Public Const CITY_TABLES As String = "N30"

-

-

-Public Const DATA_SHEET As String = "data"

-

-' Костанты листа Home

-Public Const DEF_USER_NAME_F As String = "Иван"

-Public Const DEF_USER_NAME_S As String = "Тургенев"

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-Public Const HOME_SHEET As String = "Home"

-Public Const USER_NAME_F As String = "USER_NAME_F"

-Public Const USER_NAME_S As String = "USER_NAME_S"

-Public Const USER_PLAN As String = "USER_PLAN"

-Public Const USER_BUDGET As String = "USER_BUDGET"

-Public Const USER_FACT As String = "USER_FACT"

-

-' Костанты листа Adv

-Public Const ADV_SHEET As String = "Adv"

-Public Const ADV_SUM_CAP As String = "K9"

-Public Const ADV_SUM_DOC As String = "C17"

-Public Const ADV_SUM_APT As String = "E17"

-Public Const ADV_SUM_CAST As String = "G17"

-Public Const ADV_SUM_DIST As String = "I17"

-

-

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{81B9D41B-89F6-4B17-9F1D-45017FFC6C8F}{EF972C75-B6C6-407C-BAF6-74472541F2BB}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{0D5199B4-A753-4F74-A564-40388FABC4B0}{19DC56E2-E0F4-44B4-8B23-51B77A2564D5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-Sheet52
->>>>>>
-Attribute VB_Name = "Sheet52"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INPUTDATE_LT As String = "B11"

-Const INPUTDATE_RB As String = "B25"

-Const INPUTTEXT_LT As String = "C11"

-Const INPUTTEXT_RB As String = "C25"

-Const INPUTNUMB_LT As String = "F11"

-Const INPUTNUMB_RB As String = "I25"

-

-Const INP_NO As Integer = 0

-Const INP_DAT As Integer = 1

-Const INP_TXT As Integer = 2

-Const INP_NUM As Integer = 3

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("B11").Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Select Case is_InputRange(Target)

-    Case INP_NUM

-        Check_Number Target, 100

-    Case INP_TXT, INP_DAT

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = True

-    If is_InputRange(Target) <> 0 Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-Function is_InputRange(r As Range) As Integer

-    If is_InputArea(r, Range(INPUTDATE_LT), Range(INPUTDATE_RB)) Then

-        is_InputRange = INP_DAT

-    Else

-        If is_InputArea(r, Range(INPUTTEXT_LT), Range(INPUTTEXT_RB)) Then

-            is_InputRange = INP_TXT

-        Else

-            If is_InputArea(r, Range(INPUTNUMB_LT), Range(INPUTNUMB_RB)) Then

-                    is_InputRange = INP_NUM

-            Else

-                is_InputRange = INP_NO

-            End If

-        End If

-    End If

-End Function

-

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Function check_Adv() As Boolean

-    Dim b As Boolean

-    b = Abs(Range(ADV_SUM_CAP) - 1) < 0.0001 _

-        And Abs(Range(ADV_SUM_DOC) - 1) < 0.0001 _

-        And Abs(Range(ADV_SUM_APT) - 1) < 0.0001 _

-        And Abs(Range(ADV_SUM_CAST) - 1) < 0.0001 _

-        And Abs(Range(ADV_SUM_DIST) - 1) < 0.0001 _

-        Or Range("D13") = 0

-    If Not b Then

-        MsgBox "Не правильно составлен бюджет. Итоговые суммы должны быть = 100%"

-    End If

-    check_Adv = b

-End Function

-

-Function check_budget(r As Range) As Boolean

-    Dim f As Double

-    Dim b As Boolean

-    f = r

-    b = Abs(f - 1#) < 0.0001

-    If Not b Then

-        MsgBox "Не правильно составлен бюджет. Итоговые суммы должны быть = 100%"

-    End If

-    check_budget = b

-End Function

-

-Sub RangeNormalize(Src As Range, Dst As Range)

-    Dim f As Double

-    Dim c As Range

-    f = Dst

-    If f <> 0 Then

-        Src.Worksheet.Unprotect

-        For Each c In Src

-            c = c / f

-        Next c

-        If Not Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") Then

-            Src.Worksheet.Protect

-        End If

-    Else

-        MsgBox "Введите хотя бы одно число!"

-    End If

-End Sub

-

-Sub GoalSeekNow(Goal As Range, Target As Range)

-    Dim diff As Double

-    

-    diff = Goal - 1

-    If Abs(diff) > 0.0001 Then

-        If (diff > 0 And diff < Target) Or (diff < 0 And 1 - Target > Abs(diff)) Then

-            Goal.GoalSeek Goal:=1, ChangingCell:=Range(Target.Address)

-        Else

-            MsgBox "Автоподбор значения не возможен. Выберите другой параметр!"

-        End If

-    End If

-

-End Sub

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100."

-    End If

-End Sub

-

-Sub Check_Number(Target As Range, Def_Val As Double)

-    Dim test As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                test = True

-            End If

-        End If

-    Next r

-    

-    If test Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!"

-    End If

-    

-End Sub

-

-Function is_InputArea(r As Range, LT As Range, RB As Range) As Boolean

-    is_InputArea = r.Column >= LT.Column _

-                And r.Row >= LT.Row _

-                And r.Column <= RB.Column _

-                And r.Row <= RB.Row

-End Function

-

-<<<<<<
-======================
-Sheet70
->>>>>>
-Attribute VB_Name = "Sheet70"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INP_NUM_1_LT As String = "E14"

-Const INP_NUM_1_RB As String = "J14"

-Const INP_NUM_2_LT As String = "E16"

-Const INP_NUM_2_RB As String = "J16"

-Const INP_NUM_3_LT As String = "E18"

-Const INP_NUM_3_RB As String = "J18"

-Const INP_NUM_4_LT As String = "E20"

-Const INP_NUM_4_RB As String = "J20"

-Const INP_NUM_5_LT As String = "E22"

-Const INP_NUM_5_RB As String = "J22"

-

-Const INP_DAT_1_LT As String = "B14"

-Const INP_DAT_1_RB As String = "C14"

-Const INP_DAT_2_LT As String = "B16"

-Const INP_DAT_2_RB As String = "C16"

-Const INP_DAT_3_LT As String = "B18"

-Const INP_DAT_3_RB As String = "C18"

-Const INP_DAT_4_LT As String = "B20"

-Const INP_DAT_4_RB As String = "C20"

-Const INP_DAT_5_LT As String = "B22"

-Const INP_DAT_5_RB As String = "C22"

-

-Const INP_NO As Integer = 0

-Const INP_DAT As Integer = 1

-Const INP_TXT As Integer = 2

-Const INP_NUM As Integer = 3

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("B14").Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Select Case is_InputRange(Target)

-    Case INP_NUM

-        Check_Number Target, 100

-    Case INP_TXT, INP_DAT

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE")

-    

-    If is_InputRange(Target) <> INP_NO Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-

-Function is_InputRange(r As Range) As Integer

-    Dim test As Boolean

-    

-    test = is_InputArea(r, Range(INP_NUM_1_LT), Range(INP_NUM_1_RB)) _

-        Or is_InputArea(r, Range(INP_NUM_2_LT), Range(INP_NUM_2_RB)) _

-        Or is_InputArea(r, Range(INP_NUM_3_LT), Range(INP_NUM_3_RB)) _

-        Or is_InputArea(r, Range(INP_NUM_4_LT), Range(INP_NUM_4_RB)) _

-        Or is_InputArea(r, Range(INP_NUM_5_LT), Range(INP_NUM_5_RB))

-    If test Then

-       is_InputRange = INP_NUM

-    Else

-        test = is_InputArea(r, Range(INP_DAT_1_LT), Range(INP_DAT_1_RB)) _

-            Or is_InputArea(r, Range(INP_DAT_2_LT), Range(INP_DAT_2_RB)) _

-            Or is_InputArea(r, Range(INP_DAT_3_LT), Range(INP_DAT_3_RB)) _

-            Or is_InputArea(r, Range(INP_DAT_4_LT), Range(INP_DAT_4_RB)) _

-            Or is_InputArea(r, Range(INP_DAT_5_LT), Range(INP_DAT_5_RB))

-        If test Then

-            is_InputRange = INP_DAT

-        Else

-            is_InputRange = INP_NO

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-Sheet30
->>>>>>
-Attribute VB_Name = "Sheet30"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet41
->>>>>>
-Attribute VB_Name = "Sheet41"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const MEMBERSHIP As String = "D7"

-Const MILEAGE As String = "D9"

-Const INPUTAREA_LT As String = "C17"

-Const INPUTAREA_RB As String = "E24"

-

-Const ChangeCheckFlag As Boolean = False

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("C17").Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Select Case is_InputRange(Target)

-        Case 1

-            Check_Number Target, 1

-        Case 2

-            Check_Number Target, 15

-        Case 3

-            Check_Number Target, 50

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = True

-    If is_InputRange(Target) <> 0 Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-Function is_InputRange(r As Range) As Integer

-    If r.Column = Range(MEMBERSHIP).Column And r.Row = Range(MEMBERSHIP).Row Then

-        is_InputRange = 1

-    Else

-        If r.Column = Range(MILEAGE).Column And r.Row = Range(MILEAGE).Row Then

-            is_InputRange = 2

-        Else

-            If r.Column >= Range(INPUTAREA_LT).Column _

-                And r.Row >= Range(INPUTAREA_LT).Row _

-                And r.Column <= Range(INPUTAREA_RB).Column _

-                And r.Row <= Range(INPUTAREA_RB).Row Then

-                    is_InputRange = 3

-            Else

-                is_InputRange = 0

-            End If

-        End If

-    End If

-End Function

-

-

-<<<<<<
-======================
-Sheet42
->>>>>>
-Attribute VB_Name = "Sheet42"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INPUTDATE_LT As String = "B11"

-Const INPUTDATE_RB As String = "B25"

-Const INPUTTEXT_LT As String = "C11"

-Const INPUTTEXT_RB As String = "C25"

-Const INPUTNUMB_LT As String = "F11"

-Const INPUTNUMB_RB As String = "I25"

-

-Const INP_NO As Integer = 0

-Const INP_DAT As Integer = 1

-Const INP_TXT As Integer = 2

-Const INP_NUM As Integer = 3

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range(INPUTDATE_LT).Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Select Case is_InputRange(Target)

-    Case INP_NUM

-        Check_Number Target, 100

-    Case INP_TXT, INP_DAT

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = True

-    If is_InputRange(Target) <> 0 Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-Function is_InputRange(r As Range) As Integer

-    If is_InputArea(r, Range(INPUTDATE_LT), Range(INPUTDATE_RB)) Then

-        is_InputRange = INP_DAT

-    Else

-        If is_InputArea(r, Range(INPUTTEXT_LT), Range(INPUTTEXT_RB)) Then

-            is_InputRange = INP_TXT

-        Else

-            If is_InputArea(r, Range(INPUTNUMB_LT), Range(INPUTNUMB_RB)) Then

-                    is_InputRange = INP_NUM

-            Else

-                is_InputRange = INP_NO

-            End If

-        End If

-    End If

-End Function

-

-

-<<<<<<
-======================
-Sheet60
->>>>>>
-Attribute VB_Name = "Sheet60"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INP_DOC_LT As String = "C10"

-Const INP_DOC_RB As String = "C16"

-Const INP_APT_LT As String = "E10"

-Const INP_APT_RB As String = "E16"

-Const INP_CAST_LT As String = "G10"

-Const INP_CAST_RB As String = "G16"

-Const INP_DIST_LT As String = "I10"

-Const INP_DIST_RB As String = "I16"

-Const CAP_DOC As String = "C9"

-Const CAP_APT As String = "E9"

-Const CAP_CAST As String = "G9"

-Const CAP_DIST As String = "I9"

-

-

-Const INP_NO As Integer = 0

-Const INP_CAP As Integer = 1

-Const INP_DOC As Integer = 2

-Const INP_APT As Integer = 3

-Const INP_CAST As Integer = 4

-Const INP_DIST As Integer = 5

-

-Const INP_SUM_CAP As Integer = 11

-Const INP_SUM_DOC As Integer = 12

-Const INP_SUM_APT As Integer = 13

-Const INP_SUM_CAST As Integer = 14

-Const INP_SUM_DIST As Integer = 15

-

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("C9").Select

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim Inp As Integer

-    Dim Addr As String

-    Inp = is_InputRange(Target)

-    Select Case is_InputRange(Target)

-        Case INP_NO

-            Cancel = False

-        

-        Case INP_CAP

-            GoalSeekNow Range(ADV_SUM_CAP), Target

-        

-        Case INP_DOC

-            GoalSeekNow Range(ADV_SUM_DOC), Target

-        

-        Case INP_APT

-            GoalSeekNow Range(ADV_SUM_APT), Target

-        

-        Case INP_CAST

-            GoalSeekNow Range(ADV_SUM_CAST), Target

-        

-        Case INP_DIST

-            GoalSeekNow Range(ADV_SUM_DIST), Target

-        

-        Case INP_SUM_CAP

-            Addr = CAP_DOC & "," & CAP_APT & "," & CAP_CAST & "," & CAP_DIST

-            RangeNormalize Range(Addr), Target

-        

-        Case INP_SUM_DOC

-            Addr = INP_DOC_LT & ":" & INP_DOC_RB

-            RangeNormalize Range(Addr), Target

-        

-        Case INP_SUM_APT

-            Addr = INP_APT_LT & ":" & INP_APT_RB

-            RangeNormalize Range(Addr), Target

-        

-        Case INP_SUM_CAST

-            Addr = INP_CAST_LT & ":" & INP_CAST_RB

-            RangeNormalize Range(Addr), Target

-        

-        Case INP_SUM_DIST

-            Addr = INP_DIST_LT & ":" & INP_DIST_RB

-            RangeNormalize Range(Addr), Target

-    End Select

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Select Case is_InputRange(Target)

-    Case INP_CAP

-        Check_Percent Target, 0.25

-    Case INP_DOC, INP_APT, INP_CAST, INP_DIST

-        Check_Percent Target, 0.15

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE")

-    

-    If is_InputRange(Target) > 0 Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-

-Function is_InputRange(r As Range) As Integer

-    is_InputRange = INP_NO

-    If r.Row = Range(CAP_DOC).Row Then

-        If r.Column = Range(CAP_DOC).Column _

-                Or r.Column = Range(CAP_APT).Column _

-                Or r.Column = Range(CAP_CAST).Column _

-                Or r.Column = Range(CAP_DIST).Column Then

-            is_InputRange = INP_CAP

-        End If

-        If r.Column = Range(ADV_SUM_CAP).Column Then

-            is_InputRange = INP_SUM_CAP

-        End If

-    Else

-        If is_InputArea(r, Range(INP_DOC_LT), Range(INP_DOC_RB)) Then

-            is_InputRange = INP_DOC

-        Else

-            If is_InputArea(r, Range(INP_APT_LT), Range(INP_APT_RB)) Then

-                is_InputRange = INP_APT

-            Else

-                If is_InputArea(r, Range(INP_CAST_LT), Range(INP_CAST_RB)) Then

-                    is_InputRange = INP_CAST

-                Else

-                    If is_InputArea(r, Range(INP_DIST_LT), Range(INP_DIST_RB)) Then

-                        is_InputRange = INP_DIST

-                    Else

-                        If r.Row = Range(ADV_SUM_DOC).Row Then

-                            If r.Column = Range(ADV_SUM_DOC).Column Then

-                                is_InputRange = INP_SUM_DOC

-                            End If

-                            If r.Column = Range(ADV_SUM_APT).Column Then

-                                is_InputRange = INP_SUM_APT

-                            End If

-                            If r.Column = Range(ADV_SUM_APT).Column Then

-                                is_InputRange = INP_SUM_APT

-                            End If

-                            If r.Column = Range(ADV_SUM_CAST).Column Then

-                                is_InputRange = INP_SUM_CAST

-                            End If

-                            If r.Column = Range(ADV_SUM_DIST).Column Then

-                                is_InputRange = INP_SUM_DIST

-                            End If

-                        End If

-                    End If

-                End If

-            End If

-        End If

-    End If

-End Function

-

-

-<<<<<<
-======================
-Sheet50
->>>>>>
-Attribute VB_Name = "Sheet50"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("C9").Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If is_InputRange(Target) Then

-        Check_Percent Target, 0.7

-    End If

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = True

-    If is_InputRange(Target) Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-

-Function is_InputRange(r As Range) As Boolean

-    is_InputRange = r.Column = Range("C9").Column _

-                    And r.Row = Range("C9").Row

-End Function

-

-

-<<<<<<
-======================
-Sheet51
->>>>>>
-Attribute VB_Name = "Sheet51"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INPUTAREA_LT As String = "C17"

-Const INPUTAREA_RB As String = "E20"

-

-Const ChangeCheckFlag As Boolean = False

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("C17").Select

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If is_InputRange(Target) <> 0 Then

-        Check_Number Target, 50

-    End If

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE") = True

-    If is_InputRange(Target) <> 0 Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-Function is_InputRange(r As Range) As Integer

-    If is_InputArea(r, Range(INPUTAREA_LT), Range(INPUTAREA_RB)) Then

-        is_InputRange = 3

-    Else

-        is_InputRange = 0

-    End If

-End Function

-

-

-<<<<<<
-======================
-Sheet80
->>>>>>
-Attribute VB_Name = "Sheet80"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const INP_DOC As String = "C9"

-Const INP_APT As String = "C11"

-Const INP_CUST As String = "C13"

-Const INP_DIST As String = "C15"

-Const INP_SUM As String = "C17"

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Range("C9").Select

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    

-    If is_InputRange(Target) Then

-        GoalSeekNow Range(INP_SUM), Target

-    Else

-        If Target.Row = Range(INP_SUM).Row And Target.Column = Range(INP_SUM).Column Then

-            Dim Addr As String

-            

-            Addr = INP_DOC & "," & INP_APT & "," & INP_CUST & "," & INP_DIST

-            RangeNormalize Range(Addr), Target

-            

-        End If

-    End If

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If is_InputRange(Target) Then

-        Check_Percent Target, 0.25

-    End If

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim DebugMode As Boolean

-    DebugMode = Worksheets(DATA_SHEET).Range("BOOL_DESIGN_MODE")

-    

-    If is_InputRange(Target) Or DebugMode Then

-        Unprotect

-    Else

-        Protect

-    End If

-End Sub

-

-Function is_InputRange(r As Range) As Boolean

-    is_InputRange = r.Column = Range(INP_DOC).Column _

-                And ( _

-                    r.Row = Range(INP_DOC).Row _

-                    Or r.Row = Range(INP_APT).Row _

-                    Or r.Row = Range(INP_CUST).Row _

-                    Or r.Row = Range(INP_DIST).Row _

-                )

-End Function

-

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Print"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 4

-                        .OnAction = "cmPrint"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-'                With .Controls

-'                    With .Add(msoControlButton)

-'                        .Caption = "&Contents"

-'                        .Style = msoButtonIconAndCaption

-'                        .FaceId = 49

-'                        .OnAction = "cmHelpContents"

-'                    End With

-'                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(Flag As Boolean)

-    If Flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars("Worksheet Menu Bar")

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    dlgAbout.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlgAbout.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlgAbout.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlgAbout.Show

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-        helppath = "hh.exe " & .Path & "\Telfast.chm"

-        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub cmSetStandaloneMode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-    ThisWorkbook.Worksheets("home").Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    rp = common_pwd

-    dlgGetPwd.edPwd = ""

-    dlgGetPwd.Show

-    If dlgGetPwd.edPwd = rp Then

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-    Else

-        cmSetStandaloneMode

-    End If

-    ThisWorkbook.Worksheets("home").Select

-End Sub

-

-

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If Application.Workbooks.Count > 1 Then

-        wbname = Wb.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKCancel, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            Wb.Close Savechanges:=False

-        End If

-        Exit Sub

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub GetState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.Count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.Name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars("Worksheet Menu Bar").Visible = False

-End Sub

-

-

-Public Sub RestoreState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars("Worksheet Menu Bar").Visible = True

-End Sub

-

-

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        cmHelpContents

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Telfast bar"

-Public Const common_pwd As Long = 31415926

-

-

-Sub SetEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    With Application

-        .Caption = PROGRAM_NAME

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .GetState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(HOME_SHEET).Select

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                     cWindow.DisplayHeadings = True

-                Next

-            End If

-        Next

-        .Worksheets(HOME_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu (True)

-        End If

-        With mobjAppState

-            .RestoreState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{6B54EA33-E5D1-44C0-BC3C-E5960329B246}{639FA6FC-FBAC-44B4-ACC5-7DAF95DA47F4}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    

-    dlgPrint.cbMainReport = True

-    dlgPrint.cbMainBudget = False

-    dlgPrint.cbSrcData = False

-    dlgPrint.cbAllSheets = False

-    

-    dlgPrint.Show

-    

-    If dlgPrint.Tag = vbCancel Then

-        Exit Sub

-    End If

-    

-    Dim PrnIdx As Integer

-    

-    With dlgPrint

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("home", "budget", "Final")

-    Case 1111

-        plist = Array("home", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("home")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-dlgFname
->>>>>>
-Attribute VB_Name = "dlgFname"

-Attribute VB_Base = "0{AB4D9ABD-F40E-4C39-8FE4-0625E69E5365}{2CC3E532-33AC-44D8-9195-34917AF21E8C}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btOK_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Sub Macro1()

-Attribute Macro1.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute Macro1.VB_ProcData.VB_Invoke_Func = " \n14"

-'

-' Macro1 Macro

-' Macro recorded 25.09.2003 by nick

-'

-

-'

-    Charts.Add

-    ActiveChart.ChartType = xlBubble

-    ActiveChart.SetSourceData Source:=Sheets("file1").Range("H2:J11"), PlotBy:= _

-        xlColumns

-    ActiveChart.Location Where:=xlLocationAsObject, Name:="file1"

-    With ActiveChart

-        .HasTitle = True

-        .ChartTitle.Characters.Text = "Матрица"

-        .Axes(xlCategory, xlPrimary).HasTitle = True

-        .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Доля клексана"

-        .Axes(xlValue, xlPrimary).HasTitle = True

-        .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Количество больных"

-    End With

-    With ActiveChart.Axes(xlCategory)

-        .HasMajorGridlines = True

-        .HasMinorGridlines = False

-    End With

-    With ActiveChart.Axes(xlValue)

-        .HasMajorGridlines = True

-        .HasMinorGridlines = False

-    End With

-    ActiveChart.HasLegend = False

-    ActiveChart.ApplyDataLabels Type:=xlDataLabelsShowValue, LegendKey:=False

-    ActiveChart.SeriesCollection(1).Select

-    ActiveChart.SeriesCollection(1).DataLabels.Select

-    ActiveChart.SeriesCollection(1).Select

-    ActiveChart.SeriesCollection(1).DataLabels.Select

-    ActiveChart.SeriesCollection(1).Points(9).DataLabel.Select

-    Selection.Characters.Text = "8379 №1"

-    Selection.AutoScaleFont = False

-    With Selection.Characters(Start:=1, Length:=7).Font

-        .Name = "Arial"

-        .FontStyle = "Обычный"

-        .Size = 10

-        .Strikethrough = False

-        .Superscript = False

-        .Subscript = False

-        .OutlineFont = False

-        .Shadow = False

-        .Underline = xlUnderlineStyleNone

-        .ColorIndex = xlAutomatic

-    End With

-    ActiveChart.Axes(xlValue).MajorGridlines.Select

-End Sub

-Sub Macro2()

-Attribute Macro2.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute Macro2.VB_ProcData.VB_Invoke_Func = " \n14"

-'

-' Macro2 Macro

-' Macro recorded 25.09.2003 by nick

-'

-

-'

-    Application.CutCopyMode = False

-    With ActiveChart.ChartGroups(1)

-        .VaryByCategories = True

-        .ShowNegativeBubbles = False

-        .SizeRepresents = xlSizeIsArea

-        .BubbleScale = 100

-    End With

-End Sub

-Sub Macro3()

-Attribute Macro3.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute Macro3.VB_ProcData.VB_Invoke_Func = " \n14"

-'

-' Macro3 Macro

-' Macro recorded 25.09.2003 by nick

-'

-

-'

-    ActiveChart.SeriesCollection(1).DataLabels.Select

-    ActiveChart.SeriesCollection(1).Points(6).DataLabel.Select

-    ActiveChart.Axes(xlValue).MajorGridlines.Select

-    ActiveChart.SeriesCollection(1).DataLabels.Select

-    ActiveChart.SeriesCollection(1).Points(6).DataLabel.Select

-    Selection.Characters.Text = "9847 №2"

-    Selection.AutoScaleFont = False

-    With Selection.Characters(Start:=1, Length:=7).Font

-        .Name = "Arial"

-        .FontStyle = "Обычный"

-        .Size = 12

-        .Strikethrough = False

-        .Superscript = False

-        .Subscript = False

-        .OutlineFont = False

-        .Shadow = False

-        .Underline = xlUnderlineStyleNone

-        .ColorIndex = xlAutomatic

-    End With

-    ActiveChart.PlotArea.Select

-End Sub

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Private Sub Workbook_Open()

-    xlRestoreView

-End Sub

-

-Sub xlRestoreView()

-    Application.CommandBars("Standard").Visible = True

-    Application.CommandBars("Formatting").Visible = True

-    Application.DisplayFormulaBar = True

-End Sub

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'ClexanePM'
-Quirk - duff tag length======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-

-    Application.EnableEvents = True

-    Set MyAppEvents.app = Application

-    

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    

-    MyAppEvents.CheckWorkBooksArround ThisWorkbook

-    

-    cmSetStandaloneMode

-    

-    Application.ScreenUpdating = True

-'    CheckUser

-

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).Select

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).update_history

-    Application.Calculate

-

-End Sub

-

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    

-    Dim RestMode As Boolean

-    RestMode = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE")

-    

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-'        If RestMode Then

-            ThisWorkbook.Saved = True

-'        Else

-'            ThisWorkbook.Save

-'        End If

-    End If

-    If RestMode Then

-        xlRestoreView

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    End If

-    Application.Caption = Empty

-    Application.CommandBars(STDBAR_NAME).Reset

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-    Dim MaxX, MaxY As Integer

-    With ThisWorkbook.Worksheets(TITLE_SHEET)

-        MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-        MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-    End With

-

-    With ThisWorkbook.Application

-        .ScreenUpdating = False

-        .WindowState = xlNormal

-        .Height = MaxY

-        .Width = MaxX

-    End With

-End Sub

-

-

-

-

-

-<<<<<<
-======================
-REP_QTR
->>>>>>
-Attribute VB_Name = "REP_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CQTR_QT As Integer = 0

-Const CQTR_ID As Integer = 1

-Const CQTR_PLN As Integer = 2

-Const CQTR_FCT As Integer = 3

-Const CQTR_BDG As Integer = 4

-Const CQTR_CNT As Integer = 5

-Const CQTR_BEDS As Integer = 6

-Const CQTR_HIR As Integer = 7

-Const CQTR_TER As Integer = 8

-Const CQTR_CRD As Integer = 9

-Const CQTR_CLXN_BDG As Integer = 10

-Const CQTR_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Const LOCAL_ENT_DATE As String = "QTR_SEL"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("REP_QTR")

-        s = .Range("D5") & " " & .Range("D4") & ", " & .Range("H5") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub update_history()

-    Dim objQTR() As tQTR

-    Dim i As Long

-    Dim r As Range

-    Dim cRep As tREPID

-    Dim rm_id As Long

-

-    rm_id = Range("RM_ID")

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    Range("D4") = cRep.LastName

-    Range("D5") = cRep.FirstName

-

-    Range("H4") = GetRegionName(cRep.Region)

-    Range("H5") = GetCityName(cRep.Region, cRep.City)

-

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetAll_QTR_Records_by_REP(objQTR, "%", cRep.rep_id, rm_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CQTR_QT) = objQTR(i).entry_date

-        Next i

-    End If

-    Dim qcd() As tQTR_COMMON

-    i = Get_QTR_CommonList_by_REP(qcd, "%", cRep.rep_id, rm_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(qcd)

-            r.Offset(i - 1, CQTR_QT) = qcd(i).qtr.entry_date

-            r.Offset(i - 1, CQTR_ID) = qcd(i).qtr.id

-            r.Offset(i - 1, CQTR_PLN) = qcd(i).qtr.sale_PLAN

-            r.Offset(i - 1, CQTR_FCT) = qcd(i).c_sale_ALL

-            r.Offset(i - 1, CQTR_BDG) = qcd(i).c_bdgt_LPU

-            r.Offset(i - 1, CQTR_CNT) = qcd(i).i_lcd

-            r.Offset(i - 1, CQTR_BEDS) = qcd(i).c_beds

-            r.Offset(i - 1, CQTR_HIR) = qcd(i).c_pat_HIR

-            r.Offset(i - 1, CQTR_TER) = qcd(i).c_pat_TER

-            r.Offset(i - 1, CQTR_CRD) = qcd(i).c_pat_CRD

-            If qcd(i).c_bdgt_LPU <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_BDG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_LPU

-            End If

-            If qcd(i).c_bdgt_NMG <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_NMG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CQTR_CRD + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-

-Sub Draw_PLN_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_FCT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PLN_QTR").Range("title") = MakeChartTitle

-End Sub

-

-Sub Draw_BDGT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_CLXN_NMG + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_BDGT_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Public Sub cbxRepQtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CQTR_ID + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    i = currRange.Column - Range(CINP_AREA).Column

-

-    QTR_ID = r

-

-    If QTR_ID = 0 Then

-        Worksheets(VAR_SHEET).Range("USER_ACTION") = 1

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        If i > CQTR_FCT Then

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-            Range("LAST_FOCUS") = currRange.address

-        Else

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 3

-            Range("LAST_FOCUS") = currRange.address

-        End If

-    End If

-    Cancel = True

-    btHomeDo_IT

-End Sub

-

-<<<<<<
-======================
-mRep_QTR
->>>>>>
-Attribute VB_Name = "mRep_QTR"

-Option Explicit

-

-Sub NoFunc()

-    MsgBox "Функция не доступна", vbOKOnly, PROGRAM_NAME

-End Sub

-

-Sub DO_Price_qtr(ent_date As String)

-    Dim qtr As tQTR

-    Dim res As Integer

-    Dim cRep As tREPID

-    Dim rm_id As Long

-

-    rm_id = Worksheets(REP_QTR_SHEET).Range("RM_ID")

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    qtr = Get_QTR_Record_by_REP(ent_date, cRep.rep_id, cRep.rm_id)

-

-    If qtr.id = 0 Then

-        qtr.entry_date = ent_date

-

-        With Worksheets(VAR_SHEET)

-            qtr.ClxnH20mg = .Range("ClxnH20mg")

-            qtr.ClxnH40mg = .Range("ClxnH40mg")

-            qtr.ClxnT40mg = .Range("ClxnT40mg")

-            qtr.ClxnC_ACS = .Range("ClxnC_ACS")

-            qtr.ClxnC_IM = .Range("ClxnC_IM")

-        End With

-    End If

-

-    Dim dlg_nq As dlg_nextQTR

-    Set dlg_nq = New dlg_nextQTR

-

-    With dlg_nq

-        .tb_qtr_name = qtr.entry_date

-        .tb_bdgt_avts = qtr.sale_PLAN

-        .tb_qtr_name = qtr.entry_date

-        .tb_ClxnH20mg = qtr.ClxnH20mg

-        .tb_ClxnH40mg = qtr.ClxnH40mg

-        .tb_ClxnT40mg = qtr.ClxnT40mg

-        .tb_ClxnC_ACS = qtr.ClxnC_ACS

-        .tb_ClxnC_IM = qtr.ClxnC_IM

-    End With

-

-    dlg_nq.Show

-End Sub

-

-Sub DO_Edit_qtr(ent_date As String)

-    If ent_date = "" Then

-        NoFunc

-    Else

-        Dim rep_id As Long

-        rep_id = Worksheets(REP_QTR_SHEET).Range("REP_ID")

-        With ThisWorkbook.Worksheets("LPU_LIST")

-            .Range("VIEW_ONLY") = True

-            .setEnt_date (ent_date)

-            .Range("REP_ID") = rep_id

-            .Select

-        End With

-    End If

-End Sub

-

-Sub DO_Delete_qtr(ent_date As String)

-    If ent_date <> "" Then

-        MsgBox "Удалить данные за период [" & ent_date & "] нельзя ", vbOKOnly, PROGRAM_NAME

-    End If

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-

-Sub btHomeDo_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    idx = Worksheets(VAR_SHEET).Range("USER_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).getEnt_date()

-    Select Case idx

-        Case 1

-            NoFunc

-            ' Обновляем экран

-        Case 2

-            DO_Edit_qtr ent_date

-        Case 3

-            DO_Price_qtr ent_date

-        Case 4

-            NoFunc

-    End Select

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-Sub Delete_qtr()

-'    Dim ent_date As String

-'    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-'    DO_Delete_qtr ent_date

-End Sub

-

-Sub btREP_QTR_RET_IT()

-    Dim s As String

-    With Worksheets("REP_QTR")

-        .Range("LAST_FOCUS") = ""

-        s = .Range("ret_addr")

-        .Range("ret_addr") = ""

-    End With

-    If s <> "" Then

-        ThisWorkbook.Worksheets(s).Select

-    Else

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public ppReport As New cPPReport

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane[PM]"

-Public Const PROGRAM_VERSION As String = "Clexane[PM] ver 1.1"

-Public Const PROGRAM_FILENAME As String = "clexane-pm"

-Public Const PROGRAM_BACKUPNAME As String = "pm-backup-"

-Public Const PROGRAM_EXPORTNAME As String = "pm-ex-"

-Public Const PROGRAM_IMPORTNAME As String = "rm-ex*"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-Public Const CHART_DEF_TITLE As String = "* * *"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20031207

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "O41"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-Public Const RM_QTR_SHEET As String = "RM_QTR"

-Public Const PRJ_QTR_SHEET As String = "PRJ_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-Function time_correct(end_date As Long, ByVal theDate As Date) As Boolean

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-    If end_date = NO_ESTIMATION_DATE Then

-        time_correct = True

-        Exit Function

-    End If

-    

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    

-    time_correct = CurDate <= end_date

-    

-End Function

-

-Sub EnableRun(end_date As Long)

-    If Not time_correct(end_date, Now) Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-Sub t()

-    EnableRun ESTIMATION_DATE

-End Sub

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Sub OpenPPT()

-    ppReport.ReportView

-End Sub

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-

-End Sub

-

-Function Double2Str(ByVal d As Double, ByVal precision As Integer, Optional Delim As String = ".") As String

-    Dim s As String

-    If Not precision > 0 Then

-        s = Round(d)

-    Else

-        Dim i As Integer

-        i = Fix(d)

-        s = i & Delim

-        d = Abs(d - i)

-        Do

-            precision = precision - 1

-            d = d * 10

-            If precision > 0 Then

-                i = Fix(d)

-            Else

-                i = Round(d)

-            End If

-            If i < 1 Then

-                s = s & "0"

-            Else

-                s = s & i

-                d = d - i

-            End If

-        Loop While precision > 0

-    End If

-    Double2Str = s

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetWBName(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBName = Right(FullName, s_len - pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.Name = VAR_SHEET Or sh.Name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-<<<<<<
-======================
-Var
->>>>>>
-Attribute VB_Name = "Var"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-title
->>>>>>
-Attribute VB_Name = "title"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LPU_LIST
->>>>>>
-Attribute VB_Name = "LPU_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Const LOCAL_ENT_DATE As String = "C10"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Function getCurrentLPU_ID() As Long

-    Dim r As Range

-

-    With Worksheets("LPU_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CLPU_ID)

-    End With

-

-    getCurrentLPU_ID = r

-End Function

-

-Public Sub LPU_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectLPU_NAME(lpu_id As Long, ent_date As String)

-    SelectLPU_BDGT lpu_id, ent_date

-End Sub

-

-Sub SelectLPU_BDGT(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    If lpu_id = 0 Then

-        SelectLPU_NAME lpu_id, ent_date

-    Else

-        With ThisWorkbook.Worksheets("LPU_BDGT")

-            .Range("VIEW_ONLY") = vo

-            .Range("ret_addr") = "LPU_LIST"

-            .setEnt_date (ent_date)

-            .Range("lpu_id") = lpu_id

-            .Range("REP_ID") = rep_id

-            .Range("RM_ID") = rm_id

-        End With

-    End If

-End Sub

-

-Sub SelectLPU_HIR(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_HIR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .setEnt_date (ent_date)

-        .Range("lpu_id") = lpu_id

-        .Range("REP_ID") = rep_id

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Sub SelectLPU_TER(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_TER")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .setEnt_date (ent_date)

-        .Range("lpu_id") = lpu_id

-        .Range("REP_ID") = rep_id

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Sub SelectLPU_C_ACS(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_C_ACS")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .setEnt_date (ent_date)

-        .Range("RM_ID") = rm_id

-        .Range("REP_ID") = rep_id

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateLPUList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim lpu_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CINP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CINP_AREA).row, CLPU_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    lpu_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CINP_AREA).Column

-

-    If lpu_id = 0 Then

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    End If

-

-    If lpu_id = 0 Then

-        i = CLPU_NAME

-        Range("JUMP") = ""

-    End If

-    Select Case i

-        Case CLPU_NAME, CLPU_NAME1, CLPU_NAME2, CLPU_BEDS

-            SelectLPU_NAME lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-

-        Case CLPU_NMG, CLPU_NFG, CLPU_PLAN, CLPU_FACT

-            SelectLPU_BDGT lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-

-        Case CLPU_HIR

-            SelectLPU_HIR lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_HIR"

-

-        Case CLPU_TER

-            SelectLPU_TER lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_TER"

-

-        Case CLPU_CAR

-            SelectLPU_C_ACS lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        Case Else

-            Range("JUMP") = ""

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateLPUList()

-    Dim lcd() As tLPU_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-    Dim objQTR As tQTR

-    Dim cRep As tREPID

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    ent_date = getEnt_date

-

-'     ent_date = "%" ' % - all records

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id, cRep.rm_id)

-    i = Get_LPU_CommonQTR(lcd, objQTR)

-

-'     стираем ФИО

-    Range("C3:C4").ClearContents

-

-    Range("C3") = cRep.LastName

-    Range("C4") = cRep.FirstName

-    Range("G3") = GetRegionName(cRep.Region)

-    Range("G4") = GetCityName(cRep.Region, cRep.City)

-    Range("G5") = objQTR.sale_PLAN

-

-

-

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(lcd)

-            r.Offset(i - 1, CLPU_NAME) = lcd(i).lpu.Name

-            r.Offset(i - 1, CLPU_ID) = lcd(i).lpu.id

-            r.Offset(i - 1, CLPU_BEDS) = lcd(i).lpu.beds

-

-

-            r.Offset(i - 1, CLPU_NFG) = lcd(i).bdgt.bdgt_NFG

-            r.Offset(i - 1, CLPU_NMG) = lcd(i).bdgt.bdgt_NMG

-            r.Offset(i - 1, CLPU_PLAN) = lcd(i).bdgt.sale_PLAN

-

-            r.Offset(i - 1, CLPU_HIR) = lcd(i).pat_HIR

-            r.Offset(i - 1, CLPU_TER) = lcd(i).pat_TER

-            r.Offset(i - 1, CLPU_CAR) = lcd(i).pat_CRD

-            r.Offset(i - 1, CLPU_FACT) = lcd(i).sale_ALL

-            r.Offset(i - 1, CLPU_PAT_LPU) = lcd(i).pat_LPU

-            r.Offset(i - 1, CLPU_BDGT) = lcd(i).bdgt_LPU

-            If lcd(i).bdgt_LPU > 0 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = lcd(i).sale_ALL / lcd(i).bdgt_LPU

-            End If

-            If r.Offset(i - 1, CLPU_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{32FB0F3D-6884-41DC-99DB-E2C55B2257C4}{DED79A66-DA60-4CCC-9003-082480235D55}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-dbACS
->>>>>>
-Attribute VB_Name = "dbACS"

-Option Explicit

-

-Public Type tACS

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    patients_with_geparins As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objACS.ID <> 0 then updatre else insert

-Sub Insert_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objACS.id <> 0 Then

-        dbUpdate_ACS_Record dbConnection, objACS

-    Else

-        dbInsert_ACS_Record dbConnection, objACS

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_ACS_RecordsByLPU_ID(ByRef all_ACS_() As tACS, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_ACS_RecordsByLPU_ID = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, all_ACS_, lpu_id, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_ACS_Record dbConnection, objACS

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub dbInsert_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_acs", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objACS

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("patients_with_geparins") = .patients_with_geparins

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objACS.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim Update_SQL As String

-    

-    With objACS

-        Update_SQL = "UPDATE lpu_acs SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "patients_with_geparins=" & .patients_with_geparins & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_ACS_RecordsbyLPU_ID(dbConnection As Object, all_ACS() As tACS, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_ACS_SQL As String

-    Dim getAll_ACS_SQL As String

-    Dim ACS_Count As Long

-    ACS_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    Else

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_ACS_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        ACS_Count = dbRecordset("ACS_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_ACS_RecordsbyLPU_ID = ACS_Count

-    

-    If ACS_Count > 0 Then

-        'we have records

-        ReDim all_ACS(1 To ACS_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_ACS_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_ACS As tACS

-                 With tmp_ACS

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .patients_with_geparins = dbRecordset("patients_with_geparins")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 all_ACS(index) = tmp_ACS

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE ID=" & objACS.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_ACS_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_HIR
->>>>>>
-Attribute VB_Name = "LPU_CLSN_HIR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const LOCAL_ENT_DATE As String = "S38"

-

-Sub PrintCopy()

-    Range("A1:M26").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-

-        Dim objHir As tHIRURGIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objHir

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .operations_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L9")

-                .patients_ambulator_clexan_20mg = Range("L10")

-                .patients_ambulator_clexan_40mg = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L19")

-                .patients_stationar_clexan_20mg = Range("L20")

-                .patients_stationar_clexan_40mg = Range("L21")

-            End With

-            Insert_Hir_Record objHir

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objHir.id = Range("rec_id")

-                    If objHir.id <> 0 Then

-                        Delete_Hir_Record objHir

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-End Sub

-

-Sub SetupData(objHir As tHIRURGIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    With objHir

-        Range("rec_id") = .id

-        Range("F6") = .operations_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L9") = .patients_ambulator_clexan

-        Range("L10") = .patients_ambulator_clexan_20mg

-        Range("I21") = .patients_stationar_nmg

-        Range("L19") = .patients_stationar_clexan

-        Range("L20") = .patients_stationar_clexan_20mg

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id, cRep.rm_id)

-

-        formula = "=" & qtr.ClxnH20mg & "*($L$10+$L$20)+" & qtr.ClxnH40mg & "*($L$11+$L$21)"

-        Range("F11").formula = formula

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id, Range("RM_ID"))

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.Name

-        Range("lpu_addr") = lpu.address

-

-        Dim objHir() As tHIRURGIA

-        Dim i As Integer

-        i = GetAll_Hir_RecordsByLPU_ID(objHir, id, Range("ent_date"), Range("RM_ID"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.3

-        Else

-            SetupData objHir(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-mSapes
->>>>>>
-Attribute VB_Name = "mSapes"

-Option Explicit

-

-Const SHAPE_COLOR As Integer = 1

-Const SHAPE_NAME As Integer = 2

-

-

-Sub ShapeView(r_sh_finite_state As Range)

-    Dim chk As Range

-    Dim s As String

-    Dim c, idx As Integer

-    For Each chk In r_sh_finite_state

-        idx = 0

-        If chk = "+" Then

-            c = chk.Offset(0, idx + SHAPE_COLOR)

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While c <> 0

-                ShapeFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s)), c

-                idx = idx + 2

-                c = chk.Offset(0, idx + SHAPE_COLOR)

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        Else

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While s <> ""

-                ShapeUnFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s))

-                idx = idx + 2

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        End If

-    Next chk

-End Sub

-

-Sub ShapeFill(sh As ShapeRange, ByVal color As Integer)

-    sh.Fill.Visible = msoTrue

-    sh.Fill.Solid

-    sh.Fill.ForeColor.SchemeColor = color

-    sh.Fill.Transparency = 0#

-End Sub

-

-Sub ShapeUnFill(sh As ShapeRange)

-    sh.Fill.Visible = msoFalse

-    sh.Fill.Transparency = 0#

-End Sub

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Public Const INPUT_NO = 0

-Public Const INPUT_NUMBER = 1

-Public Const INPUT_PERCENT = 2

-Public Const INPUT_STRING = 3

-Public Const INPUT_CHECK = 4

-

-Public Const INP_IDX_TYPE = 1

-Public Const INP_IDX_NEXT = 2

-Public Const INP_IDX_MIN = 3

-Public Const INP_IDX_MAX = 4

-Public Const INP_IDX_DEP = 5

-Public Const INP_IDX_ALT = 7

-

-

-Public Type tInputSet

-    vType As Integer

-    vMin As Long

-    vMax As Long

-    rChk As String

-End Type

-

-Function is_input_cell(ByVal Target As Range, inputs As Range) As tInputSet

-    Dim t As Range

-    Dim iset As tInputSet

-    Dim test As Range

-    iset.vType = INPUT_NO

-    iset.vMin = 0

-    iset.vMax = 0

-    iset.rChk = ""

-    is_input_cell = iset

-

-' Закоментировать следующую сточку для работы

-'  Exit Function

-

-    Set test = Target.Cells(1, 1)

-    For Each t In inputs

-        If Range(t).Column = test.Column And Range(t).row = test.row Then

-            iset.vType = t.Offset(0, INP_IDX_TYPE).Value

-            Select Case iset.vType

-                Case INPUT_CHECK

-                    iset.rChk = t.Offset(0, INP_IDX_ALT)

-                Case INPUT_NUMBER, INPUT_PERCENT

-                    iset.vMin = t.Offset(0, INP_IDX_MIN).Value

-                    iset.vMax = t.Offset(0, INP_IDX_MAX).Value

-            End Select

-            is_input_cell = iset

-            Exit Function

-        End If

-    Next t

-End Function

-

-Function GetFocusAddress(ByVal r As Range, f_next As Range) As String

-    Dim chk, t As Range

-    

-    For Each chk In f_next

-        For Each t In r

-            If t.address = chk Then

-                GetFocusAddress = chk

-                Exit Function

-            End If

-            If Range(chk).Column = t.Column - 1 And Range(chk).row = t.row _

-            Or Range(chk).Column = t.Column And Range(chk).row = t.row - 1 _

-            Then

-                If Range(chk) <> "" Then

-                    If Range(chk) = 0 Then

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_ALT)).address

-                    Else

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_NEXT)).address

-                    End If

-                Else

-                    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-                End If

-                Exit Function

-            End If

-        Next t

-    Next chk

-    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-End Function

-

-Sub SetDependet(r As Range, inputs As Range)

-    Dim chk As Range

-    Dim s, serr As String

-    Dim idx As Integer

-    Dim iset As tInputSet

-    Dim err_found As Boolean

-    

-    If r.count > 1 Then

-        Exit Sub

-    End If

-    

-    err_found = False

-    For Each chk In inputs

-        idx = INP_IDX_DEP

-        

-        

-        iset.vType = chk.Offset(0, INP_IDX_TYPE).Value

-        Select Case iset.vType

-            Case INPUT_NUMBER, INPUT_PERCENT

-                iset.vMin = chk.Offset(0, INP_IDX_MIN).Value

-                iset.vMax = chk.Offset(0, INP_IDX_MAX).Value

-                

-                If Range(chk) > iset.vMax Then

-                    err_found = True

-                    Range(chk) = iset.vMax

-                    serr = "Выход за дозволенный диапазон [" & iset.vMin & ".." & iset.vMax & "]! Данные скорректированы."

-                End If

-                

-                If Range(chk) = "" Then

-                    s = chk.Offset(0, idx)

-                    Do While s <> ""

-                        Range(s) = ""

-                        idx = idx + 1

-                        s = chk.Offset(0, idx)

-                    Loop

-                End If

-        End Select

-    Next chk

-    If err_found Then

-        MsgBox serr, vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Function CheckInputData(inputs As Range) As Boolean

-    Dim r As Range

-    

-    CheckInputData = True

-    For Each r In inputs

-        If Range(r) = "" Then

-            CheckInputData = False

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100.", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Sub Check_Int_Number(Target As Range, Def_Val As Long)

-    Dim err As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    err = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                err = True

-            End If

-        End If

-    Next r

-    If err Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_TER
->>>>>>
-Attribute VB_Name = "LPU_CLSN_TER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const LOCAL_ENT_DATE As String = "S38"

-

-Sub PrintCopy()

-    Range("A1:M26").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim objTer As tTERAPIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objTer

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .patients_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L20")

-            End With

-            Insert_Ter_Record objTer

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objTer.id = Range("rec_id")

-                    If objTer.id <> 0 Then

-                        Delete_Ter_Record objTer

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-

-End Sub

-

-Sub SetupData(objTer As tTERAPIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    With objTer

-        Range("rec_id") = .id

-        Range("F6") = .patients_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L11") = .patients_ambulator_clexan

-        Range("I21") = .patients_stationar_nmg

-        Range("L20") = .patients_stationar_clexan

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id, cRep.rm_id)

-        formula = "=" & qtr.ClxnT40mg & "*($L$12+$L$20)"

-        Range("F11").formula = formula

-

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id, Range("RM_ID"))

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.Name

-        Range("lpu_addr") = lpu.address

-

-        Dim objTer() As tTERAPIA

-        Dim i As Integer

-        i = GetAll_Ter_RecordsByLPU_ID(objTer, id, Range("ent_date"), Range("RM_ID"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.25

-        Else

-            SetupData objTer(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{0DC9E035-CE0A-49FF-85A2-A4EC5FF8FE96}{D54DDC8A-1EE2-4BB3-8B94-343B521AF098}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-LPU_BDGT
->>>>>>
-Attribute VB_Name = "LPU_BDGT"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const LOCAL_ENT_DATE As String = "S15"

-

-Sub PrintCopy()

-    Range("B1:K21").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Sub SetDefFocus()

-    Range(Range("DEF_FOCUS")).Select

-End Sub

-

-Public Sub ClearData()

-    ClearSheetData

-End Sub

-

-Sub ClearSheetData()

-    If Range("F10") = 0 And Range("F13") = 0 Then

-        Range("F11:F18") = ""

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("F11:F13") = ""

-    End If

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim bdgt As tBUDGET

-        Dim sum As Long

-        Dim test As Boolean

-        With bdgt

-            .lpu_id = Range("lpu_id")

-            .id = Range("rec_id")

-            .entry_date = Range("ent_date")

-            .bdgt_NMG = Round(Range("F11").Value, 0)

-            .bdgt_NFG = Round(Range("F12").Value, 0)

-            .sale_PLAN = Round(Range("F13").Value, 0)

-

-            sum = .bdgt_NFG + .bdgt_NMG - .sale_PLAN

-            test = .bdgt_NFG <> 0 Or .bdgt_NMG <> 0 Or .sale_PLAN <> 0

-        End With

-        If test Then

-            If sum < 0 Then

-                MsgBox _

-                    "Ваш план превышает выделенный на гепарины бюджет. Сохранить данные?", _

-                    vbOKOnly, PROGRAM_NAME

-            End If

-            If test Then

-                Insert_BDGT_Record bdgt

-            End If

-        Else

-            If bdgt.id <> 0 Then

-                If vbYes = MsgBox("Удалить данные из базы!", vbYesNo, PROGRAM_NAME) Then

-                    Delete_BDGT_Record bdgt

-                End If

-                ret_back Range("DEF_FOCUS").Worksheet

-                Exit Sub

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-    End If

-

-   ClearData

-   ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(cLPU As tLPU_COMMON)

-    Dim t_sum As Long

-    t_sum = 0

-' Setup budget data

-    Range("F11") = cLPU.bdgt.bdgt_NMG

-    Range("F12") = cLPU.bdgt.bdgt_NFG

-    Range("F13") = cLPU.bdgt.sale_PLAN

-

-    With cLPU

-        Range("F14") = .pat_ALL

-        Range("F15") = .pat_HIR

-        Range("F16") = .pat_TER

-        Range("F17") = .pat_CRD

-        Range("F18") = .sale_ALL

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    ws_activate

-End Sub

-

-

-Sub ws_activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Dim cLPU As tLPU_COMMON

-    Dim objQTR As tQTR

-    Dim objLPU As tLPU

-    Dim ent_date As String

-    Dim id As Long

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"), Range("RM_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    id = Range("lpu_id").Value

-    ent_date = Range("ent_date")

-    

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id, cRep.rm_id)

-

-    objLPU = Get_LPU_Record(id, Range("RM_ID"))

-    Get_LPU_Common cLPU, objLPU, objQTR

-

-    If cLPU.lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = cLPU.lpu.beds

-        Range("lpu_name") = cLPU.lpu.Name

-        Range("lpu_addr") = cLPU.lpu.address

-        Range("rec_id") = cLPU.bdgt.id

-

-        SetupData cLPU

-

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-'    MsgBox Target.address

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case INPUT_CHECK

-

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{BFB4547C-96A7-4739-AA0A-CEF1E35E2BDC}{C3D618A3-9410-4BC7-9D93-3B049D361132}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mSheets
->>>>>>
-Attribute VB_Name = "mSheets"

-Option Explicit

-

-Function am_load_now() As Boolean

-    am_load_now = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE")

-End Function

-

-Sub Wks_select(RetSheet As String)

-    Dim sheet As Worksheet

-    For Each sheet In ThisWorkbook.Worksheets

-        If sheet.Name = RetSheet Then

-            ThisWorkbook.Worksheets(RetSheet).Select

-            Exit Sub

-        End If

-    Next sheet

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub ret_back(sh As Worksheet)

-    Dim RetSheet As String

-    RetSheet = sh.Range("ret_addr")

-    sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    sh.Range("rec_id") = ""

-    sh.Range("lpu_id") = ""

-    sh.Range("ent_date") = ""

-    sh.Range("lpu_name") = ""

-    sh.Range("lpu_addr") = ""

-    sh.Range("lpu_beds") = ""

-    Wks_select RetSheet

-    sh.Range("ret_addr") = ""

-End Sub

-

-Sub ClearSheetData(r_start As Range)

-    If r_start <> "" Then

-        r_start.Worksheet.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        r_start = ""

-    Else

-        ret_back r_start.Worksheet

-    End If

-End Sub

-

-Sub wks_sel_chng(iset As tInputSet, ByVal Target As Range, sh As Worksheet)

-    Dim DebugMode As Boolean

-    Dim in_range As Range

-    

-    DebugMode = Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-

-    If DebugMode Then

-        sh.Unprotect

-    Else

-        sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    End If

-

-    If iset.vType = INPUT_CHECK Then

-        Set in_range = Target.Worksheet.Range(iset.rChk)

-    Else

-        Set in_range = Target

-    End If

-    

-    Dim str As String

-    str = GetFocusAddress(in_range, sh.Range("h_inputs"))

-

-'    MsgBox Target.Address & "; " & str

-    If str <> Target.address Then

-        sh.Range(str).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-Dlg_lpu_card
->>>>>>
-Attribute VB_Name = "Dlg_lpu_card"

-Attribute VB_Base = "0{9AAD262F-A6C4-4912-9C58-D7A2071181B8}{9470F4EB-DA9F-4584-9159-D09319548D21}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbLPU_List_Change()

-    Dim src As Range

-    Dim idx_src As Integer

-    

-    Set src = Worksheets(VAR_SHEET).Range(Me.cbLPU_List.RowSource)

-    idx_src = Me.cbLPU_List.ListIndex + 1

-    Me.tb_lpu_name.Text = src.Cells(idx_src, 1)

-    Me.tb_lpu_address.Text = src.Cells(idx_src, 2)

-    Me.tbBedsCount.Text = src.Cells(idx_src, 3)

-End Sub

-

-

-Private Sub cbxLPU_List_Enable_Click()

-    

-    If Me.cbxLPU_List_Enable Then

-        

-        Me.tb_lpu_name.Text = ""

-        Me.tb_lpu_name.Enabled = False

-        

-        Me.tb_lpu_address.Text = ""

-        Me.tb_lpu_address.Enabled = False

-        

-        Me.tbBedsCount.Text = ""

-        Me.tbBedsCount.Enabled = False

-        

-        Me.cbLPU_List.Enabled = True

-        cbLPU_List_Change

-    Else

-        Me.tb_lpu_name.Enabled = True

-        Me.tb_lpu_name.Text = ""

-        

-        Me.tb_lpu_address.Enabled = True

-        Me.tb_lpu_address.Text = ""

-        

-        Me.tbBedsCount.Enabled = True

-        Me.tbBedsCount.Text = ""

-        

-        Me.cbLPU_List.Enabled = False

-    End If

-End Sub

-

-<<<<<<
-======================
-UserInfo
->>>>>>
-Attribute VB_Name = "UserInfo"

-Attribute VB_Base = "0{A8FBEE9C-DE59-49DE-971D-07BC9C0E9BD2}{C712732B-D8E4-4C2D-8E78-AC90968E0CD7}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Tag = vbOK

-End Sub

-

-Private Sub cbCity_Change()

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_CITY") = Me.cbCity.ListIndex

-        .Calculate

-    End With

-End Sub

-

-Private Sub cbRegion_Change()

-    Dim LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        NewRangeOffsetCol = cbRegion.Value * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .Name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).address

-        NewSumRange = .Name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).address

-        .Calculate

-        .Range("IDX_CITY") = 0

-        cbCity.RowSource = NewCbxRange

-

-    End With

-    cbCity.ListIndex = 0

-End Sub

-

-<<<<<<
-======================
-mREGMAN
->>>>>>
-Attribute VB_Name = "mREGMAN"

-Option Explicit

-

-Sub hw_reset()

-    Dim rs As Range

-    Dim re As Object

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    HWReset

-    With Application

-        .DisplayAlerts = False

-        .Quit

-    End With

-End Sub

-

-Sub CheckUser()

-    If Range("HW_Number") = "" Then

-        StoreHWInfo

-    End If

-    If CheckHWInfo <> True Then

-        MsgBox "2"

-        cmAbout

-'        With Application

-'            .DisplayAlerts = False

-'            .Quit

-'        End With

-    Else

-        SetupUser

-    End If

-End Sub

-

-

-Sub SetupUser()

-'    Dim cREGMAN As tREGMAN

-'    Dim idx As Integer

-'    Dim dlg_ui As UserInfo

-'

-'    Set dlg_ui = New UserInfo

-'

-'    cREGMAN = Get_REGMAN_Record()

-'

-'    With ThisWorkbook.Worksheets(REGS_SHEET)

-'        .Range("IDX_REGION") = cREGMAN.Region

-'        .Range("IDX_CITY") = cREGMAN.City

-'    End With

-'

-'    With dlg_ui

-'        .cbRegion = cREGMAN.Region

-'        .cbCity = cREGMAN.City

-'        .tbFName = cREGMAN.FirstName

-'        .tbLName = cREGMAN.LastName

-'    End With

-'

-'    dlg_ui.Show

-'    Worksheets(REGS_SHEET).Calculate

-'

-'    If dlg_ui.Tag = vbOK Then

-'        With cREGMAN

-'            .Region = dlg_ui.cbRegion.Value

-'            .City = dlg_ui.cbCity.Value

-'            .FirstName = dlg_ui.tbFName.Value

-'            .LastName = dlg_ui.tbLName.Value

-'        End With

-'        Set_REGMAN_Record cREGMAN

-'    Else

-'        cmAbout

-'        With Application

-'            .DisplayAlerts = False

-'            .Quit

-'        End With

-'    End If

-End Sub

-

-Sub StoreHWInfo()

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim objHW() As Long

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    Set r = Range("HW_Number")

-    i = 1

-    For Each d In dc

-        If d.drivetype = 2 Then

-            r = d.SerialNumber

-            Set r = r.Offset(1, 0)

-            ReDim Preserve objHW(i)

-            objHW(i) = d.SerialNumber

-            i = i + 1

-        End If

-    Next

-    

-    UpdateHWRecords objHW

-End Sub

-

-Function CheckHWInfo()

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim objHW() As Long

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    

-    CheckHWInfo = False

-    

-    i = GetHWRecords(objHW)

-    If i = 0 And Range("HW_Number") <> 0 Then

-        Exit Function

-    End If

-    For Each d In dc

-        If d.drivetype = 2 Then

-            Set r = Range("HW_Number")

-            Do While r <> ""

-                If r = d.SerialNumber Then

-                    For i = 1 To UBound(objHW)

-                        If d.SerialNumber = objHW(i) Then

-                            CheckHWInfo = True

-                            Exit Function

-                        End If

-                    Next i

-                End If

-                Set r = r.Offset(1, 0)

-            Loop

-        End If

-    Next

-End Function

-<<<<<<
-======================
-dbBudget
->>>>>>
-Attribute VB_Name = "dbBudget"

-Option Explicit

-

-Public Type tBUDGET

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    rm_id As Long

-    bdgt_NMG As Long

-    bdgt_NFG As Long

-    sale_PLAN As Long

-End Type

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function GetAll_BDGT_RecordsByLPU_ID(ByRef allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_BDGT_RecordsByLPU_ID = dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection, allBDGT, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function Get_BDGT_Record(ByVal lpu_id As Long, ByVal ent_date As String, rm_id As Long) As tBUDGET

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    Get_BDGT_Record = dbGet_BDGT_Record(dbConnection, lpu_id, ent_date, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-' if objBDGT.ID <> 0 then updatre else insert

-Public Sub Insert_BDGT_Record(objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    If objBDGT.id <> 0 Then

-        dbUpdate_BDGT_Record dbConnection, objBDGT

-    Else

-        dbInsert_BDGT_Record dbConnection, objBDGT

-    End If

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Public Sub Delete_BDGT_Record(ByRef objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    dbDelete_BDGT_Record dbConnection, objBDGT

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_BDGT_Record(dbConnection As Object, ByVal lpu_id As Long, ent_date As String, rm_id As Long) As tBUDGET

-    

-    Dim sql As String

-    Dim objBDGT As tBUDGET

-    

-    With objBDGT

-        .id = 0

-        .lpu_id = lpu_id

-        .rm_id = rm_id

-        .entry_date = ent_date

-        .bdgt_NMG = 0

-        .bdgt_NFG = 0

-        .sale_PLAN = 0

-    End With

-        

-    

-    sql = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        With objBDGT

-            .entry_date = dbRecordset("entry_date")

-            .id = dbRecordset("id")

-            .lpu_id = dbRecordset("lpu_id")

-            .bdgt_NFG = dbRecordset("bdgt_NFG")

-            .bdgt_NMG = dbRecordset("bdgt_NMG")

-            .sale_PLAN = dbRecordset("sale_PLAN")

-        End With

-    End If

-    

-    dbGet_BDGT_Record = objBDGT

-End Function

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection As Object, allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_BDGT_SQL As String

-    Dim getAll_BDGT_SQL As String

-    Dim BDGT_Count As Long

-    BDGT_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_BDGT_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        BDGT_Count = dbRecordset("BDGT_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_BDGT_RecordsbyLPU_ID = BDGT_Count

-    

-    If BDGT_Count > 0 Then

-        'we have records

-        ReDim allBDGT(1 To BDGT_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_BDGT_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpBDGT As tBUDGET

-                 With tmpBDGT

-                    .entry_date = dbRecordset("entry_date")

-                    .id = dbRecordset("id")

-                    .lpu_id = dbRecordset("lpu_id")

-                    .bdgt_NFG = dbRecordset("bdgt_NFG")

-                    .bdgt_NMG = dbRecordset("bdgt_NMG")

-                    .sale_PLAN = dbRecordset("sale_PLAN")

-                 End With

-                 

-                 allBDGT(index) = tmpBDGT

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbInsert_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "lpu_budget", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    dbRecordset("entry_date") = objBDGT.entry_date

-    dbRecordset("lpu_id") = objBDGT.lpu_id

-    dbRecordset("bdgt_NMG") = objBDGT.bdgt_NMG

-    dbRecordset("bdgt_NFG") = objBDGT.bdgt_NFG

-    dbRecordset("sale_PLAN") = objBDGT.sale_PLAN

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objBDGT.id = dbRecordset("id")

-  

-End Sub

-

-Public Sub dbUpdate_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu_budget SET " & _

-    "entry_date='" & objBDGT.entry_date & "'," & _

-    "lpu_id=" & objBDGT.lpu_id & "," & _

-    "bdgt_NMG=" & objBDGT.bdgt_NMG & "," & _

-    "bdgt_NFG=" & objBDGT.bdgt_NFG & "," & _

-    "sale_PLAN=" & objBDGT.sale_PLAN & _

-    " WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-Public Sub dbDelete_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_BDGT_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbDatabase
->>>>>>
-Attribute VB_Name = "dbDatabase"

-Option Explicit

-

-

-Sub dbOpenConnection(dbConnection As Object)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-<<<<<<
-======================
-dbLPU
->>>>>>
-Attribute VB_Name = "dbLPU"

-Option Explicit

-

-Public Type tLPU

-    id As Long

-    rep_id As Long

-    rm_id As Long

-    Name As String

-    address As String

-    beds As Integer

-End Type

-

-Function Get_LPU_Record(ByVal lpu_id As Long, rm_id As Long) As tLPU

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_LPU_Record = dbGet_LPU_Record(dbConnection, lpu_id, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_LPU_byQTR(allLPU() As tLPU, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_LPU_byQTR = dbGetAll_LPU_byQTR(dbConnection, allLPU, ent_date, rep_id, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_Record(dbConnection As Object, ByVal lpu_id As Long, rm_id As Long) As tLPU

-    

-    Dim sql As String

-    Dim objLPU As tLPU

-    

-    objLPU.id = lpu_id

-    objLPU.Name = ""

-    objLPU.address = ""

-    

-    sql = "SELECT * FROM lpu WHERE id=" & lpu_id & " AND rm_id=" & rm_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objLPU.Name = dbRecordset("name")

-        objLPU.address = dbRecordset("address")

-        objLPU.rep_id = dbRecordset("rep_id")

-        objLPU.rm_id = dbRecordset("rm_id")

-        objLPU.beds = dbRecordset("beds")

-    End If

-    

-    dbGet_LPU_Record = objLPU

-

-End Function

-

-Function dbGetAll_LPU_byQTR(dbConnection As Object, allLPU() As tLPU, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    Dim Where As String

-    Where = "WHERE lpu_budget.entry_date like '" & ent_date & "'" & " AND lpu.id=lpu_budget.lpu_id " & _

-    "AND lpu.rep_id=" & rep_id & " AND lpu.rm_id=lpu_budget.rm_id AND lpu.rm_id=" & rm_id

-

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu_budget, lpu " & Where

-    

-    getAll_LPU_SQL = "SELECT lpu.id as id, lpu.rep_id as rep_id, lpu.name as name, lpu.address as address, lpu.beds AS beds, lpu.rm_id AS rm_id " & _

-    "FROM lpu, lpu_budget " & Where

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_LPU_byQTR = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .Name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-dbREP
->>>>>>
-Attribute VB_Name = "dbREP"

-'Option Explicit

-'

-'Public Type tREP

-'    FirstName As String

-'    LastName As String

-'    Region As Integer

-'    City As Integer

-'End Type

-'

-'Function GetREPRecord() As tREP

-'    Dim dbConnection As Object

-'

-'    dbOpenConnection dbConnection

-'    GetREPRecord = dbGetREPRecord(dbConnection)

-'    dbCloseConnection dbConnection

-'End Function

-'

-'Sub SetREPRecord(cUser As tREP)

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbSetREPRecord dbConnection, cUser

-'    dbCloseConnection dbConnection

-'End Sub

-'

-'Public Function dbGetREPRecord(dbConnection As Object) As tREP

-'

-'    Dim SQL As String

-'    Dim objREP As tREP

-'

-'    objREP.FirstName = ""

-'    objREP.LastName = ""

-'    objREP.Region = 0

-'    objREP.City = 0

-'    SQL = "SELECT firstname, lastname, region, city FROM " & _

-'          "rep"

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open SQL, dbConnection

-'    ', 3, 3

-'    If Not dbRecordset.BOF Then

-'

-'        objREP.FirstName = dbRecordset("firstname")

-'        objREP.LastName = dbRecordset("lastname")

-'        objREP.Region = dbRecordset("region")

-'        objREP.City = dbRecordset("city")

-'

-'    End If

-'

-'    dbGetREPRecord = objREP

-'

-'End Function

-'

-'Public Sub dbSetREPRecord(dbConnection As Object, ByRef objREP As tREP)

-'

-'    Dim DeleteSQL As String

-'    Dim InsertSQL As String

-'

-'    DeleteSQL = "DELETE FROM rep"

-'    InsertSQL = "INSERT INTO rep (firstname, lastname, region, city) VALUES (" & _

-'    "'" & objREP.FirstName & "', " & _

-'    "'" & objREP.LastName & "', " & _

-'    objREP.Region & ", " & _

-'    objREP.City & ")"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-'

-'End Sub

-'

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    CheckWorkBooksArround Wb

-End Sub

-

-

-Sub CheckWorkBooksArround(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If app.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEL сейчас будут закрыты!", vbOKOnly, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub GetState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-        ActiveWorkbook.DisplayDrawingObjects = xlDisplayShapes

-        

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.Name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars(STDBAR_NAME).Visible = False

-End Sub

-

-

-Public Sub RestoreState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars(STDBAR_NAME).Visible = True

-End Sub

-

-

-

-<<<<<<
-======================
-cdbRM
->>>>>>
-Attribute VB_Name = "cdbRM"

-Option Explicit

-

-Public Type tRMID_COMMON

-    rm As tREGMAN

-    rgcd_count As Integer

-    rgcd() As tREGION

-End Type

-

-Function Get_RM_CommonList_by_QTR(ByRef rmcd() As tRMID_COMMON, ent_date As String) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_RM_CommonList_by_QTR = dbGet_RM_CommonList_by_QTR(dbConnection, rmcd(), ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_RM_CommonList_by_QTR(dbConnection As Object, ByRef rmcd() As tRMID_COMMON, ent_date As String) As Integer

-    ' Получить список RM-ов

-    Dim count As Integer

-    count = db_get_All_RM_by_QTR(dbConnection, rmcd(), ent_date)

-    

-    Dim i As Integer

-    For i = 1 To count

-        rmcd(i).rgcd_count = 1

-        ReDim rmcd(i).rgcd(1 To 1)

-        getREGION_by_QTR ent_date, rmcd(i).rgcd(1), rmcd(i).rm.rm_id

-    Next i

-    dbGet_RM_CommonList_by_QTR = count

-End Function

-

-Function db_get_All_RM_by_QTR(dbConnection As Object, rmcd() As tRMID_COMMON, ent_date As String) As Integer

-    

-    Dim count_sql As String

-    Dim get_sql As String

-    Dim rs As Object

-    Dim RM_Count As Integer

-        

-    count_sql = "SELECT COUNT(*) AS RM_TOTAL FROM reg_man"

-    get_sql = "SELECT * FROM reg_man"

-    Set rs = CreateObject("ADODB.Recordset")

-    rs.Open count_sql, dbConnection

-    

-    If Not rs.BOF Then

-        RM_Count = rs("RM_TOTAL")

-    End If

-    

-    rs.Close

-    

-     db_get_All_RM_by_QTR = RM_Count

-    

-    If RM_Count > 0 Then

-        'we have records

-        ReDim rmcd(1 To RM_Count)

-        Dim index As Long

-        index = 1

-        rs.Open get_sql, dbConnection

-        

-        If Not rs.BOF Then

-             Do While Not rs.EOF

-                 Dim tmp_rmcd As tRMID_COMMON

-                 With tmp_rmcd

-                    .rgcd_count = 0

-                    .rm.City = rs("city")

-                    .rm.FirstName = rs("firstname")

-                    .rm.LastName = rs("lastname")

-                    .rm.rm_id = rs("mgr_id")

-                    .rm.Region = rs("region")

-                 End With

-                 

-                 rmcd(index) = tmp_rmcd

-                 index = index + 1

-                 rs.MoveNext

-             Loop

-        End If

-    End If

-    

-End Function

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Public Const STDBAR_NAME = "Worksheet Menu Bar"

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Import data"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmDataImport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-             With .Add(msoControlPopup)

-                .Caption = "&Report"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&New Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 18

-                        .OnAction = "cmNewReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Open Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmOpenReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Close && Save"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseReport"

-                    End With

-                End With

-            End With

-           With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Exit && Restore Excel"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 548

-                        .OnAction = "cmExitRestore"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-        End With

-    End With

-End Sub

-

-Sub CreateExtCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom extendet commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Import data"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmDataImport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-             With .Add(msoControlPopup)

-                .Caption = "&Report"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&New Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 18

-                        .OnAction = "cmNewReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Open Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmOpenReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Close && Save"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseReport"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Add New Slide"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 280

-                .OnAction = "cmAddSlide"

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(flag As Boolean)

-    If flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars(STDBAR_NAME)

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmExport()

-    dbExport

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    Dim dlg As dlgAbout

-    Set dlg = New dlgAbout

-    

-    dlg.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlg.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlg.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlg.Show

-End Sub

-

-Sub cmMail2Support()

-    Dim err_description As String

-    Dim dlg_msg As dlg_Mail

-    Set dlg_msg = New dlg_Mail

-    With dlg_msg

-        .Show

-        If .Tag = vbOK Then

-            ThisWorkbook.Worksheets(VAR_SHEET).Range("ERR_MESSAGE") _

-                = .tbMessage.Text

-            ThisWorkbook.Save

-            ThisWorkbook.SendMail Recipients:="infra@i-rs.ru", Subject:=PROGRAM_NAME & " ver.:" & PROGRAM_VERSION

-            MsgBox "Сообщение об ошибке отправлено. Перезагрузите программу.", vbOKOnly, PROGRAM_NAME

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-    End With

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-'        helppath = "hh.exe " & .Path & "\Telfast.chm"

-'        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub set_work_mode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-End Sub

-

-Sub cmSetStandaloneMode()

-    set_work_mode

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    Dim dlg As dlgGetPwd

-    rp = common_pwd

-    

-    Set dlg = New dlgGetPwd

-    dlg.edPwd = ""

-    dlg.Show

-    

-    If dlg.edPwd = rp Then

-        Application.ScreenUpdating = False

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-        xlRestoreView

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-        Application.ScreenUpdating = True

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmNewReport()

-    ppReport.CreateReport

-    MsgBox "Новый отчет создан", vbInformation + vbOKOnly, PROGRAM_NAME

-    CreateExtCommandBar theApp:=ThisWorkbook.Application

-End Sub

-

-Sub cmOpenReport()

-    Dim fileToOpen

-    Dim s As String

-    fileToOpen = Application _

-        .GetOpenFileName("Report Files (*.ppt), *.ppt", title:="Report OPen", MultiSelect:=False)

-    If fileToOpen <> False Then

-        s = fileToOpen

-        ppReport.OpenReport s

-        CreateExtCommandBar theApp:=ThisWorkbook.Application

-    End If

-End Sub

-

-Sub cmCloseReport()

-    On Error Resume Next

-    ppReport.SaveReport

-    CreateCommandBar theApp:=ThisWorkbook.Application

-End Sub

-

-Sub cmAddSlide()

-    ThisWorkbook.ActiveSheet.PrintCopy

-    ppReport.InsertSlide

-End Sub

-

-Sub cmHomePage()

-    ThisWorkbook.Worksheets("PRJ_QTR").Select

-End Sub

-

-Sub cmExitRestore()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = True

-    Application.Quit

-End Sub

-

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    Dim dlg_prn As dlgPrint

-    

-    Set dlg_prn = New dlgPrint

-    

-    With dlg_prn

-        .cbMainReport = True

-        .cbMainBudget = False

-        .cbSrcData = False

-        .cbAllSheets = False

-    

-        .Show

-    

-        If .Tag = vbCancel Then

-            Exit Sub

-        End If

-    End With

-    

-    Dim PrnIdx As Integer

-    

-    With dlg_prn

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("REP_QTR", "budget", "Final")

-    Case 1111

-        plist = Array("REP_QTR", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("REP_QTR")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Clexane bar"

-Public Const common_pwd As String = "crdjhxtyjr"

-

-

-Sub SetEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    With Application

-        .Caption = PROGRAM_NAME

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .GetState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = False

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Unprotect

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    If cWindow.Type = xlWorkbook Then

-                        cWindow.DisplayHeadings = True

-                    End If

-                Next

-            End If

-        Next

-        If DesignMode Then

-            SetupDesignMenu True

-        End If

-        With mobjAppState

-            .RestoreState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Option Explicit

-

-Sub UpdateHWRecords(objHW() As Long)

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    dbUpdateHWRecords dbConnection, objHW

-    dbCloseConnection dbConnection

-End Sub

-

-Function GetHWRecords(objHW() As Long) As Integer

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    GetHWRecords = dbGetHWRecords(dbConnection, objHW)

-    dbCloseConnection dbConnection

-End Function

-

-Sub HWReset()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbInsertHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    

-    Dim dbRecordset As Object

-    Dim i As Long

-    

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "hw", dbConnection, 2, 2

-    

-    For i = 1 To UBound(objHW)

-        dbRecordset.addnew

-        dbRecordset("num") = objHW(i)

-        dbRecordset.Update

-    Next i

-    

-End Sub

-

-Sub dbUpdateHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    dbDeleteHWRecord dbConnection

-    dbInsertHWRecords dbConnection, objHW

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-dbHir
->>>>>>
-Attribute VB_Name = "dbHir"

-Option Explicit

-

-Public Type tHIRURGIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    operations_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_ambulator_clexan_40mg As Integer

-    patients_ambulator_clexan_20mg As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-    patients_stationar_clexan_40mg As Integer

-    patients_stationar_clexan_20mg As Integer

-End Type

-

-' if objHir.ID <> 0 then updatre else insert

-Sub Insert_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objHir.id <> 0 Then

-        dbUpdate_Hir_Record dbConnection, objHir

-    Else

-        dbInsert_Hir_Record dbConnection, objHir

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Hir_RecordsByLPU_ID(ByRef allHir() As tHIRURGIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Hir_RecordsByLPU_ID = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, allHir, lpu_id, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Hir_Record dbConnection, objHir

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objHir.ID <> 0 then updatre else insert

-

-Sub dbInsert_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_hir", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objHir

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("operations_per_quarter") = .operations_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_ambulator_clexan_20mg") = .patients_ambulator_clexan_20mg

-        dbRecordset("patients_ambulator_clexan_40mg") = .patients_ambulator_clexan_40mg

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-        dbRecordset("patients_stationar_clexan_20mg") = .patients_stationar_clexan_20mg

-        dbRecordset("patients_stationar_clexan_40mg") = .patients_stationar_clexan_40mg

-        

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objHir.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim UpdateSQL As String

-    

-    With objHir

-        UpdateSQL = "UPDATE lpu_hir SET " & _

-            "entry_date='" & objHir.entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "operations_per_quarter=" & .operations_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_ambulator_clexan_20mg=" & .patients_ambulator_clexan_20mg & "," & _

-            "patients_ambulator_clexan_40mg=" & .patients_ambulator_clexan_40mg & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & "," & _

-            "patients_stationar_clexan_20mg=" & .patients_stationar_clexan_20mg & "," & _

-            "patients_stationar_clexan_40mg=" & .patients_stationar_clexan_40mg & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_Hir_RecordsbyLPU_ID(dbConnection As Object, allHir() As tHIRURGIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_Hir_SQL As String

-    Dim getAll_Hir_SQL As String

-    Dim Hir_Count As Long

-    Hir_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    Else

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Hir_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Hir_Count = dbRecordset("HIR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Hir_RecordsbyLPU_ID = Hir_Count

-    

-    If Hir_Count > 0 Then

-        'we have records

-        ReDim allHir(1 To Hir_Count)

-        Dim index As Integer

-        index = 1

-        dbRecordset.Open getAll_Hir_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpHir As tHIRURGIA

-                 With tmpHir

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .operations_per_quarter = dbRecordset("operations_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_ambulator_clexan_20mg = dbRecordset("patients_ambulator_clexan_20mg")

-                    .patients_ambulator_clexan_40mg = dbRecordset("patients_ambulator_clexan_40mg")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                    .patients_stationar_clexan_20mg = dbRecordset("patients_stationar_clexan_20mg")

-                    .patients_stationar_clexan_40mg = dbRecordset("patients_stationar_clexan_40mg")

-                 End With

-                 

-                 allHir(index) = tmpHir

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE ID=" & objHir.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Hir_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbTer
->>>>>>
-Attribute VB_Name = "dbTer"

-Option Explicit

-

-Public Type tTERAPIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objTer.ID <> 0 then updatre else insert

-Sub Insert_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objTer.id <> 0 Then

-        dbUpdate_Ter_Record dbConnection, objTer

-    Else

-        dbInsert_Ter_Record dbConnection, objTer

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Ter_RecordsByLPU_ID(ByRef allTer() As tTERAPIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Ter_RecordsByLPU_ID = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, allTer, lpu_id, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Ter_Record dbConnection, objTer

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objTer.ID <> 0 then updatre else insert

-

-Sub dbInsert_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_ter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objTer

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objTer.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim Update_SQL As String

-    

-    With objTer

-        Update_SQL = "UPDATE lpu_ter SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_Ter_RecordsbyLPU_ID(dbConnection As Object, allTer() As tTERAPIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_Ter_SQL As String

-    Dim getAll_Ter_SQL As String

-    Dim Ter_Count As Long

-    Ter_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    Else

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Ter_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Ter_Count = dbRecordset("TER_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Ter_RecordsbyLPU_ID = Ter_Count

-    

-    If Ter_Count > 0 Then

-        'we have records

-        ReDim allTer(1 To Ter_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_Ter_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpTer As tTERAPIA

-                 With tmpTer

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 allTer(index) = tmpTer

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE ID=" & objTer.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Ter_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-mLPU_LIST
->>>>>>
-Attribute VB_Name = "mLPU_LIST"

-Option Explicit

-

-Public Const CINP_AREA As String = "B12"

-Public Const CLPU_NAME As Integer = 0

-Public Const CLPU_NAME1 As Integer = 1

-Public Const CLPU_NAME2 As Integer = 2

-Public Const CLPU_ID As Integer = 3

-Public Const CLPU_BEDS As Integer = 4

-Public Const CLPU_NFG As Integer = 5

-Public Const CLPU_NMG As Integer = 6

-Public Const CLPU_HIR As Integer = 7

-Public Const CLPU_TER As Integer = 8

-Public Const CLPU_CAR As Integer = 9

-Public Const CLPU_FACT As Integer = 10

-Public Const CLPU_PLAN As Integer = 11

-Public Const CLPU_PAT_LPU As Integer = 16

-Public Const CLPU_BDGT As Integer = 17

-Public Const CLPU_PAT_ALL As Integer = 16

-

-Sub EditLPU(cLPU As tLPU, ent_date As String)

-    NoFunc

-End Sub

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("LPU_LIST")

-        s = .Range("C4") & " " & .Range("C3") & ", " & .Range("G4") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_LPU_BBL").Range("title") = MakeChartTitle

-End Sub

-

-Sub Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PIE").Range("title") = MakeChartTitle

-End Sub

-

-Sub Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU_A").Range("title") = MakeChartTitle

-End Sub

-

-Sub btLPU_DEL_IT()

-'    Dim cLPU As tLPU

-'    Dim ent_date As String

-'    Dim delete_all As Integer

-'    Dim dlg_del As dlg_LPU_delete

-'

-'    With Worksheets("LPU_LIST")

-'        ent_date = .Range("ent_date")

-'        cLPU.id = .getCurrentLPU_ID()

-'    End With

-'

-'    If cLPU.id = 0 Then

-'        MsgBox "Укажите удаляемый объект", vbOKOnly, PROGRAM_NAME

-'        Exit Sub

-'    End If

-'    cLPU = Get_LPU_Record(cLPU.id)

-'

-'    Set dlg_del = New dlg_LPU_delete

-'    With dlg_del

-'        .chbDeleteQTR.Value = True

-'        .chbDeleteAll.Value = False

-'        .lComment = ent_date & ": Удаление ЛПУ '" _

-'        & cLPU.Name & "', расположенного по адресу:" _

-'        & cLPU.address & " не разрешено."

-'        .Show

-'    End With

-End Sub

-

-Sub btLPU_RET_IT()

-    With Worksheets("LPU_LIST")

-        .setEnt_date ("")

-        .Range("LAST_FOCUS") = ""

-        

-        Wks_select .Range("ret_addr")

-    End With

-

-End Sub

-

-

-Sub btLPU_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim lpu_id As Long

-

-    i = Worksheets(VAR_SHEET).Range("QTR_ACTION").Value

-    With Worksheets("LPU_LIST")

-        ent_date = .getEnt_date()

-

-

-        lpu_id = .getCurrentLPU_ID

-        If lpu_id = 0 And i <> 6 Then

-            i = 1

-        End If

-        Select Case i

-            Case 1

-                .SelectLPU_NAME lpu_id, ent_date

-                .Range("JUMP") = "LPU_BDGT"

-            Case 2

-                .SelectLPU_BDGT lpu_id, ent_date

-                .Range("JUMP") = "LPU_BDGT"

-            Case 3

-                .SelectLPU_HIR lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_HIR"

-

-            Case 4

-                .SelectLPU_TER lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_TER"

-

-            Case 5

-                .SelectLPU_C_ACS lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        End Select

-    End With

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-dbQTR
->>>>>>
-Attribute VB_Name = "dbQTR"

-Option Explicit

-

-Public Type tQTR

-    id As Long

-    entry_date As String

-    rep_id As Long

-    rm_id As Long

-    sale_PLAN As Long

-    ClxnH20mg As Long

-    ClxnH40mg As Long

-    ClxnT40mg As Long

-    ClxnC_IM As Long

-    ClxnC_ACS As Long

-End Type

-

-Function Get_QTR_Record(ByVal QTR_ID As Long, rm_id As Long) As tQTR

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_QTR_Record = dbGet_QTR_Record(dbConnection, QTR_ID, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_Record(dbConnection As Object, ByVal QTR_ID As Long, rm_id As Long) As tQTR

-    

-    Dim sql As String

-    Dim objQTR As tQTR

-    

-    With objQTR

-        .ClxnC_ACS = 0

-        .ClxnC_IM = 0

-        .ClxnH20mg = 0

-        .ClxnH40mg = 0

-        .ClxnT40mg = 0

-        .entry_date = ""

-        .id = QTR_ID

-        .rm_id = rm_id

-    End With

-    

-    sql = "SELECT * FROM quarter WHERE id=" & QTR_ID & " AND rm_id=" & rm_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objQTR.entry_date = dbRecordset("entry_date")

-        objQTR.rep_id = dbRecordset("rep_id")

-        objQTR.rm_id = dbRecordset("rm_id")

-        objQTR.sale_PLAN = dbRecordset("sale_plan")

-        objQTR.ClxnH20mg = dbRecordset("ClxnH20mg")

-        objQTR.ClxnH40mg = dbRecordset("ClxnH40mg")

-        objQTR.ClxnT40mg = dbRecordset("ClxnT40mg")

-        objQTR.ClxnC_IM = dbRecordset("ClxnC_IM")

-        objQTR.ClxnC_ACS = dbRecordset("ClxnC_ACS")

-        objQTR.id = dbRecordset("id")

-    End If

-    

-    dbGet_QTR_Record = objQTR

-

-End Function

-

-

-Function Get_QTR_Record_by_REP(ent_date As String, rep_id As Long, rm_id As Long) As tQTR

-    Dim dbConnection As Object

-    Dim allQTR() As tQTR

-    Dim i As Long

-

-    dbOpenConnection dbConnection

-

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id, rm_id)

-    If i <> 0 Then

-        Get_QTR_Record_by_REP = allQTR(1)

-    End If

-

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTR_Records_by_REP(ByRef all_QTR() As tQTR, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-

-    GetAll_QTR_Records_by_REP = dbGetAll_QTR_Records_By_REP(dbConnection, all_QTR, ent_date, rep_id, rm_id)

-

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGetAll_QTR_Records_By_REP(dbConnection As Object, all_QTR() As tQTR, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-

-    Dim getCount_QTR_SQL As String

-    Dim getAll_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    Dim rep_sql As String

-    Dim rm_sql As String

-    

-    rep_sql = ""

-    rm_sql = ""

-    

-    If rep_id <> 0 Then

-        rep_sql = " AND rep_id=" & rep_id

-    End If

-    

-    If rm_id <> 0 Then

-        rm_sql = " AND rm_id=" & rm_id

-    End If

-    

-    

-        getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter " & _

-        "WHERE entry_date like '" & ent_date & "' " & rep_sql & rm_sql

-        getAll_QTR_SQL = "SELECT * FROM quarter " & _

-        "WHERE entry_date like '" & ent_date & "' " & rep_sql & rm_sql & " ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-

-    dbRecordset.Close

-

-    dbGetAll_QTR_Records_By_REP = QTR_Count

-

-    If QTR_Count > 0 Then

-        'we have records

-        ReDim all_QTR(1 To QTR_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTR_SQL, dbConnection

-

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTR As tQTR

-                 With tmp_QTR

-                    .entry_date = dbRecordset("entry_date")

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .ClxnH20mg = dbRecordset("ClxnH20mg")

-                    .ClxnH40mg = dbRecordset("ClxnH40mg")

-                    .ClxnT40mg = dbRecordset("ClxnT40mg")

-                    .ClxnC_IM = dbRecordset("ClxnC_IM")

-                    .ClxnC_ACS = dbRecordset("ClxnC_ACS")

-                    .id = dbRecordset("id")

-                 End With

-

-                 all_QTR(index) = tmp_QTR

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-cdbQTR
->>>>>>
-Attribute VB_Name = "cdbQTR"

-Option Explicit

-

-Public Type tQTR_COMMON

-    qtr As tQTR

-    i_lcd As Long           ' число ЛПУ в СПИСКЕ

-    lcd() As tLPU_COMMON    ' список ЛПУ

-    c_beds As Long          ' сумма коек

-    c_bdgt_NFG As Long      ' общий бюджет на НФГ

-    c_bdgt_NMG As Long      ' общий бюджет на НМГ

-    c_bdgt_LPU As Long      ' общий бюджет на гепарины

-    c_sale_PLAN As Long     ' план продаж репа

-    c_sale_ALL As Long      ' продажи

-    c_sale_HIR As Long      ' в хирургии

-    c_sale_TER  As Long     ' в терапии

-    c_sale_CRD  As Long     ' в кардиологии

-    c_pat_HIR   As Long     ' пациенты

-    c_pat_TER   As Long     '

-    c_pat_CRD   As Long     '

-    c_pat_ALL   As Long     '

-    c_pat_LPU   As Long     ' Всего операций

-End Type

-

-Function Get_QTR_CommonList_by_REP(ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long, rm_id As Long) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_QTR_CommonList_by_REP = dbGet_QTR_CommonList_by_REP(dbConnection, qcd, ent_date, rep_id, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_CommonList_by_REP(dbConnection As Object, ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long, rm_id As Long) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim allQTR() As tQTR

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id, rm_id)

-    dbGet_QTR_CommonList_by_REP = i

-    If i > 0 Then

-        ReDim qcd(i)

-        For i = 1 To UBound(allQTR)

-            With qcd(i)

-                .qtr = allQTR(i)

-                .c_beds = 0

-                .c_bdgt_NFG = 0

-                .c_bdgt_NMG = 0

-                .c_bdgt_LPU = 0

-                .c_sale_PLAN = 0

-                .c_pat_HIR = 0

-                .c_pat_TER = 0

-                .c_pat_CRD = 0

-                .c_pat_ALL = 0

-                .c_sale_HIR = 0

-                .c_sale_TER = 0

-                .c_sale_CRD = 0

-                .c_sale_ALL = 0

-                .c_pat_LPU = 0

-                

-                j = dbGet_LPU_CommonQTR(dbConnection, .lcd, .qtr)

-                .i_lcd = j

-                If j > 0 Then

-                    For j = 1 To UBound(.lcd)

-                        .c_beds = .c_beds + .lcd(j).lpu.beds

-                        .c_bdgt_NFG = .c_bdgt_NFG + .lcd(j).bdgt.bdgt_NFG

-                        .c_bdgt_NMG = .c_bdgt_NMG + .lcd(j).bdgt.bdgt_NMG

-                        .c_bdgt_LPU = .c_bdgt_LPU + .lcd(j).bdgt_LPU

-                        .c_sale_PLAN = .c_sale_PLAN + .lcd(j).bdgt.sale_PLAN

-                        .c_pat_HIR = .c_pat_HIR + .lcd(j).pat_HIR

-                        .c_pat_TER = .c_pat_TER + .lcd(j).pat_TER

-                        .c_pat_CRD = .c_pat_CRD + .lcd(j).pat_CRD

-                        .c_pat_ALL = .c_pat_ALL + .lcd(j).pat_ALL

-                        .c_sale_HIR = .c_sale_HIR + .lcd(j).sale_HIR

-                        .c_sale_TER = .c_sale_TER + .lcd(j).sale_TER

-                        .c_sale_CRD = .c_sale_CRD + .lcd(j).sale_CRD

-                        .c_sale_ALL = .c_sale_ALL + .lcd(j).sale_ALL

-                        .c_pat_LPU = .c_pat_LPU + .lcd(j).pat_LPU

-                    Next j

-                    

-                End If

-            End With

-        Next i

-    End If

-End Function

-

-Function GetLastQtr() As String

-    Dim s As String

-    Dim r As Range

-    Set r = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Do While r.Cells(1, 1) <> ""

-        s = r.Cells(1, 1)

-        Set r = r.Cells.Offset(1, 0)

-    Loop

-    GetLastQtr = s

-End Function

-

-Function GetNextQTR(ent_date As String) As String

-    Dim rd As Range

-    Dim idx As Integer

-    Dim b As Variant

-    Dim dlg As dlg_newQTR

-    Set dlg = New dlg_newQTR

-    

-    If ent_date = "" Then

-        Dim ir As Variant

-        idx = 0

-        dlg.Show

-        b = dlg.Tag

-            

-        If IsNumeric(b) Then

-            GetNextQTR = dlg.cbQTR

-        Else

-            GetNextQTR = ""

-        End If

-    Else

-        Set rd = Worksheets(VAR_SHEET).Range("Date_Lst")

-        idx = WorksheetFunction.Match(ent_date, rd, 0)

-        GetNextQTR = WorksheetFunction.index(rd, idx + 1, 1)

-    End If

-End Function

-<<<<<<
-======================
-mRestView
->>>>>>
-Attribute VB_Name = "mRestView"

-Option Explicit

-

-Sub xlRestoreView()

-Attribute xlRestoreView.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute xlRestoreView.VB_ProcData.VB_Invoke_Func = " \n14"

-    With Application

-        .CommandBars("Standard").Visible = True

-        .CommandBars("Formatting").Visible = True

-        .DisplayFormulaBar = True

-        .DisplayStatusBar = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = True

-    End With

-End Sub

-<<<<<<
-======================
-dlg_newQTR
->>>>>>
-Attribute VB_Name = "dlg_newQTR"

-Attribute VB_Base = "0{92648543-CB84-4B6B-BEB3-539AE7EF9D84}{7E20E3E3-027A-483B-A14D-AA9EA5398ACC}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mDec2TS
->>>>>>
-Attribute VB_Name = "mDec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-CHRT_LPU_BBL
->>>>>>
-Attribute VB_Name = "CHRT_LPU_BBL"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    Unprotect

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Потенциал рынка: " & Range("title")

-    Range("view_key") = False

-    ChangeLabels

-    Range("A1").Select

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Unprotect

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub BCLabelChng_Click()

-    Unprotect

-    If Range("view_key") Then

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать названия"

-    Else

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать объемы"

-    End If

-    Range("view_key") = Not Range("view_key")

-    ChangeLabels

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub ChangeLabels()

-    Dim i As Integer

-    Dim offset_text As Integer

-    Dim src As Range

-    Set src = Range("CHRT_BBL_DATA")

-    

-    offset_text = 3

-    If Range("view_key") Then

-        offset_text = 4

-    End If

-    

-    With ChartObjects(1).Chart

-        With .SeriesCollection(1)

-            For i = 1 To .Points.count

-                On Error GoTo ExitLabel

-                .Points(i).DataLabel.Characters.Text = Format(src.Cells(i, offset_text))

-            Next i

-        End With

-    End With

-ExitLabel:

-End Sub

-<<<<<<
-======================
-CHRT_PAT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PAT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Пациенты на Клексане(чел.): " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-<<<<<<
-======================
-CHRT_PAT_LPU
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Пациенты на Клексане(%): " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_nextQTR
->>>>>>
-Attribute VB_Name = "dlg_nextQTR"

-Attribute VB_Base = "0{067FED69-B41E-427D-AF59-5798B8E2E73A}{4C13CAB1-FDCC-4708-89EB-E92EDC125712}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-cdbLPU
->>>>>>
-Attribute VB_Name = "cdbLPU"

-Option Explicit

-

-Public Type tLPU_COMMON

-    lpu As tLPU

-    bdgt As tBUDGET

-    i_hir As Long

-    hir() As tHIRURGIA

-    i_ter As Long

-    ter() As tTERAPIA

-    i_ACS As Long

-    ACS() As tACS

-    bdgt_LPU As Long

-    sale_HIR As Long

-    sale_TER As Long

-    sale_CRD As Long

-    sale_ALL As Long

-    pat_HIR As Long

-    pat_TER As Long

-    pat_CRD As Long

-    pat_ALL As Long     ' Сумма всех пациентов на клексане

-    pat_LPU As Long     ' Число потенциальных пациентов для продаж клексана

-End Type

-

-Function Get_LPU_CommonQTR(ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    Get_LPU_CommonQTR = dbGet_LPU_CommonQTR(dbConnection, lcd, objQTR)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_CommonQTR(dbConnection As Object, ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    i = dbGetAll_LPU_byQTR(dbConnection, allLPU, objQTR.entry_date, objQTR.rep_id, objQTR.rm_id)

-    dbGet_LPU_CommonQTR = i

-    If i > 0 Then

-        ReDim lcd(i)

-        For i = 1 To UBound(allLPU)

-            dbGet_LPU_Common dbConnection, lcd(i), allLPU(i), objQTR

-        Next i

-    End If

-End Function

-

-Sub Get_LPU_Common(ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    dbGet_LPU_Common dbConnection, lcd, cLPU, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbGet_LPU_Common(dbConnection As Object, ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-

-    lcd.lpu = cLPU

-    lcd.bdgt = dbGet_BDGT_Record(dbConnection, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    lcd.i_hir = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, lcd.hir, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    lcd.i_ter = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, lcd.ter, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    lcd.i_ACS = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, lcd.ACS, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    With lcd

-        .bdgt_LPU = .bdgt.bdgt_NFG + .bdgt.bdgt_NMG

-        .pat_LPU = 0

-        If .i_hir > 0 Then

-            .pat_HIR = .hir(1).patients_ambulator_clexan + .hir(1).patients_stationar_clexan

-            .sale_HIR = objQTR.ClxnH20mg * (.hir(1).patients_ambulator_clexan_20mg + .hir(1).patients_stationar_clexan_20mg)

-            .sale_HIR = .sale_HIR + objQTR.ClxnH40mg * (.hir(1).patients_ambulator_clexan_40mg + .hir(1).patients_stationar_clexan_40mg)

-            .pat_LPU = .pat_LPU + .hir(1).operations_per_quarter

-        End If

-        If .i_ter > 0 Then

-            .pat_TER = .ter(1).patients_ambulator_clexan + .ter(1).patients_stationar_clexan

-            .sale_TER = .pat_TER * objQTR.ClxnT40mg

-            .pat_LPU = .pat_LPU + .ter(1).patients_per_quarter

-        End If

-        If .i_ACS > 0 Then

-            .pat_CRD = .ACS(1).patients_stationar_clexan

-            .sale_CRD = .pat_CRD * objQTR.ClxnC_ACS

-            .pat_LPU = .pat_LPU + .ACS(1).patients_per_quarter

-        End If

-        .pat_ALL = .pat_HIR + .pat_TER + .pat_CRD

-        .sale_ALL = .sale_HIR + .sale_TER + .sale_CRD

-    End With

-End Sub

-

-<<<<<<
-======================
-CHRT_PIE
->>>>>>
-Attribute VB_Name = "CHRT_PIE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Unprotect

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Доля продаж: " & Range("title")

-    

-    On Error Resume Next

-    Range("P5:Q24").Sort _

-        Key1:=Range("Q5"), _

-        Order1:=xlDescending, _

-        Header:=xlGuess, _

-        OrderCustom:=1, _

-        MatchCase:=False, _

-        Orientation:=xlTopToBottom

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PLN_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PLN_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Динамика продаж: " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_BDGT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_BDGT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Бюджеты ЛПУ: " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-dlg_LPU_delete
->>>>>>
-Attribute VB_Name = "dlg_LPU_delete"

-Attribute VB_Base = "0{9C81F4D2-4ECF-46F5-999B-9801D572A12F}{B382508B-7F3D-4747-8407-0F75F6F265F5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlg_Mail
->>>>>>
-Attribute VB_Name = "dlg_Mail"

-Attribute VB_Base = "0{EA8CE4CE-AC2E-45BC-BAF8-1429E6242097}{575F0762-04F4-4F86-B98A-8E87E3424B0D}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dbREP_id
->>>>>>
-Attribute VB_Name = "dbREP_id"

-Public Type tREPID

-    rep_id As Long

-    rm_id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function GetAll_REPID_Records_by_QTR(ByRef all_REPID() As tREPID, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_REPID_Records_by_QTR = dbGetAll_REPID_Records_by_QTR(dbConnection, all_REPID, ent_date, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function Get_REPID_Record(rep_id As Long, rm_id As Long) As tREPID

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REPID_Record = dbGet_REPID_Record(dbConnection, rep_id, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_REPID_Records(ByRef all_REPID() As tREPID) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_REPID_Records = dbGetAll_REPID_Records(dbConnection, all_REPID)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function dbGet_REPID_Record(dbConnection As Object, rep_id As Long, rm_id As Long) As tREPID

-    

-    Dim sql As String

-    Dim objREPID As tREPID

-    

-    objREPID.FirstName = ""

-    objREPID.LastName = ""

-    objREPID.Region = 0

-    objREPID.City = 0

-    sql = "SELECT * FROM " & _

-          "rep WHERE rep_id=" & rep_id & " AND rm_id=" & rm_id

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREPID.rep_id = dbRecordset("rep_id")

-        objREPID.rm_id = dbRecordset("rm_id")

-        objREPID.FirstName = dbRecordset("firstname")

-        objREPID.LastName = dbRecordset("lastname")

-        objREPID.Region = dbRecordset("region")

-        objREPID.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REPID_Record = objREPID

-        

-End Function

-

-Function dbGetAll_REPID_Records_by_QTR(dbConnection As Object, ByRef all_REPID() As tREPID, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    Dim Where As String

-    

-    REPID_Count = 0

-    

-    Where = " WHERE lpu_budget.entry_date like '" & ent_date & "' " & _

-        "AND rep.rep_id=lpu.rep_id AND lpu.id=lpu_budget.lpu_id"

-    If rm_id <> 0 Then

-        Where = Where & " AND rep.rm_id=" & rm_id

-    End If

-    

-    getAll_REPID_SQL = "SELECT distinct rep.* FROM rep, lpu, lpu_budget" & Where

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM (" & getAll_REPID_SQL & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records_by_QTR = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Function dbGetAll_REPID_Records(dbConnection As Object, ByRef all_REPID() As tREPID) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    REPID_Count = 0

-    

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM rep"

-    getAll_REPID_SQL = "SELECT * FROM rep"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-cdbExport
->>>>>>
-Attribute VB_Name = "cdbExport"

-Option Explicit

-

-Function GetDBSN() As String

-    Dim n As Long

-    Randomize Timer

-    n = Int((100000000 - 1000000 + 1) * Rnd + 1000000)

-    GetDBSN = Dec2ThirtySix(n)

-End Function

-

-Sub dbExport()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim old_file As String

-    

-    On Error GoTo ErrHandler

-    

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    old_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & "*.*"

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & GetDBSN() & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.DeleteFile old_file, True

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Данные экспортированы в файл:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для передачи", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-Exit Sub

-

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-<<<<<<
-======================
-mRegs
->>>>>>
-Attribute VB_Name = "mRegs"

-Option Explicit

-

-Function GetRegionName(idx As Integer) As String

-    GetRegionName = Worksheets(REGS_SHEET).Range("LST_REGIONS").Cells(idx + 1, 1).Text

-End Function

-

-Function GetCityName(idx_reg As Integer, idx_city As Integer) As String

-    GetCityName = Worksheets(REGS_SHEET).Range("CITY_TABLES").Offset(idx_city + 1, idx_reg * 2).Text

-End Function

-

-Sub testReg()

-    Dim r As Integer

-    Dim c As Integer

-    Dim s As String

-    

-    r = 3

-    c = 3

-    s = GetRegionName(r)

-    s = s & ", " & GetCityName(r, c)

-    MsgBox s

-End Sub

-

-<<<<<<
-======================
-RM_QTR
->>>>>>
-Attribute VB_Name = "RM_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CRGN_QT As Integer = 0

-Const CRGN_PLN As Integer = 2

-Const CRGN_FCT As Integer = 3

-Const CRGN_BDG As Integer = 4

-Const CRGN_LPU As Integer = 5

-Const CRGN_REP As Integer = 6

-Const CRGN_HIR As Integer = 7

-Const CRGN_TER As Integer = 8

-Const CRGN_CRD As Integer = 9

-Const CRGN_CLXN_BDG As Integer = 10

-Const CRGN_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Const LOCAL_ENT_DATE As String = "B11"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("RM_QTR")

-        s = .Range("D5") & " " & .Range("D4") & ", " & .Range("H4") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub update_history()

-    Dim objRGN() As tREGION

-    Dim i As Long

-    Dim r As Range

-    Dim cRMan As tREGMAN

-

-    cRMan = Get_REGMAN_Record(Range("RM_ID"))

-    

-    Range("D4") = cRMan.LastName

-    Range("D5") = cRMan.FirstName

-

-    Range("H4") = GetRegionName(cRMan.Region)

-    

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetRGN_COMM_DATA(objRGN, Range("RM_ID"))

-    

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objRGN)

-            r.Offset(i - 1, CRGN_QT) = objRGN(i).ent_date

-            r.Offset(i - 1, CRGN_FCT) = objRGN(i).total_SALE

-            r.Offset(i - 1, CRGN_PLN) = objRGN(i).sale_PLAN

-            r.Offset(i - 1, CRGN_BDG) = objRGN(i).total_BDGT

-            r.Offset(i - 1, CRGN_LPU) = objRGN(i).total_LPU

-            r.Offset(i - 1, CRGN_REP) = objRGN(i).total_REP

-            r.Offset(i - 1, CRGN_HIR) = objRGN(i).total_HIR

-            r.Offset(i - 1, CRGN_TER) = objRGN(i).total_TER

-            r.Offset(i - 1, CRGN_CRD) = objRGN(i).total_ACS

-            If objRGN(i).total_BDGT <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_BDG) = objRGN(i).total_SALE / objRGN(i).total_BDGT

-            End If

-            If objRGN(i).total_BDGT_NMG <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_NMG) = objRGN(i).total_SALE / objRGN(i).total_BDGT_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRGN_CRD + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-

-Sub Draw_PLN_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_FCT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PLN_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Draw_BDGT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_CLXN_NMG + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_BDGT_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Public Sub cbxRM_QtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR_RM

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR_RM

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR_RM

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = RM_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CRGN_QT + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    If r = "" Then

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = currRange.address

-    End If

-    Cancel = True

-    btRM_QTR_Do_IT

-End Sub

-

-<<<<<<
-======================
-dbREG_MAN
->>>>>>
-Attribute VB_Name = "dbREG_MAN"

-Option Explicit

-

-Public Type tREGMAN

-    rm_id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function Get_REGMAN_Record(rm_id As Long) As tREGMAN

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REGMAN_Record = dbGet_REGMAN_Record(dbConnection, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Sub Set_REGMAN_Record(cREGMAN As tREGMAN)

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbSet_REGMAN_Record dbConnection, cREGMAN

-'    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_REGMAN_Record(dbConnection As Object, rm_id As Long) As tREGMAN

-    

-    Dim sql As String

-    Dim objREGMAN As tREGMAN

-    

-    objREGMAN.FirstName = ""

-    objREGMAN.LastName = ""

-    objREGMAN.Region = 0

-    objREGMAN.City = 0

-    objREGMAN.rm_id = rm_id

-    sql = "SELECT * FROM " & _

-          "reg_man WHERE mgr_id=" & rm_id

-          

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREGMAN.FirstName = dbRecordset("firstname")

-        objREGMAN.LastName = dbRecordset("lastname")

-        objREGMAN.Region = dbRecordset("region")

-        objREGMAN.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REGMAN_Record = objREGMAN

-        

-End Function

-

-Public Sub dbSet_REGMAN_Record(dbConnection As Object, ByRef objREGMAN As tREGMAN)

-  

-'    Dim DeleteSQL As String

-'    Dim InsertSQL As String

-'

-'    DeleteSQL = "DELETE FROM reg_man"

-'    InsertSQL = "INSERT INTO reg_man (firstname, lastname, region, city) VALUES (" & _

-'    "'" & objREGMAN.FirstName & "', " & _

-'    "'" & objREGMAN.LastName & "', " & _

-'    objREGMAN.Region & ", " & _

-'    objREGMAN.City & ")"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-       

-End Sub

-

-

-

-<<<<<<
-======================
-dbDatabaseMerge
->>>>>>
-Attribute VB_Name = "dbDatabaseMerge"

-Option Explicit

-

-Public Type tDBFIELD

-    Name As String

-End Type

-

-Public Type tDBTABLE

-    Name As String

-    field() As tDBFIELD

-End Type

-

-

-Function dbGetConnection(dbAccessFileFullPath As String) As Object

-    Dim dbConnection As Object

-    Dim dbAccessFilePasswd As String

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFileFullPath & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    Set dbGetConnection = dbConnection

-End Function

-

-Sub dbCloseOpenedConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteOpenedSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-Function dbMergeREP(from_dbConnection As Object, to_dbConnection As Object) As Long

-

-    Dim getRecordset As Object

-    Dim getREPData_SQL As String

-    Dim REP_fn As String

-    Dim REP_ln As String

-    Dim REP_region As String

-    Dim REP_city As String

-

-

-    getREPData_SQL = "SELECT * FROM rep"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getREPData_SQL, from_dbConnection

-        

-        If Not getRecordset.BOF Then

-            REP_fn = getRecordset("firstname")

-            REP_ln = getRecordset("lastname")

-            REP_city = getRecordset("city")

-            REP_region = getRecordset("region")

-        Else

-            MsgBox "There is no information about rep! This database cannot be merged!!!"

-            dbMergeREP = -1

-            Exit Function

-        End If

-    

-    Dim insertRecordset As Object

-    Set insertRecordset = CreateObject("ADODB.Recordset")

-        

-    insertRecordset.Open "rep", to_dbConnection, 2, 2

-    insertRecordset.addnew

-        

-    insertRecordset("firstname") = REP_fn

-    insertRecordset("lastname") = REP_ln

-    insertRecordset("region") = REP_region

-    insertRecordset("city") = REP_city

-    insertRecordset.Update

-    insertRecordset.MoveLast

-    'new ID

-    

-    dbMergeREP = insertRecordset("rep_id")

-    

-End Function

-

-Sub dbMergeLPU(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getLPU_SQL As String

-    Dim getRecordset As Object

-    Dim idx As Long

-    idx = 1

-    

-    getLPU_SQL = "SELECT * FROM lpu"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getLPU_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            ReDim Preserve objLPU(1 To idx)

-            objLPU(idx).old_lpu_id = getRecordset("id")

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "lpu", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("name") = getRecordset("name")

-            insRS("address") = getRecordset("address")

-            insRS("beds") = getRecordset("beds")

-            insRS.Update

-            insRS.MoveLast

-            'new ID

-            

-            objLPU(idx).new_lpu_id = insRS("id")

-                        

-            idx = idx + 1

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about LPU! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-

-Sub dbMergeLPURelated(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object)

-

-    ' 6 tables to change

-    Dim tables(1 To 5) As tDBTABLE

-    

-    'lpu budget

-    tables(1).Name = "lpu_budget"

-    ReDim tables(1).field(1 To 4)

-    

-    tables(1).field(1).Name = "entry_date"

-    tables(1).field(2).Name = "bdgt_NMG"

-    tables(1).field(3).Name = "bdgt_NFG"

-    tables(1).field(4).Name = "sale_PLAN"

-    

-    'lpu hir

-    tables(2).Name = "lpu_hir"

-    ReDim tables(2).field(1 To 13)

-    

-    tables(2).field(1).Name = "entry_date"

-    tables(2).field(2).Name = "operations_per_quarter"

-    tables(2).field(3).Name = "risk_percent"

-    tables(2).field(4).Name = "patients_with_risk_ON"

-    tables(2).field(5).Name = "patients_ambulator"

-    tables(2).field(6).Name = "patients_ambulator_nmg"

-    tables(2).field(7).Name = "patients_ambulator_clexan"

-    tables(2).field(8).Name = "patients_ambulator_clexan_40mg"

-    tables(2).field(9).Name = "patients_ambulator_clexan_20mg"

-    tables(2).field(10).Name = "patients_stationar_nmg"

-    tables(2).field(11).Name = "patients_stationar_clexan"

-    tables(2).field(12).Name = "patients_stationar_clexan_40mg"

-    tables(2).field(13).Name = "patients_stationar_clexan_20mg"

-    

-    

-    'lpu acs

-    tables(3).Name = "lpu_acs"

-    ReDim tables(3).field(1 To 5)

-    

-    tables(3).field(1).Name = "entry_date"

-    tables(3).field(2).Name = "patients_with_geparins"

-    tables(3).field(3).Name = "patients_per_quarter"

-    tables(3).field(4).Name = "patients_stationar_nmg"

-    tables(3).field(5).Name = "patients_stationar_clexan"

-    

-    'lpu acs

-    tables(4).Name = "lpu_im"

-    ReDim tables(4).field(1 To 5)

-    

-    tables(4).field(1).Name = "entry_date"

-    tables(4).field(2).Name = "patients_with_geparins"

-    tables(4).field(3).Name = "patients_per_quarter"

-    tables(4).field(4).Name = "patients_stationar_nmg"

-    tables(4).field(5).Name = "patients_stationar_clexan"

-    

-    

-    'lpu acs

-    tables(5).Name = "lpu_ter"

-    ReDim tables(5).field(1 To 9)

-    

-    tables(5).field(1).Name = "entry_date"

-    tables(5).field(2).Name = "patients_per_quarter"

-    tables(5).field(3).Name = "risk_percent"

-    tables(5).field(4).Name = "patients_with_risk_ON"

-    tables(5).field(5).Name = "patients_ambulator"

-    tables(5).field(6).Name = "patients_ambulator_nmg"

-    tables(5).field(7).Name = "patients_ambulator_clexan"

-    tables(5).field(8).Name = "patients_stationar_nmg"

-    tables(5).field(9).Name = "patients_stationar_clexan"

-    

-    

-    

-    Dim tbl_idx As Integer

-    

-    For tbl_idx = 1 To UBound(tables)

-        

-        Dim getSQL As String

-        Dim getRS As Object

-        

-        

-        

-        Set getRS = CreateObject("ADODB.Recordset")

-        

-        getSQL = "SELECT * FROM " & tables(tbl_idx).Name

-        getRS.Open getSQL, from_db

-        

-        If Not getRS.BOF Then

-            Do While Not getRS.EOF

-                Dim insRS As Object

-                Set insRS = CreateObject("ADODB.Recordset")

-                

-                insRS.Open tables(tbl_idx).Name, to_db, 2, 2

-                insRS.addnew

-                Dim fld_idx As Integer

-    

-                    For fld_idx = 1 To UBound(tables(tbl_idx).field)

-                        insRS(tables(tbl_idx).field(fld_idx).Name) = getRS(tables(tbl_idx).field(fld_idx).Name)

-                        insRS("lpu_id") = findNewLPU_IDByOld(objLPU, getRS("lpu_id"))

-                    Next fld_idx

-                    

-                insRS.Update

-                insRS.MoveLast

-                getRS.MoveNext

-            Loop

-        End If

-        

-        

-    Next tbl_idx

-

-End Sub

-

-Function findNewLPU_IDByOld(objLPU() As tLPUCONVERTION, old_id As Long)

-

-Dim i As Integer

-For i = 1 To UBound(objLPU)

-    If objLPU(i).old_lpu_id = old_id Then

-        findNewLPU_IDByOld = objLPU(i).new_lpu_id

-        Exit Function

-    End If

-Next i

-

-findNewLPU_IDByOld = -1

-End Function

-

-

-

-

-

-Sub dbMergeQTR(from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getQTR_SQL As String

-    Dim getRecordset As Object

-    

-    getQTR_SQL = "SELECT * FROM quarter"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getQTR_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "quarter", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("entry_date") = getRecordset("entry_date")

-            insRS("sale_plan") = getRecordset("sale_plan")

-            insRS("ClxnH20mg") = getRecordset("ClxnH20mg")

-            insRS("ClxnH40mg") = getRecordset("ClxnH40mg")

-            insRS("ClxnT40mg") = getRecordset("ClxnT40mg")

-            insRS("ClxnC_IM") = getRecordset("ClxnC_IM")

-            insRS("ClxnC_ACS") = getRecordset("ClxnC_ACS")

-            

-            

-            insRS.Update

-            

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about quarter budget! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-dbMerge
->>>>>>
-Attribute VB_Name = "dbMerge"

-Option Explicit

-

-Public Type tLPUCONVERTION

-    old_lpu_id As Long

-    new_lpu_id As Long

-End Type

-

-Sub Merge_BackUp_All_Data()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim time_stump As String

-    

-    On Error GoTo ErrHandler

-    

-    time_stump = Format(Date, "yy-mm-dd_") & Format(Time, "hh-mm")

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_BACKUPNAME & time_stump & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Старые данные сохранены в файле:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для восстанеовления данных в случае утери", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-    Exit Sub

-    

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-

-Sub Merge_Clear_All_Data(access_file_full_path As String)

-    

-    Dim db As Object

-    Dim tables_to_clear() As String

-    On Error GoTo ErrHandler

-    

-    ReDim tables_to_clear(1 To 10)

-    tables_to_clear(1) = "rep"

-    tables_to_clear(2) = "lpu"

-    tables_to_clear(3) = "lpu_budget"

-    tables_to_clear(4) = "lpu_hir"

-    tables_to_clear(5) = "lpu_ter"

-    tables_to_clear(6) = "lpu_acs"

-    tables_to_clear(7) = "lpu_im"

-    tables_to_clear(8) = "quarter"

-    tables_to_clear(9) = "quarter_rm"

-    tables_to_clear(10) = "reg_man"

-    

-    Set db = dbGetConnection(access_file_full_path)

-

-    Dim i As Integer

-    

-    For i = 1 To UBound(tables_to_clear)

-        

-        If tables_to_clear(i) <> "" Then

-            Dim Clear_SQL As String

-            Clear_SQL = "DELETE FROM " & tables_to_clear(i)

-            dbExecuteOpenedSQL db, Clear_SQL

-        Else

-            'do nothing or show message

-        End If

-    Next i

-    

-    dbCloseOpenedConnection db

-    Set db = Nothing

-    

-Exit Sub

-

-ErrHandler:

-    MsgBox "something wrong: " & err.Description

-    Resume Next

-    

-End Sub

-

-Function MergeREP(from_file As String, to_file As String) As Long

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    Dim new_rep_id As Long

-

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    MergeREP = dbMergeREP(db1, db2)

-    'MsgBox "new rep ID is " & new_rep_id

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Function

-

-Sub MergeQTR(from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeQTR db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-

-Sub MergeLPU(objLPU() As tLPUCONVERTION, from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeLPU objLPU, db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-Sub MergeLPURelated(objLPU() As tLPUCONVERTION, from_file As String, to_file As String)

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    dbMergeLPURelated objLPU, db1, db2

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-

-End Sub

-

-Sub MergeGlobal(rep_files() As String, rm_file As String)

-

-    Dim i As Integer

-    'clear output file content

-    Merge_Clear_All_Data rm_file

-    

-    For i = 1 To UBound(rep_files)

-        

-        Dim rep_file As String

-        'setup input and output files

-        rep_file = rep_files(i)

-        

-        Dim new_rep_id As Long

-        ' insert REP data and get new rep_id

-        new_rep_id = MergeREP(rep_file, rm_file)

-        

-        Dim objLPU() As tLPUCONVERTION

-        'insert all LPU using new generated rep_id

-        'and populate objLPU old->new relation object

-        

-        MergeLPU objLPU, rep_file, rm_file, new_rep_id

-        'insert quarter data using new rep_id

-        MergeQTR rep_file, rm_file, new_rep_id

-        

-        

-        ' and.... insert all another data (5 tables excl version and hw)

-        'using objLPU old->new relation object

-        MergeLPURelated objLPU, rep_file, rm_file

-    

-    

-    Next i

-    

-End Sub

-

-Function GetDBList(MyPath() As String, ByRef dblist() As String) As Integer

-    Dim i As Integer

-    Dim MyName, MyMask

-    MyMask = MyPath(0) & MyPath(1) & PROGRAM_DATAEXT

-    i = 0

-    MyName = Dir(MyMask)      ' Retrieve the first entry.

-    Do While MyName <> ""    ' Start the loop.

-        ' Ignore the current directory and the encompassing directory.

-        If MyName <> "." And MyName <> ".." Then

-            ' Use bitwise comparison to make sure MyName is a directory.

-            i = i + 1

-            ReDim Preserve dblist(i)

-            dblist(i) = MyPath(0) & MyName

-        End If

-        MyName = Dir    ' Get next entry.

-    Loop

-    GetDBList = i

-End Function

-

-<<<<<<
-======================
-cdbPRJ
->>>>>>
-Attribute VB_Name = "cdbPRJ"

-Option Explicit

-

-Type tPROJECT

-    total_SALE  As Long ' общий объем продаж

-    total_BDGT  As Long ' бюджет всех ЛПУ

-    total_BDGT_NMG As Long ' бюджет всех ЛПУ на НМГ

-    total_LPU   As Long ' число ЛПУ

-    total_REP   As Long ' число репов

-    total_RM    As Long ' число репов

-    total_BEDS  As Long ' общее число коек

-    total_HIR   As Long '  общее число пациентов на клексане в хирургии

-    total_TER   As Long '  общее число пациентов на клексане в терапии

-    total_ACS   As Long '  общее число пациентов на клексане в кардиологии

-    sale_PLAN   As Long '  план продаж Авентиса

-    objRGN() As tREGION

-End Type

-

-Function GetPRJ_COMM_DATA(ByRef prj_data As tPROJECT) As Integer

-    Dim i As Integer

-    i = GetRGN_COMM_DATA(prj_data.objRGN, 0)

-    GetPRJ_COMM_DATA = i

-    If i > 0 Then

-        With prj_data

-            .sale_PLAN = 0

-            .total_ACS = 0

-            .total_BDGT = 0

-            .total_BDGT_NMG = 0

-            .total_BEDS = 0

-            .total_HIR = 0

-            .total_LPU = 0

-            .total_REP = 0

-            .total_RM = 0

-            .total_SALE = 0

-            .total_TER = 0

-            For i = 1 To UBound(prj_data.objRGN)

-                

-            Next i

-        End With

-    End If

-

-End Function

-

-<<<<<<
-======================
-dbQTR_RM
->>>>>>
-Attribute VB_Name = "dbQTR_RM"

-Option Explicit

-

-Public Type tQTRRM

-    id As Long

-    entry_date As String

-    rm_id As Long

-    sale_PLAN As Long

-End Type

-

-

-Sub Insert_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objQTRRM.id <> 0 Then

-        dbUpdate_QTRRM_Record dbConnection, objQTRRM

-    Else

-        dbInsert_QTRRM_Record dbConnection, objQTRRM

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-Function Get_QTRRM_Record(ent_date As String) As tQTRRM

-    Dim dbConnection As Object

-    Dim allQTRRM() As tQTRRM

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    i = dbGetAll_QTRRM_Records(dbConnection, allQTRRM, ent_date)

-    If i <> 0 Then

-        Get_QTRRM_Record = allQTRRM(1)

-    End If

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTRRM_Records(ByRef all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_QTRRM_Records = dbGetAll_QTRRM_Records(dbConnection, all_QTRRM, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_QTRRM_Record dbConnection, objQTRRM

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objQTRRM.ID <> 0 then updatre else insert

-Sub dbInsert_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "quarter_rm", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objQTRRM

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("sale_plan") = .sale_PLAN

-        dbRecordset("rm_id") = .rm_id

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objQTRRM.id = dbRecordset("id")

-

-End Sub

-

-Sub dbUpdate_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim Update_SQL As String

-    

-    With objQTRRM

-        Update_SQL = "UPDATE quarter_rm SET " & _

-            "entry_date='" & .entry_date & "'" & "," & _

-            "rm_id=" & .rm_id & "," & _

-            "sale_plan=" & .sale_PLAN & "," & _

-            " WHERE id=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if ent_date = % then all_records

-Function dbGetAll_QTRRM_Records(dbConnection As Object, all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    

-    Dim getCount_QTRRM_SQL As String

-    Dim getAll_QTRRM_SQL As String

-    Dim QTRRM_Count As Long

-    QTRRM_Count = 0

-    

-    getCount_QTRRM_SQL = "SELECT COUNT(*) AS QTRRM_TOTAL FROM quarter_rm WHERE entry_date like '" & ent_date & "'"

-    getAll_QTRRM_SQL = "SELECT * FROM quarter_rm WHERE entry_date like '" & ent_date & "' ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTRRM_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTRRM_Count = dbRecordset("QTRRM_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_QTRRM_Records = QTRRM_Count

-    

-    If QTRRM_Count > 0 Then

-        'we have records

-        ReDim all_QTRRM(1 To QTRRM_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTRRM_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTRRM As tQTRRM

-                 With tmp_QTRRM

-                    .entry_date = dbRecordset("entry_date")

-                    .rm_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .id = dbRecordset("id")

-                 End With

-                 

-                 all_QTRRM(index) = tmp_QTRRM

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM quarter_rm " & _

-    "WHERE id=" & objQTRRM.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-    

-    'delete related budget entries

-    MsgBox "remember delete related"

-'    dbDelete_BDGT_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Hir_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Ter_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_ACS_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-       

-End Sub

-

-

-<<<<<<
-======================
-REP_LIST
->>>>>>
-Attribute VB_Name = "REP_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Const LOCAL_ENT_DATE As String = "C10"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-

-Public Function getCurrentREP_ID() As Long

-    Dim r As Range

-

-    With Worksheets("REP_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CREP_ID)

-    End With

-

-    getCurrentREP_ID = r

-End Function

-

-Public Sub REP_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Rep_Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Rep_Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Rep_Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Rep_Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectREP_LPU(rep_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    Range("JUMP") = "LPU_LIST"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-        .Range("RM_ID") = rm_id

-        .setEnt_date (getEnt_date())

-    End With

-End Sub

-

-Public Sub SelectREP_QTR(rep_id As Long)

-    Dim vo As Boolean

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    Range("JUMP") = "REP_QTR"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("REP_QTR")

-        .Range("VIEW_ONLY") = vo

-        .Range("RM_ID") = rm_id

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateREPList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim rep_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CREP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CREP_AREA).row, CREP_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    rep_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CREP_AREA).Column

-    

-    If i < 4 Then

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 1

-    Else

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 2

-    End If

-    

-    If rep_id = 0 Then

-        Range("LAST_FOCUS") = Range(CREP_AREA).address

-    End If

-

-    If rep_id = 0 Then

-        i = CREP_NAME

-        Range("JUMP") = ""

-    Else

-        btREP_LIST_DO_IT

-    End If

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateREPList()

-    Dim rcd() As tREPID_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-

-    ent_date = getEnt_date

-

-    Dim rm_struc As tREGMAN

-    

-    i = Range("RM_ID")

-    rm_struc = Get_REGMAN_Record(i)

-    

-    Range("C4") = rm_struc.LastName

-    Range("C5") = rm_struc.FirstName

-

-    Range("G5") = GetRegionName(rm_struc.Region)

-    

-    i = Get_REP_CommonList_by_QTR(rcd, ent_date, Range("RM_ID"))

-

-    

-    With ThisWorkbook.Worksheets("REP_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(rcd)

-            r.Offset(i - 1, CREP_NAME) = rcd(i).rep.FirstName & " " & rcd(i).rep.LastName

-            r.Offset(i - 1, CREP_ID) = rcd(i).rep.rep_id

-            r.Offset(i - 1, CREP_BEDS) = rcd(i).qtrs(1).c_beds

-

-            r.Offset(i - 1, CREP_NFG) = rcd(i).qtrs(1).c_bdgt_NFG

-            r.Offset(i - 1, CREP_NMG) = rcd(i).qtrs(1).c_bdgt_NMG

-

-            r.Offset(i - 1, CREP_PLAN) = rcd(i).qtrs(1).qtr.sale_PLAN

-

-            r.Offset(i - 1, CREP_HIR) = rcd(i).qtrs(1).c_pat_HIR

-            r.Offset(i - 1, CREP_TER) = rcd(i).qtrs(1).c_pat_TER

-            r.Offset(i - 1, CREP_CAR) = rcd(i).qtrs(1).c_pat_CRD

-            r.Offset(i - 1, CREP_FACT) = rcd(i).qtrs(1).c_sale_ALL

-            r.Offset(i - 1, CREP_PAT_LPU) = rcd(i).qtrs(1).c_pat_LPU

-            r.Offset(i - 1, CREP_BDGT) = rcd(i).qtrs(1).c_bdgt_LPU

-            If rcd(i).qtrs(1).c_bdgt_LPU > 0 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = rcd(i).qtrs(1).c_sale_ALL / rcd(i).qtrs(1).c_bdgt_LPU

-            End If

-            If r.Offset(i - 1, CREP_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-

-

-<<<<<<
-======================
-mREP_LIST
->>>>>>
-Attribute VB_Name = "mREP_LIST"

-Option Explicit

-

-Public Const CREP_AREA As String = "B12"

-Public Const CREP_NAME As Integer = 0

-Public Const CREP_NAME1 As Integer = 1

-Public Const CREP_NAME2 As Integer = 2

-Public Const CREP_ID As Integer = 3

-Public Const CREP_BEDS As Integer = 4

-Public Const CREP_NFG As Integer = 5

-Public Const CREP_NMG As Integer = 6

-Public Const CREP_HIR As Integer = 7

-Public Const CREP_TER As Integer = 8

-Public Const CREP_CAR As Integer = 9

-Public Const CREP_FACT As Integer = 10

-Public Const CREP_PLAN As Integer = 11

-Public Const CREP_PAT_LPU As Integer = 16

-Public Const CREP_BDGT As Integer = 17

-

-

-Const LOCAL_ENT_DATE As String = "C10"

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Sub EditREP(cRep As tREPID, ent_date As String)

-    NoFunc

-End Sub

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("REP_LIST")

-        s = .Range("C5") & " " & .Range("C4") & ", " & .Range("G5") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub Rep_Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_LPU_BBL").Range("title") = MakeChartTitle

-End Sub

-

-Sub Rep_Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CREP_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CREP_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CREP_FACT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PIE").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rep_Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CREP_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CREP_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CREP_HIR + 1)

-            psum = psum + src.Cells(i, CREP_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CREP_TER + 1)

-            psum = psum + src.Cells(i, CREP_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CREP_CAR + 1)

-            psum = psum + src.Cells(i, CREP_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CREP_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rep_Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CREP_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CREP_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CREP_HIR + 1)

-            psum = psum + src.Cells(i, CREP_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CREP_TER + 1)

-            psum = psum + src.Cells(i, CREP_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CREP_CAR + 1)

-            psum = psum + src.Cells(i, CREP_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CREP_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU_A").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub btREP_RET_IT()

-    With Worksheets("REP_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = "RM_QTR"

-    End With

-    Dim str As String

-    str = Range("ret_addr")

-    ThisWorkbook.Worksheets(str).Activate

-End Sub

-

-

-Sub btREP_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim rep_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("REP_LST_DETALS")

-    With Worksheets("REP_LIST")

-        rep_id = .getCurrentREP_ID

-        

-        Select Case i

-            Case 1:

-                .SelectREP_QTR rep_id

-            Case 2:

-                ent_date = .getEnt_date()

-                .SelectREP_LPU rep_id, ent_date

-        End Select

-    End With

-    

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-

-

-

-<<<<<<
-======================
-cdbREP
->>>>>>
-Attribute VB_Name = "cdbREP"

-Option Explicit

-

-Public Type tREPID_COMMON

-    rep As tREPID

-    i_qtrs As Integer

-    qtrs() As tQTR_COMMON

-End Type

-

-Function Get_REP_CommonList_by_QTR(ByRef rcd() As tREPID_COMMON, ent_date As String, rm_id As Long) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_REP_CommonList_by_QTR = dbGet_REP_CommonList_by_QTR(dbConnection, rcd, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_REP_CommonList_by_QTR(dbConnection As Object, ByRef rcd() As tREPID_COMMON, ent_date As String, rm_id As Long) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim k As Long

-    Dim allREPID() As tREPID

-    

-    i = dbGetAll_REPID_Records_by_QTR(dbConnection, allREPID, ent_date, rm_id)

-    dbGet_REP_CommonList_by_QTR = i

-    If i > 0 Then

-        ReDim rcd(i)

-        For i = 1 To UBound(allREPID)

-            rcd(i).rep = allREPID(i)

-            rcd(i).i_qtrs = Get_QTR_CommonList_by_REP(rcd(i).qtrs, ent_date, allREPID(i).rep_id, allREPID(i).rm_id)

-        Next i

-    End If

-End Function

-

-

-

-<<<<<<
-======================
-CHRT_PAT_LPU_A
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU_A"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Пациенты на Клексане(чел.): " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-cdbRegion
->>>>>>
-Attribute VB_Name = "cdbRegion"

-Option Explicit

-

-Type tREGION

-    ent_date As String

-    rm_id As Long

-    total_SALE As Long ' общий объем продаж

-    total_BDGT As Long ' бюджет всех ЛПУ

-    total_BDGT_NMG As Long ' бюджет всех ЛПУ на НМГ

-    total_LPU As Long ' число ЛПУ

-    total_REP   As Long ' число репов

-    total_BEDS As Long ' общее число коек

-    total_HIR As Long '  общее число пациентов на клексане в хирургии

-    total_TER As Long '  общее число пациентов на клексане в терапии

-    total_ACS As Long '  общее число пациентов на клексане в кардиологии

-    sale_PLAN As Long '  план продаж Авентиса

-End Type

-

-Function GetRGN_COMM_DATA(ByRef reg_data() As tREGION, rm_id As Long) As Integer

-    Dim q_date() As String

-    Dim q_count As Integer, i As Integer

-    

-    q_count = getAllQTRNames(q_date, rm_id)

-    If q_count > 0 Then

-        ReDim reg_data(q_count)

-        For i = 1 To q_count

-            Dim current_REP_count As Integer

-            reg_data(i).rm_id = rm_id

-            reg_data(i).ent_date = q_date(i)

-            current_REP_count = getREGION_by_QTR(q_date(i), reg_data(i), rm_id)

-        Next i

-    End If

-    

-    GetRGN_COMM_DATA = q_count

-End Function

-

-' if rm_id = 0 then gets all records

-Function getAllQTRNames(ByRef qtr_lst() As String, rm_id As Long) As Integer

-    

-    Dim sql As String

-    Dim i As Integer

-    Dim db As Object, rs As Object

-    

-    sql = "SELECT DISTINCT entry_date FROM lpu_budget"

-    

-    If rm_id <> 0 Then

-        sql = sql & " WHERE rm_id=" & rm_id

-    End If

-    

-    i = 0

-    

-    dbOpenConnection db

-    Set rs = CreateObject("ADODB.Recordset")

-    

-    rs.Open sql, db

-        

-        If Not rs.BOF Then

-            Do While Not rs.EOF

-                i = i + 1

-                ReDim Preserve qtr_lst(i)

-                qtr_lst(i) = rs("entry_date")

-                rs.MoveNext

-            Loop

-        Else

-            getAllQTRNames = 0

-            Exit Function

-        End If

-    getAllQTRNames = i

-    dbCloseConnection db

-End Function

-

-Function getREGION_by_QTR(ent_date As String, treg As tREGION, rm_id As Long) As Integer

-    Dim rep_count As Integer

-    rep_count = 0

-    

-    Dim reps() As tQTR_COMMON

-    rep_count = Get_QTR_CommonList_by_REP(reps, ent_date, 0, rm_id)

-    

-    treg.ent_date = ent_date

-    treg.total_BDGT = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.total_BDGT_NMG = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.sale_PLAN = 0 ' quarter.sale_plan

-    treg.total_SALE = 0 'summ of

-    ' hir = (amb40+st40)*pr40 + (amb20+st20)*pr20

-    'ter (amb_clx+stat_clx)*price

-    ' acs xxx

-    'price per rep

-    treg.total_HIR = 0 'patiens clxn

-    treg.total_TER = 0 'patiens clxn

-    treg.total_ACS = 0 'patiens clxn

-    treg.total_LPU = 0 'lpu

-    treg.total_BEDS = 0 'lpu.beds

-    treg.total_REP = 0 '

-    

-    If rep_count > 0 Then

-        Dim i As Integer

-        

-        For i = 1 To UBound(reps)

-            ' current rep is reps(i)

-            With reps(i)

-                treg.total_BDGT = treg.total_BDGT + .c_bdgt_NFG + .c_bdgt_NMG

-                treg.total_BDGT_NMG = treg.total_BDGT_NMG + .c_bdgt_NMG

-                treg.sale_PLAN = treg.sale_PLAN + .qtr.sale_PLAN

-                treg.total_SALE = treg.total_SALE + .c_sale_ALL

-                treg.total_HIR = treg.total_HIR + .c_pat_HIR

-                treg.total_TER = treg.total_TER + .c_pat_TER

-                treg.total_ACS = treg.total_ACS + .c_pat_CRD

-                treg.total_LPU = treg.total_LPU + .i_lcd

-                treg.total_BEDS = treg.total_BEDS + .c_beds

-                treg.total_REP = treg.total_REP + 1

-            End With

-            

-        Next i

-        

-    End If

-    

-    getREGION_by_QTR = treg.total_REP

-End Function

-

-<<<<<<
-======================
-mRM_QTR
->>>>>>
-Attribute VB_Name = "mRM_QTR"

-Option Explicit

-

-Sub btRM_QTR_Do_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    Dim i As Integer

-    Dim def_dir As String

-    Dim flist() As String

-    

-    idx = Worksheets(VAR_SHEET).Range("RM_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-'            def_dir = GetWBPath(ThisWorkbook.FullName)

-'            If GetImportDirectory(def_dir, flist) Then

-'                Dim db_list() As String

-'                i = GetDBList(flist, db_list)

-'                If i > 0 Then

-'                    ImportFromRegionalManagers db_list, GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-'                End If

-'            End If

-'            Worksheets(RM_QTR_SHEET).update_history

-        Case 2

-            Worksheets("REP_LIST").Range("ret_addr") = "RM_QTR"

-            Worksheets("REP_LIST").setEnt_date (Worksheets(RM_QTR_SHEET).getEnt_date())

-            Worksheets("REP_LIST").Range("RM_ID") = Worksheets(RM_QTR_SHEET).Range("RM_ID")

-            Worksheets("REP_LIST").Range("VIEW_ONLY") = True

-

-            Worksheets("REP_LIST").Select

-        Case 3

-            MsgBox "Функция не доступна", vbOKOnly, PROGRAM_NAME

-    End Select

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-End Sub

-

-Sub btRM_QTR_RET_IT()

-    Dim str As String

-    str = Range("ret_addr")

-    ThisWorkbook.Worksheets(str).Activate

-End Sub

-

-<<<<<<
-======================
-mImport
->>>>>>
-Attribute VB_Name = "mImport"

-    Option Explicit

-

-Const OFN_ALLOWMULTISELECT As Long = 512

-Const OFN_EXPLORER As Long = 524288

-Const OFN_HIDEREADONLY As Long = 4

-Const OFN_NONETWORKBUTTON As Long = 131072

-Const OFN_READONLY As Long = 1

-       

-Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _

-    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

-

-Private Type OPENFILENAME

-    lStructSize As Long

-    hWndOwner As Long

-    hInstance As Long

-    lpstrFilter As String

-    lpstrCustomFilter As String

-    nMaxCustFilter As Long

-    nFilterIndex As Long

-    lpstrFile As String

-    nMaxFile As Long

-    lpstrFileTitle As String

-    nMaxFileTitle As Long

-    lpstrInitialDir As String

-    lpstrTitle As String

-    flags As Long

-    nFileOffset As Integer

-    nFileExtension As Integer

-    lpstrDefExt As String

-    lCustData As Long

-    lpfnHook As Long

-    lpTemplateName As String

-End Type

-

-Function GetImportDirectory(DB_dir As String, flist() As String) As Boolean

-    Dim OpenFile As OPENFILENAME

-    Dim lReturn As Long

-    Dim sFilter As String

-    

-    OpenFile.lStructSize = Len(OpenFile)

-    '         OpenFile.hwndOwner = Form1.hWnd

-    '         OpenFile.hInstance = App.hInstance

-    sFilter = "Clexane Data Files" & Chr(0) & PROGRAM_IMPORTNAME & PROGRAM_DATAEXT & Chr(0)

-    OpenFile.lpstrFilter = sFilter

-    OpenFile.nFilterIndex = 1

-    OpenFile.lpstrFile = String(257, 0)

-    OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1

-    OpenFile.lpstrFileTitle = OpenFile.lpstrFile

-    OpenFile.nMaxFileTitle = OpenFile.nMaxFile

-    OpenFile.lpstrInitialDir = DB_dir

-    OpenFile.lpstrTitle = "Импорт данных"

-    OpenFile.flags = OFN_HIDEREADONLY + OFN_EXPLORER

-    lReturn = GetOpenFileName(OpenFile)

-    If lReturn = 0 Then

-        GetImportDirectory = False

-    Else

-        GetImportDirectory = True

- 

-        flist = Split(OpenFile.lpstrFile, Chr(0), Compare:=vbBinaryCompare)

-        Dim i As Integer

-        i = 0

-        Do While flist(i) <> ""

-            i = i + 1

-        Loop

-        If i = 1 Then

-            flist(1) = flist(0)

-            flist(0) = GetWBPath(flist(1))

-            flist(1) = GetWBName(flist(1))

-        Else

-            flist(0) = flist(0) & "\"

-        End If

-    End If

-End Function

-<<<<<<
-======================
-cPPReport
->>>>>>
-Attribute VB_Name = "cPPReport"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Const PPR_NON As Integer = 0

-Const PPR_NEW As Integer = 1

-Const PPR_OLD As Integer = 2

-

-Dim ReportApp As PowerPoint.Application

-Dim ReportDoc As PowerPoint.Presentation

-Dim ReportState As Integer

-Dim PowerPointPath As String

-

-Private Sub Class_Initialize()

-    Set ReportApp = CreateObject("PowerPoint.Application")

-    PowerPointPath = ReportApp.Path & "\PowerPNT.EXE"

-    ReportState = PPR_NON

-End Sub

-

-Sub OpenReport(FileName As String)

-    If ReportState <> PPR_NON Then

-        SaveReport

-    End If

-    Set ReportDoc = GetObject(FileName)

-    ReportState = PPR_OLD

-End Sub

-

-Sub CreateReport()

-    If ReportState <> PPR_NON Then

-        SaveReport

-    End If

-    Set ReportDoc = ReportApp.Presentations.Add

-    ReportState = PPR_NEW

-End Sub

-

-Sub SaveReport()

-    Select Case ReportState

-        Case PPR_NEW

-            ReportDoc.SaveAs GetWBPath(ThisWorkbook.FullName) + PROGRAM_FILENAME

-        Case PPR_OLD

-            ReportDoc.Save

-    End Select

-    ReportState = PPR_NON

-End Sub

-

-Sub ReportView()

-    Dim CmdName As String

-    CmdName = GetWBPath(ThisWorkbook.FullName) + PROGRAM_FILENAME + ".PPT"

-    CmdName = PowerPointPath & " " & CmdName

-    Shell CmdName, 1

-End Sub

-

-Sub InsertSlide()

-    Dim ReportPage As PowerPoint.Slide

-    Set ReportPage = ReportDoc.Slides.Add(ReportDoc.Slides.count + 1, ppLayoutBlank)

-    

-    ReportPage.Shapes.Paste

-    ReportPage.Shapes.AddLabel(msoTextOrientationHorizontal, 20, 20, 640, 40) _

-      .TextFrame.TextRange.Text = "Slide #" & Format(ReportDoc.Slides.count)

-End Sub

-

-

-Private Sub Class_Terminate()

-    SaveReport

-    ReportApp.Quit

-End Sub

-<<<<<<
-======================
-dlgImprtDB
->>>>>>
-Attribute VB_Name = "dlgImprtDB"

-Attribute VB_Base = "0{36355920-F7A4-44A8-96EF-5D79CF26137D}{F852BDF2-AB3E-468E-89DF-EC5DC0C7C88B}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Private Sub btSelAll_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = True

-    Next i

-End Sub

-

-Private Sub btUnselect_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = False

-    Next i

-End Sub

-<<<<<<
-======================
-rmImport
->>>>>>
-Attribute VB_Name = "rmImport"

-Option Explicit

-

-Public Type dbDESCRIPTION

-    Name As String

-    Fields() As String

-End Type

-

-Sub ImportFromRegionalManagers(rm_files() As String, fm_file As String)

-    Dim db(9) As dbDESCRIPTION

-    

-    '''''data

-    db(1).Name = "rep"

-    

-    db(2).Name = "lpu"

-    db(3).Name = "lpu_acs"

-    db(4).Name = "lpu_budget"

-    db(5).Name = "lpu_hir"

-    db(6).Name = "lpu_im"

-    db(7).Name = "lpu_ter"

-    db(8).Name = "quarter"

-    db(9).Name = "quarter_rm"

-    

-    ReDim db(1).Fields(5)

-    With db(1)

-        .Fields(1) = "rep_id"

-        .Fields(2) = "firstname"

-        .Fields(3) = "lastname"

-        .Fields(4) = "region"

-        .Fields(5) = "city"

-    End With

-    

-    ReDim db(2).Fields(5)

-    With db(2)

-        .Fields(1) = "id"

-        .Fields(2) = "rep_id"

-        .Fields(3) = "name"

-        .Fields(4) = "address"

-        .Fields(5) = "beds"

-    End With

-    

-    ReDim db(3).Fields(7)

-    With db(3)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "patients_with_geparins"

-        .Fields(5) = "patients_per_quarter"

-        .Fields(6) = "patients_stationar_nmg"

-        .Fields(7) = "patients_stationar_clexan"

-    End With

-    

-    ReDim db(4).Fields(6)

-    With db(4)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "bdgt_NMG"

-        .Fields(5) = "bdgt_NFG"

-        .Fields(6) = "sale_PLAN"

-    End With

-    

-    ReDim db(5).Fields(15)

-    With db(5)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "operations_per_quarter"

-        .Fields(5) = "risk_percent"

-        .Fields(6) = "patients_with_risk_ON"

-        .Fields(7) = "patients_ambulator"

-        .Fields(8) = "patients_ambulator_nmg"

-        .Fields(9) = "patients_ambulator_clexan"

-        .Fields(10) = "patients_ambulator_clexan_40mg"

-        .Fields(11) = "patients_ambulator_clexan_20mg"

-        .Fields(12) = "patients_stationar_nmg"

-        .Fields(13) = "patients_stationar_clexan"

-        .Fields(14) = "patients_stationar_clexan_40mg"

-        .Fields(15) = "patients_stationar_clexan_20mg"

-    End With

-    

-    

-    ReDim db(6).Fields(7)

-    With db(6)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "patients_with_geparins"

-        .Fields(5) = "patients_per_quarter"

-        .Fields(6) = "patients_stationar_nmg"

-        .Fields(7) = "patients_stationar_clexan"

-    End With

-    

-    ReDim db(7).Fields(11)

-    With db(7)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "patients_per_quarter"

-        .Fields(5) = "risk_percent"

-        .Fields(6) = "patients_with_risk_ON"

-        .Fields(7) = "patients_ambulator"

-        .Fields(8) = "patients_ambulator_nmg"

-        .Fields(9) = "patients_ambulator_clexan"

-        .Fields(10) = "patients_stationar_nmg"

-        .Fields(11) = "patients_stationar_clexan"

-    End With

-    

-    ReDim db(8).Fields(9)

-    With db(8)

-        .Fields(1) = "ID"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "rep_id"

-        .Fields(4) = "sale_plan"

-        .Fields(5) = "ClxnH20mg"

-        .Fields(6) = "ClxnH40mg"

-        .Fields(7) = "ClxnT40mg"

-        .Fields(8) = "ClxnC_IM"

-        .Fields(9) = "ClxnC_ACS"

-    End With

-    

-    ReDim db(9).Fields(3)

-    With db(9)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "sale_plan"

-    End With

-    

-    Dim rm_idx As Integer

-    Dim to_db As Object

-    'back uo

-    Merge_BackUp_All_Data

-    

-    'clean up

-    Merge_Clear_All_Data fm_file

-    

-    Set to_db = dbGetConnection(fm_file)

-    

-    For rm_idx = 1 To UBound(rm_files)

-        Dim from_db As Object

-        

-        Set from_db = dbGetConnection(rm_files(rm_idx))

-        

-        Dim new_rm_id As Long

-        new_rm_id = dbMergeRM(from_db, to_db)

-

-        Dim i As Integer

-

-        For i = 1 To UBound(db)

-            Dim get_sql As String

-            Dim getRS As Object

-            Dim insRS As Object

-            Dim field_idx As Integer

-                        

-            get_sql = "SELECT * FROM " & db(i).Name

-            Set getRS = CreateObject("ADODB.Recordset")

-            Set insRS = CreateObject("ADODB.Recordset")

-            insRS.Open db(i).Name, to_db, 2, 2

-

-            getRS.Open get_sql, from_db

-            

-            If Not getRS.BOF Then

-                Do While Not getRS.EOF

-                    insRS.addnew

-                    Dim fld_name As String

-                    

-                    For field_idx = 1 To UBound(db(i).Fields)

-                        fld_name = db(i).Fields(field_idx)

-                        insRS(fld_name) = getRS(fld_name)

-                    Next field_idx

-                    

-                    insRS("rm_id") = new_rm_id

-                    insRS.Update

-                    getRS.MoveNext

-                Loop

-            

-            Else

-                'empty table

-                ' do nothing

-            End If

-            

-            

-        Next i

-        

-        dbCloseOpenedConnection from_db

-    Next rm_idx

-    

-    dbCloseOpenedConnection to_db

-End Sub

-

-Function dbMergeRM(from_dbConnection As Object, to_dbConnection As Object) As Long

-

-    Dim getRecordset As Object

-    Dim getREPData_SQL As String

-    Dim REP_fn As String

-    Dim REP_ln As String

-    Dim REP_region As String

-    Dim REP_city As String

-

-

-    getREPData_SQL = "SELECT * FROM reg_man"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getREPData_SQL, from_dbConnection

-        

-        If Not getRecordset.BOF Then

-            REP_fn = getRecordset("firstname")

-            REP_ln = getRecordset("lastname")

-            REP_city = getRecordset("city")

-            REP_region = getRecordset("region")

-        Else

-            MsgBox "There is no information about Regional Manager! This database cannot be merged!!!"

-            dbMergeRM = -1

-            Exit Function

-        End If

-    

-    Dim insertRecordset As Object

-    Set insertRecordset = CreateObject("ADODB.Recordset")

-        

-    insertRecordset.Open "reg_man", to_dbConnection, 2, 2

-    insertRecordset.addnew

-        

-    insertRecordset("firstname") = REP_fn

-    insertRecordset("lastname") = REP_ln

-    insertRecordset("region") = REP_region

-    insertRecordset("city") = REP_city

-    insertRecordset.Update

-    insertRecordset.MoveLast

-    'new ID

-    dbMergeRM = insertRecordset("mgr_id")

-    

-End Function

-

-Sub cmDataImport()

-    Dim def_dir As String

-    Dim flist() As String

-    Dim i As Integer

-

-    def_dir = GetWBPath(ThisWorkbook.FullName)

-    If GetImportDirectory(def_dir, flist) Then

-        Dim ImpMask() As String

-        ImpMask = Split(flist(1), Chr(95), Compare:=vbBinaryCompare)

-        flist(1) = ImpMask(0) & "*"

-        Dim db_list() As String

-        i = GetDBList(flist(), db_list)

-        

-        If i > 0 Then

-            ImportFromRegionalManagers db_list, GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-        End If

-    End If

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).Select

-End Sub

-

-

-<<<<<<
-======================
-PRJ_QTR
->>>>>>
-Attribute VB_Name = "PRJ_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CPRJ_QT As Integer = 0

-Const CPRJ_ID As Integer = 1

-Const CPRJ_PLN As Integer = 2

-Const CPRJ_FCT As Integer = 3

-Const CPRJ_BDG As Integer = 4

-Const CPRJ_CNT As Integer = 5

-Const CPRJ_BEDS As Integer = 6

-Const CPRJ_HIR As Integer = 7

-Const CPRJ_TER As Integer = 8

-Const CPRJ_CRD As Integer = 9

-Const CPRJ_CLXN_BDG As Integer = 10

-Const CPRJ_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Const LOCAL_ENT_DATE As String = "B11"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("PRJ_QTR")

-        s = "Все регионы, " & .getEnt_date()

-    End With

-    

-    MakeChartTitle = s

-End Function

-

-Sub update_history()

-    Dim objQTR() As tREGION

-    Dim i As Long

-    Dim r As Range

-

-

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetRGN_COMM_DATA(objQTR(), 0)

-    

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CPRJ_QT) = objQTR(i).ent_date

-            r.Offset(i - 1, CPRJ_ID) = ""

-            r.Offset(i - 1, CPRJ_PLN) = objQTR(i).sale_PLAN

-            r.Offset(i - 1, CPRJ_FCT) = objQTR(i).total_SALE

-            r.Offset(i - 1, CPRJ_BDG) = objQTR(i).total_BDGT

-            r.Offset(i - 1, CPRJ_CNT) = objQTR(i).total_LPU

-            r.Offset(i - 1, CPRJ_BEDS) = objQTR(i).total_REP

-            r.Offset(i - 1, CPRJ_HIR) = objQTR(i).total_HIR

-            r.Offset(i - 1, CPRJ_TER) = objQTR(i).total_TER

-            r.Offset(i - 1, CPRJ_CRD) = objQTR(i).total_ACS

-            If objQTR(i).total_BDGT <> 0 Then

-                r.Offset(i - 1, CPRJ_CLXN_BDG) = objQTR(i).total_SALE / objQTR(i).total_BDGT

-            End If

-            If objQTR(i).total_BDGT_NMG <> 0 Then

-                r.Offset(i - 1, CPRJ_CLXN_NMG) = objQTR(i).total_SALE / objQTR(i).total_BDGT_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR_PRJ()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(PRJ_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CPRJ_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CPRJ_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CPRJ_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CPRJ_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CPRJ_CRD + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-

-Sub Draw_PLN_QTR_PRJ()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(PRJ_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CPRJ_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CPRJ_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CPRJ_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CPRJ_FCT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PLN_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Draw_BDGT_QTR_PRJ()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(PRJ_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CPRJ_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CPRJ_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CPRJ_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CPRJ_CLXN_NMG + 1)

-        End If

-    Next i

-    Worksheets("CHRT_BDGT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-Public Sub cbxPRJ_QtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR_PRJ

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR_PRJ

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR_PRJ

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = PRJ_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    Protect UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CPRJ_QT + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    If r = "" Then

-        Worksheets(VAR_SHEET).Range("PRJ_ACTION") = 2

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        Worksheets(VAR_SHEET).Range("PRJ_ACTION") = 2

-        Range("LAST_FOCUS") = currRange.address

-        With Worksheets("REP_LIST")

-            .Range("ret_addr") = "PRJ_QTR"

-            .Range("ent_date") = r

-            .Range("VIEW_ONLY") = True

-        End With

-    End If

-    Cancel = True

-    btPRJ_QTR_Do_IT ' old btRM_OTR_DO_IT

-End Sub

-

-<<<<<<
-======================
-RM_LIST
->>>>>>
-Attribute VB_Name = "RM_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Const LOCAL_ENT_DATE As String = "C10"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-

-Public Function getCurrentRM_ID() As Long

-    Dim r As Range

-

-    With Worksheets("RM_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CRM_ID)

-    End With

-

-    getCurrentRM_ID = r

-End Function

-

-Public Sub RM_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("PM_CHR_IDX")

-        Case 1

-            Rm_Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Rm_Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Rm_Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-

-        Case 4

-            Rm_Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectRM_QTR(rm_id As Long)

-    Dim vo As Boolean

-

-    Range("JUMP") = "RM_QTR"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("RM_QTR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "RM_LIST"

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Public Sub SelectREP_LIST(rm_id As Long)

-    Dim vo As Boolean

-

-    Range("JUMP") = "REP_LIST"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("REP_LIST")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "RM_LIST"

-        .setEnt_date (getEnt_date())

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateRMList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Sub UpdateRMList()

-    Dim rmcd() As tRMID_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-

-    ent_date = getEnt_date

-

-    i = Get_RM_CommonList_by_QTR(rmcd(), ent_date)

-

-    With ThisWorkbook.Worksheets("RM_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(rmcd)

-            r.Offset(i - 1, CRM_NAME) = GetRegionName(rmcd(i).rm.Region)

-            r.Offset(i - 1, CRM_ID) = rmcd(i).rm.rm_id

-            r.Offset(i - 1, CRM_BEDS) = rmcd(i).rgcd(1).total_BEDS

-            r.Offset(i - 1, CRM_BDGT) = rmcd(i).rgcd(1).total_BDGT

-            r.Offset(i - 1, CRM_NMG) = rmcd(i).rgcd(1).total_BDGT_NMG

-            r.Offset(i - 1, CRM_HIR) = rmcd(i).rgcd(1).total_HIR

-            r.Offset(i - 1, CRM_TER) = rmcd(i).rgcd(1).total_TER

-            r.Offset(i - 1, CRM_CAR) = rmcd(i).rgcd(1).total_ACS

-            r.Offset(i - 1, CRM_FACT) = rmcd(i).rgcd(1).total_SALE

-            r.Offset(i - 1, CRM_PLAN) = rmcd(i).rgcd(1).sale_PLAN

-            

-            With rmcd(i).rgcd(1)

-                r.Offset(i - 1, CRM_PAT_LPU) = .total_HIR + .total_TER + .total_ACS

-            End With

-            

-            r.Offset(i - 1, CRM_BDGT_1) = rmcd(i).rgcd(1).total_BDGT

-            If rmcd(i).rgcd(1).total_BDGT > 0 Then

-                r.Offset(i - 1, CRM_BDGT_1 + 1) = rmcd(i).rgcd(1).total_SALE / rmcd(i).rgcd(1).total_BDGT

-            End If

-            If r.Offset(i - 1, CRM_BDGT_1 + 1) > 1 Then

-                r.Offset(i - 1, CRM_BDGT_1 + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim rep_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CRM_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CRM_AREA).row, CRM_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    rep_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CRM_AREA).Column

-

-    If i < 4 Then

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 1

-    Else

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 2

-    End If

-

-    If rep_id = 0 Then

-        Range("LAST_FOCUS") = Range(CRM_AREA).address

-    End If

-

-    If rep_id = 0 Then

-        i = CRM_NAME

-        Range("JUMP") = ""

-    Else

-        btRM_LIST_DO_IT

-    End If

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-<<<<<<
-======================
-mPRJ_QTR
->>>>>>
-Attribute VB_Name = "mPRJ_QTR"

-Sub btPRJ_QTR_Do_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    

-    idx = Worksheets(VAR_SHEET).Range("PRJ_ACTION")

-    ent_date = Worksheets(PRJ_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            cmDataImport

-        Case 2

-            Worksheets("RM_LIST").setEnt_date (Worksheets("PRJ_QTR").getEnt_date())

-            Worksheets("RM_LIST").Range("ret_addr") = "PRJ_QTR"

-            Worksheets("RM_LIST").Select

-        Case 3

-            cmNewReport

-    End Select

-    Worksheets(VAR_SHEET).Range("PRJ_ACTION") = 2

-End Sub

-

-

-<<<<<<
-======================
-mRM_LIST
->>>>>>
-Attribute VB_Name = "mRM_LIST"

-Option Explicit

-

-Public Const CRM_AREA As String = "B12"

-Public Const CRM_NAME As Integer = 0

-Public Const CRM_NAME1 As Integer = 1

-Public Const CRM_NAME2 As Integer = 2

-Public Const CRM_ID As Integer = 3

-Public Const CRM_BEDS As Integer = 4

-Public Const CRM_BDGT As Integer = 5

-Public Const CRM_NMG As Integer = 6

-Public Const CRM_HIR As Integer = 7

-Public Const CRM_TER As Integer = 8

-Public Const CRM_CAR As Integer = 9

-Public Const CRM_FACT As Integer = 10

-Public Const CRM_PLAN As Integer = 11

-Public Const CRM_PAT_LPU As Integer = 16

-Public Const CRM_BDGT_1 As Integer = 17

-

-

-Const LOCAL_ENT_DATE As String = "C10"

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Sub EditREP(CRM As tREPID, ent_date As String)

-    NoFunc

-End Sub

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("RM_LIST")

-        s = "Регионы, " & .getEnt_date()

-    End With

-    

-    MakeChartTitle = s

-End Function

-

-Sub Rm_Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_LPU_BBL").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rm_Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRM_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRM_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRM_FACT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PIE").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rm_Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CRM_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRM_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRM_HIR + 1)

-            psum = psum + src.Cells(i, CRM_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRM_TER + 1)

-            psum = psum + src.Cells(i, CRM_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRM_CAR + 1)

-            psum = psum + src.Cells(i, CRM_CAR + 1)

-            dst.Cells(i, 5) = psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU").Range("title") = MakeChartTitle

-    

-End Sub

-

-Sub Rm_Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CRM_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRM_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRM_HIR + 1)

-            psum = psum + src.Cells(i, CRM_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRM_TER + 1)

-            psum = psum + src.Cells(i, CRM_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRM_CAR + 1)

-            psum = psum + src.Cells(i, CRM_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CRM_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU_A").Range("title") = MakeChartTitle

-    

-End Sub

-

-Sub btRM_LIST_RET_IT()

-    With Worksheets("RM_LIST")

-        .setEnt_date ("")

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = "PRJ_QTR"

-    End With

-    ThisWorkbook.Worksheets("PRJ_QTR").Activate

-End Sub

-

-

-Sub btRM_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim rm_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("RM_LIST_ACTION")

-    With Worksheets("RM_LIST")

-        rm_id = .getCurrentRM_ID()

-        

-        Select Case i

-            Case 1:

-                .SelectRM_QTR rm_id

-            Case 2:

-                .SelectREP_LIST rm_id

-            End Select

-    End With

-    

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-

-

-

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mImport2
->>>>>>
-Attribute VB_Name = "mImport2"

-Option Explicit

-

-Sub FOpen()

-    Dim flist As String

-    Dim fileToOpen, s

-    flist = ""

-    fileToOpen = Application _

-        .GetOpenFileName("Data Files (*.mdb), mr*.mdb", Title:="Импорт данных", MultiSelect:=True)

-    If fileToOpen <> False Then

-        For Each s In fileToOpen

-            flist = flist & s & "; "

-        Next s

-        MsgBox "Open " & flist

-    End If

-End Sub

-

-Sub t2()

-Dim d As ImprtDB

-Set d = New ImprtDB

-d.Show

-

-End Sub

-

-<<<<<<
-======================
-ImprtDB
->>>>>>
-Attribute VB_Name = "ImprtDB"

-Attribute VB_Base = "0{67FA6A28-8370-4981-8F01-1A9079245761}{ECFCB43F-B241-4CD9-9CB3-2A981933173D}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btSelAll_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = True

-    Next i

-End Sub

-

-Private Sub btUnselect_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = False

-    Next i

-End Sub

-<<<<<<
-======================
-mImport
->>>>>>
-Attribute VB_Name = "mImport"

-    Option Explicit

-

-Const OFN_ALLOWMULTISELECT As Long = 512

-Const OFN_EXPLORER As Long = 524288

-Const OFN_HIDEREADONLY As Long = 4

-Const OFN_NONETWORKBUTTON As Long = 131072

-Const OFN_READONLY As Long = 1

-       

-Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _

-  "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

-

-Private Type OPENFILENAME

-  lStructSize As Long

-  hWndOwner As Long

-  hInstance As Long

-  lpstrFilter As String

-  lpstrCustomFilter As String

-  nMaxCustFilter As Long

-  nFilterIndex As Long

-  lpstrFile As String

-  nMaxFile As Long

-  lpstrFileTitle As String

-  nMaxFileTitle As Long

-  lpstrInitialDir As String

-  lpstrTitle As String

-  flags As Long

-  nFileOffset As Integer

-  nFileExtension As Integer

-  lpstrDefExt As String

-  lCustData As Long

-  lpfnHook As Long

-  lpTemplateName As String

-End Type

-

-Private Sub Command1_Click()

-  Dim OpenFile As OPENFILENAME

-  Dim lReturn As Long

-  Dim sFilter As String

-  OpenFile.lStructSize = Len(OpenFile)

-'         OpenFile.hwndOwner = Form1.hWnd

-'         OpenFile.hInstance = App.hInstance

-  sFilter = "Clexane Data Files" & Chr(0) & "mr*.mdb" & Chr(0)

-  OpenFile.lpstrFilter = sFilter

-  OpenFile.nFilterIndex = 1

-  OpenFile.lpstrFile = String(257, 0)

-  OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1

-  OpenFile.lpstrFileTitle = OpenFile.lpstrFile

-  OpenFile.nMaxFileTitle = OpenFile.nMaxFile

-' OpenFile.lpstrInitialDir = "C:\"

-  OpenFile.lpstrTitle = "Импорт данных"

-  OpenFile.flags = OFN_HIDEREADONLY + OFN_ALLOWMULTISELECT + OFN_EXPLORER

-  lReturn = GetOpenFileName(OpenFile)

-  If lReturn = 0 Then

-     MsgBox "The User pressed the Cancel Button"

-  Else

-     MsgBox "The user Chose " & Trim(OpenFile.lpstrFile)

-  End If

-End Sub

-

-<<<<<<
-Project Name : 'ClexaneRM'
-Quirk - duff tag length======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    ThisWorkbook.Worksheets(RM_QTR_SHEET).ClearRMName

-    

-    Application.EnableEvents = True

-    Set MyAppEvents.app = Application

-    

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    

-    MyAppEvents.CheckWorkBooksArround ThisWorkbook

-    

-    cmSetStandaloneMode

-    

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-    

-    Application.ScreenUpdating = True

-    

-    If CheckUser Then

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).update_history

-        Application.Calculate

-    End If

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    

-    Dim RestMode As Boolean

-    RestMode = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE")

-    

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-'        If RestMode Then

-            ThisWorkbook.Saved = True

-'        Else

-'            ThisWorkbook.Save

-'        End If

-    End If

-    Application.Caption = Empty

-    Application.CommandBars(STDBAR_NAME).Reset

-    If RestMode Then

-        xlRestoreView

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    End If

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-    Dim MaxX, MaxY As Integer

-    With ThisWorkbook.Worksheets(TITLE_SHEET)

-        MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-        MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-    End With

-

-    With ThisWorkbook.Application

-        .ScreenUpdating = False

-        .WindowState = xlNormal

-        .Height = MaxY

-        .Width = MaxX

-    End With

-End Sub

-

-

-

-

-

-<<<<<<
-======================
-REP_QTR
->>>>>>
-Attribute VB_Name = "REP_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CQTR_QT As Integer = 0

-Const CQTR_ID As Integer = 1

-Const CQTR_PLN As Integer = 2

-Const CQTR_FCT As Integer = 3

-Const CQTR_BDG As Integer = 4

-Const CQTR_CNT As Integer = 5

-Const CQTR_BEDS As Integer = 6

-Const CQTR_HIR As Integer = 7

-Const CQTR_TER As Integer = 8

-Const CQTR_CRD As Integer = 9

-Const CQTR_CLXN_BDG As Integer = 10

-Const CQTR_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub update_history()

-    Dim objQTR() As tQTR

-    Dim i As Long

-    Dim r As Range

-    Dim cRep As tREPID

-

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    Range("D4") = cRep.LastName

-    Range("D5") = cRep.FirstName

-

-    Range("H4") = GetRegionName(cRep.Region)

-    Range("H5") = GetCityName(cRep.Region, cRep.City)

-

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetAll_QTR_Records_by_REP(objQTR, "%", cRep.rep_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CQTR_QT) = objQTR(i).entry_date

-        Next i

-    End If

-    Dim qcd() As tQTR_COMMON

-    i = Get_QTR_CommonList_by_REP(qcd, "%", cRep.rep_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(qcd)

-            r.Offset(i - 1, CQTR_QT) = qcd(i).qtr.entry_date

-            r.Offset(i - 1, CQTR_ID) = qcd(i).qtr.id

-            r.Offset(i - 1, CQTR_PLN) = qcd(i).qtr.sale_PLAN

-            r.Offset(i - 1, CQTR_FCT) = qcd(i).c_sale_ALL

-            r.Offset(i - 1, CQTR_BDG) = qcd(i).c_bdgt_LPU

-            r.Offset(i - 1, CQTR_CNT) = qcd(i).i_lcd

-            r.Offset(i - 1, CQTR_BEDS) = qcd(i).c_beds

-            r.Offset(i - 1, CQTR_HIR) = qcd(i).c_pat_HIR

-            r.Offset(i - 1, CQTR_TER) = qcd(i).c_pat_TER

-            r.Offset(i - 1, CQTR_CRD) = qcd(i).c_pat_CRD

-            If qcd(i).c_bdgt_LPU <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_BDG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_LPU

-            End If

-            If qcd(i).c_bdgt_NMG <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_NMG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CQTR_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRepQtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect UserInterfaceOnly:=True

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CQTR_ID + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    i = currRange.Column - Range(CINP_AREA).Column

-

-    QTR_ID = r

-

-    If QTR_ID = 0 Then

-        Worksheets(VAR_SHEET).Range("USER_ACTION") = 1

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        If i > CQTR_FCT Then

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-            Range("LAST_FOCUS") = currRange.address

-        Else

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 3

-            Range("LAST_FOCUS") = currRange.address

-        End If

-    End If

-    Cancel = True

-    btHomeDo_IT

-End Sub

-

-<<<<<<
-======================
-mRep_QTR
->>>>>>
-Attribute VB_Name = "mRep_QTR"

-Option Explicit

-

-Sub NoFunc()

-    MsgBox "Функция не доступна", vbOKOnly, PROGRAM_NAME

-End Sub

-

-Sub DO_Price_qtr(ent_date As String)

-    Dim qtr As tQTR

-    Dim res As Integer

-    Dim cRep As tREPID

-

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    qtr = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-

-    If qtr.id = 0 Then

-        qtr.entry_date = ent_date

-

-        With Worksheets(VAR_SHEET)

-            qtr.ClxnH20mg = .Range("ClxnH20mg")

-            qtr.ClxnH40mg = .Range("ClxnH40mg")

-            qtr.ClxnT40mg = .Range("ClxnT40mg")

-            qtr.ClxnC_ACS = .Range("ClxnC_ACS")

-            qtr.ClxnC_IM = .Range("ClxnC_IM")

-        End With

-    End If

-

-    Dim dlg_nq As dlg_nextQTR

-    Set dlg_nq = New dlg_nextQTR

-

-    With dlg_nq

-        .tb_qtr_name = qtr.entry_date

-        .tb_bdgt_avts = qtr.sale_PLAN

-        .tb_qtr_name = qtr.entry_date

-        .tb_ClxnH20mg = qtr.ClxnH20mg

-        .tb_ClxnH40mg = qtr.ClxnH40mg

-        .tb_ClxnT40mg = qtr.ClxnT40mg

-        .tb_ClxnC_ACS = qtr.ClxnC_ACS

-        .tb_ClxnC_IM = qtr.ClxnC_IM

-    End With

-

-    dlg_nq.Show

-End Sub

-

-Sub DO_Edit_qtr(ent_date As String)

-    If ent_date = "" Then

-        NoFunc

-    Else

-        Dim rep_id As Long

-        rep_id = Worksheets(REP_QTR_SHEET).Range("REP_ID")

-        With ThisWorkbook.Worksheets("LPU_LIST")

-            .Range("VIEW_ONLY") = True

-            .Range("ent_date") = ent_date

-            .Range("REP_ID") = rep_id

-            .Select

-        End With

-    End If

-End Sub

-

-Sub DO_Delete_qtr(ent_date As String)

-    If ent_date <> "" Then

-        MsgBox "Удалить данные за период [" & ent_date & "] нельзя ", vbOKOnly, PROGRAM_NAME

-    End If

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-

-Sub btHomeDo_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    idx = Worksheets(VAR_SHEET).Range("USER_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            NoFunc

-            ' Обновляем экран

-        Case 2

-            DO_Edit_qtr ent_date

-        Case 3

-            DO_Price_qtr ent_date

-        Case 4

-            NoFunc

-    End Select

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-Sub Delete_qtr()

-'    Dim ent_date As String

-'    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-'    DO_Delete_qtr ent_date

-End Sub

-

-Sub btREP_QTR_RET_IT()

-    Dim s As String

-    With Worksheets("REP_QTR")

-        .Range("LAST_FOCUS") = ""

-        s = .Range("ret_addr")

-        .Range("ret_addr") = ""

-    End With

-    If s <> "" Then

-        ThisWorkbook.Worksheets(s).Select

-    Else

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane[RM]"

-Public Const PROGRAM_VERSION As String = "version 1.3"

-Public Const PROGRAM_FILENAME As String = "clexane-rm"

-Public Const PROGRAM_BACKUPNAME As String = "rm-backup-"

-Public Const PROGRAM_EXPORTNAME As String = "rm-ex-"

-Public Const PROGRAM_IMPORTNAME As String = "mr-ex-*"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20030329

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "O40"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-Public Const RM_QTR_SHEET As String = "RM_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-

-End Sub

-

-Function Double2Str(ByVal d As Double, ByVal precision As Integer, Optional Delim As String = ".") As String

-    Dim s As String

-    If Not precision > 0 Then

-        s = Round(d)

-    Else

-        Dim i As Integer

-        i = Fix(d)

-        s = i & Delim

-        d = Abs(d - i)

-        Do

-            precision = precision - 1

-            d = d * 10

-            If precision > 0 Then

-                i = Fix(d)

-            Else

-                i = Round(d)

-            End If

-            If i < 1 Then

-                s = s & "0"

-            Else

-                s = s & i

-                d = d - i

-            End If

-        Loop While precision > 0

-    End If

-    Double2Str = s

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetWBName(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBName = Right(FullName, s_len - pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.name = VAR_SHEET Or sh.name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-<<<<<<
-======================
-Var
->>>>>>
-Attribute VB_Name = "Var"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-title
->>>>>>
-Attribute VB_Name = "title"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LPU_LIST
->>>>>>
-Attribute VB_Name = "LPU_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentLPU_ID() As Long

-    Dim r As Range

-

-    With Worksheets("LPU_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CLPU_ID)

-    End With

-

-    getCurrentLPU_ID = r

-End Function

-

-Public Sub LPU_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectLPU_NAME(lpu_id As Long, ent_date As String)

-    If Range("VIEW_ONLY") = True Then

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    Dim cLPU As tLPU

-    If lpu_id = 0 Then

-        cLPU.id = 0

-        cLPU.rep_id = 0

-        cLPU.address = ""

-        cLPU.name = ""

-    Else

-        cLPU = Get_LPU_Record(lpu_id)

-    End If

-    EditLPU cLPU, getEnt_date

-    Worksheet_Activate

-End Sub

-

-Sub SelectLPU_BDGT(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    vo = Range("VIEW_ONLY")

-    If lpu_id = 0 Then

-        SelectLPU_NAME lpu_id, ent_date

-    Else

-        With ThisWorkbook.Worksheets("LPU_BDGT")

-            .Range("VIEW_ONLY") = vo

-            .Range("ret_addr") = "LPU_LIST"

-            .Range("REP_ID") = r_id

-            .Range("ent_date") = ent_date

-            .Range("lpu_id") = lpu_id

-        End With

-    End If

-End Sub

-

-Sub SelectLPU_HIR(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_HIR")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Sub SelectLPU_TER(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_TER")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Sub SelectLPU_C_ACS(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_C_ACS")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect UserInterfaceOnly:=True

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateLPUList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim lpu_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CINP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CINP_AREA).row, CLPU_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    lpu_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CINP_AREA).Column

-

-    If lpu_id = 0 Then

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    End If

-

-    If lpu_id = 0 Then

-        i = CLPU_NAME

-        Range("JUMP") = ""

-    End If

-    Select Case i

-        Case CLPU_NAME, CLPU_NAME1, CLPU_NAME2, CLPU_BEDS

-            SelectLPU_NAME lpu_id, ent_date

-            Range("JUMP") = ""

-

-        Case CLPU_NMG, CLPU_NFG, CLPU_PLAN, CLPU_FACT

-            SelectLPU_BDGT lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-

-        Case CLPU_HIR

-            SelectLPU_HIR lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_HIR"

-

-        Case CLPU_TER

-            SelectLPU_TER lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_TER"

-

-        Case CLPU_CAR

-            SelectLPU_C_ACS lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        Case Else

-            Range("JUMP") = ""

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateLPUList()

-    Dim lcd() As tLPU_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-    Dim objQTR As tQTR

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    ent_date = getEnt_date

-

-'     ent_date = "%" ' % - all records

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-    i = Get_LPU_CommonQTR(lcd, objQTR)

-

-'     стираем ФИО

-    Range("C3:C4").ClearContents

-

-    Range("C3") = cRep.LastName

-    Range("C4") = cRep.FirstName

-    Range("G3") = GetRegionName(cRep.Region)

-    Range("G4") = GetCityName(cRep.Region, cRep.City)

-    Range("G5") = objQTR.sale_PLAN

-

-

-

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(lcd)

-            r.Offset(i - 1, CLPU_NAME) = lcd(i).lpu.name

-            r.Offset(i - 1, CLPU_ID) = lcd(i).lpu.id

-            r.Offset(i - 1, CLPU_BEDS) = lcd(i).lpu.beds

-

-

-            r.Offset(i - 1, CLPU_NFG) = lcd(i).bdgt.bdgt_NFG

-            r.Offset(i - 1, CLPU_NMG) = lcd(i).bdgt.bdgt_NMG

-            r.Offset(i - 1, CLPU_PLAN) = lcd(i).bdgt.sale_PLAN

-

-            r.Offset(i - 1, CLPU_HIR) = lcd(i).pat_HIR

-            r.Offset(i - 1, CLPU_TER) = lcd(i).pat_TER

-            r.Offset(i - 1, CLPU_CAR) = lcd(i).pat_CRD

-            r.Offset(i - 1, CLPU_FACT) = lcd(i).sale_ALL

-            r.Offset(i - 1, CLPU_PAT_LPU) = lcd(i).pat_LPU

-            r.Offset(i - 1, CLPU_BDGT) = lcd(i).bdgt_LPU

-            If lcd(i).bdgt_LPU > 0 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = lcd(i).sale_ALL / lcd(i).bdgt_LPU

-            End If

-            If r.Offset(i - 1, CLPU_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{F2A5159C-AEB6-4066-B85F-339184DAFECD}{712D78F6-CCB6-499E-9674-B992A7482317}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-dbACS
->>>>>>
-Attribute VB_Name = "dbACS"

-Option Explicit

-

-Public Type tACS

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    patients_with_geparins As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objACS.ID <> 0 then updatre else insert

-Sub Insert_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objACS.id <> 0 Then

-        dbUpdate_ACS_Record dbConnection, objACS

-    Else

-        dbInsert_ACS_Record dbConnection, objACS

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_ACS_RecordsByLPU_ID(ByRef all_ACS_() As tACS, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_ACS_RecordsByLPU_ID = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, all_ACS_, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_ACS_Record dbConnection, objACS

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub dbInsert_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_acs", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objACS

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("patients_with_geparins") = .patients_with_geparins

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objACS.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim Update_SQL As String

-    

-    With objACS

-        Update_SQL = "UPDATE lpu_acs SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "patients_with_geparins=" & .patients_with_geparins & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_ACS_RecordsbyLPU_ID(dbConnection As Object, all_ACS() As tACS, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_ACS_SQL As String

-    Dim getAll_ACS_SQL As String

-    Dim ACS_Count As Long

-    ACS_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_ACS_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        ACS_Count = dbRecordset("ACS_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_ACS_RecordsbyLPU_ID = ACS_Count

-    

-    If ACS_Count > 0 Then

-        'we have records

-        ReDim all_ACS(1 To ACS_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_ACS_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_ACS As tACS

-                 With tmp_ACS

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .patients_with_geparins = dbRecordset("patients_with_geparins")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 all_ACS(index) = tmp_ACS

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE ID=" & objACS.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_ACS_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_HIR
->>>>>>
-Attribute VB_Name = "LPU_CLSN_HIR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-

-        Dim objHir As tHIRURGIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objHir

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .operations_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L9")

-                .patients_ambulator_clexan_20mg = Range("L10")

-                .patients_ambulator_clexan_40mg = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L19")

-                .patients_stationar_clexan_20mg = Range("L20")

-                .patients_stationar_clexan_40mg = Range("L21")

-            End With

-            Insert_Hir_Record objHir

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objHir.id = Range("rec_id")

-                    If objHir.id <> 0 Then

-                        Delete_Hir_Record objHir

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objHir As tHIRURGIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    With objHir

-        Range("rec_id") = .id

-        Range("F6") = .operations_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L9") = .patients_ambulator_clexan

-        Range("L10") = .patients_ambulator_clexan_20mg

-        Range("I21") = .patients_stationar_nmg

-        Range("L19") = .patients_stationar_clexan

-        Range("L20") = .patients_stationar_clexan_20mg

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id)

-

-        formula = "=" & qtr.ClxnH20mg & "*($L$10+$L$20)+" & qtr.ClxnH40mg & "*($L$11+$L$21)"

-        Range("F11").formula = formula

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objHir() As tHIRURGIA

-        Dim i As Integer

-        i = GetAll_Hir_RecordsByLPU_ID(objHir, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.3

-        Else

-            SetupData objHir(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-mSapes
->>>>>>
-Attribute VB_Name = "mSapes"

-Option Explicit

-

-Const SHAPE_COLOR As Integer = 1

-Const SHAPE_NAME As Integer = 2

-

-

-Sub ShapeView(r_sh_finite_state As Range)

-    Dim chk As Range

-    Dim s As String

-    Dim c, idx As Integer

-    For Each chk In r_sh_finite_state

-        idx = 0

-        If chk = "+" Then

-            c = chk.Offset(0, idx + SHAPE_COLOR)

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While c <> 0

-                ShapeFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s)), c

-                idx = idx + 2

-                c = chk.Offset(0, idx + SHAPE_COLOR)

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        Else

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While s <> ""

-                ShapeUnFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s))

-                idx = idx + 2

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        End If

-    Next chk

-End Sub

-

-Sub ShapeFill(sh As ShapeRange, ByVal color As Integer)

-    sh.Fill.Visible = msoTrue

-    sh.Fill.Solid

-    sh.Fill.ForeColor.SchemeColor = color

-    sh.Fill.Transparency = 0#

-End Sub

-

-Sub ShapeUnFill(sh As ShapeRange)

-    sh.Fill.Visible = msoFalse

-    sh.Fill.Transparency = 0#

-End Sub

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Public Const INPUT_NO = 0

-Public Const INPUT_NUMBER = 1

-Public Const INPUT_PERCENT = 2

-Public Const INPUT_STRING = 3

-Public Const INPUT_CHECK = 4

-

-Public Const INP_IDX_TYPE = 1

-Public Const INP_IDX_NEXT = 2

-Public Const INP_IDX_MIN = 3

-Public Const INP_IDX_MAX = 4

-Public Const INP_IDX_DEP = 5

-Public Const INP_IDX_ALT = 7

-

-

-Public Type tInputSet

-    vType As Integer

-    vMin As Long

-    vMax As Long

-    rChk As String

-End Type

-

-Function is_input_cell(ByVal Target As Range, inputs As Range) As tInputSet

-    Dim t As Range

-    Dim iset As tInputSet

-    Dim test As Range

-    iset.vType = INPUT_NO

-    iset.vMin = 0

-    iset.vMax = 0

-    iset.rChk = ""

-    is_input_cell = iset

-

-' Закоментировать следующую сточку для работы

-'  Exit Function

-

-    Set test = Target.Cells(1, 1)

-    For Each t In inputs

-        If Range(t).Column = test.Column And Range(t).row = test.row Then

-            iset.vType = t.Offset(0, INP_IDX_TYPE).Value

-            Select Case iset.vType

-                Case INPUT_CHECK

-                    iset.rChk = t.Offset(0, INP_IDX_ALT)

-                Case INPUT_NUMBER, INPUT_PERCENT

-                    iset.vMin = t.Offset(0, INP_IDX_MIN).Value

-                    iset.vMax = t.Offset(0, INP_IDX_MAX).Value

-            End Select

-            is_input_cell = iset

-            Exit Function

-        End If

-    Next t

-End Function

-

-Function GetFocusAddress(ByVal r As Range, f_next As Range) As String

-    Dim chk, t As Range

-    

-    For Each chk In f_next

-        For Each t In r

-            If t.address = chk Then

-                GetFocusAddress = chk

-                Exit Function

-            End If

-            If Range(chk).Column = t.Column - 1 And Range(chk).row = t.row _

-            Or Range(chk).Column = t.Column And Range(chk).row = t.row - 1 _

-            Then

-                If Range(chk) <> "" Then

-                    If Range(chk) = 0 Then

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_ALT)).address

-                    Else

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_NEXT)).address

-                    End If

-                Else

-                    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-                End If

-                Exit Function

-            End If

-        Next t

-    Next chk

-    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-End Function

-

-Sub SetDependet(r As Range, inputs As Range)

-    Dim chk As Range

-    Dim s, serr As String

-    Dim idx As Integer

-    Dim iset As tInputSet

-    Dim err_found As Boolean

-    

-    If r.count > 1 Then

-        Exit Sub

-    End If

-    

-    err_found = False

-    For Each chk In inputs

-        idx = INP_IDX_DEP

-        

-        

-        iset.vType = chk.Offset(0, INP_IDX_TYPE).Value

-        Select Case iset.vType

-            Case INPUT_NUMBER, INPUT_PERCENT

-                iset.vMin = chk.Offset(0, INP_IDX_MIN).Value

-                iset.vMax = chk.Offset(0, INP_IDX_MAX).Value

-                

-                If Range(chk) > iset.vMax Then

-                    err_found = True

-                    Range(chk) = iset.vMax

-                    serr = "Выход за дозволенный диапазон [" & iset.vMin & ".." & iset.vMax & "]! Данные скорректированы."

-                End If

-                

-                If Range(chk) = "" Then

-                    s = chk.Offset(0, idx)

-                    Do While s <> ""

-                        Range(s) = ""

-                        idx = idx + 1

-                        s = chk.Offset(0, idx)

-                    Loop

-                End If

-        End Select

-    Next chk

-    If err_found Then

-        MsgBox serr, vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Function CheckInputData(inputs As Range) As Boolean

-    Dim r As Range

-    

-    CheckInputData = True

-    For Each r In inputs

-        If Range(r) = "" Then

-            CheckInputData = False

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100.", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Sub Check_Int_Number(Target As Range, Def_Val As Long)

-    Dim err As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    err = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                err = True

-            End If

-        End If

-    Next r

-    If err Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_TER
->>>>>>
-Attribute VB_Name = "LPU_CLSN_TER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim objTer As tTERAPIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objTer

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .patients_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L20")

-            End With

-            Insert_Ter_Record objTer

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objTer.id = Range("rec_id")

-                    If objTer.id <> 0 Then

-                        Delete_Ter_Record objTer

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objTer As tTERAPIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    With objTer

-        Range("rec_id") = .id

-        Range("F6") = .patients_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L11") = .patients_ambulator_clexan

-        Range("I21") = .patients_stationar_nmg

-        Range("L20") = .patients_stationar_clexan

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id)

-        formula = "=" & qtr.ClxnT40mg & "*($L$12+$L$20)"

-        Range("F11").formula = formula

-

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objTer() As tTERAPIA

-        Dim i As Integer

-        i = GetAll_Ter_RecordsByLPU_ID(objTer, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.25

-        Else

-            SetupData objTer(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{5D2CB2D2-3E5E-4B6E-9E0C-2EEBA5E10E17}{C891C133-B6B4-43D3-B411-B4A821905C23}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-LPU_BDGT
->>>>>>
-Attribute VB_Name = "LPU_BDGT"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub SetDefFocus()

-    Range(Range("DEF_FOCUS")).Select

-End Sub

-

-Public Sub ClearData()

-    ClearSheetData

-End Sub

-

-Sub ClearSheetData()

-    If Range("F10") = 0 And Range("F13") = 0 Then

-        Range("F11:F18") = ""

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("F11:F13") = ""

-    End If

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim bdgt As tBUDGET

-        Dim test As Boolean

-        Dim sum As Long

-        With bdgt

-            .lpu_id = Range("lpu_id")

-            .id = Range("rec_id")

-            .entry_date = Range("ent_date")

-            .bdgt_NMG = Round(Range("F11").Value, 0)

-            .bdgt_NFG = Round(Range("F12").Value, 0)

-            .sale_PLAN = Round(Range("F13").Value, 0)

-

-            sum = .bdgt_NFG + .bdgt_NMG - .sale_PLAN

-            test = .bdgt_NFG <> 0 Or .bdgt_NMG <> 0 Or .sale_PLAN <> 0

-        End With

-        If test Then

-            If sum < 0 Then

-                MsgBox _

-                    "Ваш план превышает выделенный на гепарины бюджет. Сохранить данные?", _

-                    vbOKOnly, PROGRAM_NAME

-            End If

-            If test Then

-                Insert_BDGT_Record bdgt

-            End If

-        Else

-            If bdgt.id <> 0 Then

-                If vbYes = MsgBox("Удалить данные из базы!", vbYesNo, PROGRAM_NAME) Then

-                    Delete_BDGT_Record bdgt

-                End If

-                ret_back Range("DEF_FOCUS").Worksheet

-                Exit Sub

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-    End If

-

-   ClearData

-   ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(cLPU As tLPU_COMMON)

-    Dim t_sum As Long

-    t_sum = 0

-' Setup budget data

-    Range("F11") = cLPU.bdgt.bdgt_NMG

-    Range("F12") = cLPU.bdgt.bdgt_NFG

-    Range("F13") = cLPU.bdgt.sale_PLAN

-

-    With cLPU

-        Range("F14") = .pat_ALL

-        Range("F15") = .pat_HIR

-        Range("F16") = .pat_TER

-        Range("F17") = .pat_CRD

-        Range("F18") = .sale_ALL

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-    ws_activate

-End Sub

-

-

-Sub ws_activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Dim cLPU As tLPU_COMMON

-    Dim objQTR As tQTR

-    Dim objLPU As tLPU

-    Dim ent_date As String

-    Dim id As Long

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    id = Range("lpu_id").Value

-    ent_date = Range("ent_date")

-    

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-

-    objLPU = Get_LPU_Record(id)

-    Get_LPU_Common cLPU, objLPU, objQTR

-

-    If cLPU.lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = cLPU.lpu.beds

-        Range("lpu_name") = cLPU.lpu.name

-        Range("lpu_addr") = cLPU.lpu.address

-        Range("rec_id") = cLPU.bdgt.id

-

-        SetupData cLPU

-

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-'    MsgBox Target.address

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case INPUT_CHECK

-

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{BB60E38F-A4AB-4AB4-91D0-40AA798D9F5C}{BE9A54D9-F093-4755-9E17-0B47BB5E2546}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mSheets
->>>>>>
-Attribute VB_Name = "mSheets"

-Option Explicit

-

-Function am_load_now() As Boolean

-    am_load_now = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE")

-End Function

-

-Sub Wks_select(RetSheet As String)

-    Dim sheet As Worksheet

-    For Each sheet In ThisWorkbook.Worksheets

-        If sheet.name = RetSheet Then

-            ThisWorkbook.Worksheets(RetSheet).Select

-            Exit Sub

-        End If

-    Next sheet

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub ret_back(sh As Worksheet)

-    Dim RetSheet As String

-    RetSheet = sh.Range("ret_addr")

-    sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    sh.Range("ret_addr") = ""

-    sh.Range("rec_id") = ""

-    sh.Range("lpu_id") = ""

-    sh.Range("ent_date") = ""

-    sh.Range("lpu_name") = ""

-    sh.Range("lpu_addr") = ""

-    sh.Range("lpu_beds") = ""

-    Wks_select RetSheet

-End Sub

-

-Sub ClearSheetData(r_start As Range)

-    If r_start <> "" Then

-        r_start.Worksheet.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        r_start = ""

-    Else

-        ret_back r_start.Worksheet

-    End If

-End Sub

-

-Sub wks_sel_chng(iset As tInputSet, ByVal Target As Range, sh As Worksheet)

-    Dim DebugMode As Boolean

-    Dim in_range As Range

-    

-    DebugMode = Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-

-    If DebugMode Then

-        sh.Unprotect

-    Else

-        sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    End If

-

-    If iset.vType = INPUT_CHECK Then

-        Set in_range = Target.Worksheet.Range(iset.rChk)

-    Else

-        Set in_range = Target

-    End If

-    

-    Dim str As String

-    str = GetFocusAddress(in_range, sh.Range("h_inputs"))

-

-'    MsgBox Target.Address & "; " & str

-    If str <> Target.address Then

-        sh.Range(str).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-Dlg_lpu_card
->>>>>>
-Attribute VB_Name = "Dlg_lpu_card"

-Attribute VB_Base = "0{2C69E842-8DA9-4240-A0A8-F6B0141DC246}{75AAB28C-ADCF-4D1B-9D5A-AF89E80A810C}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbLPU_List_Change()

-    Dim src As Range

-    Dim idx_src As Integer

-    

-    Set src = Worksheets(VAR_SHEET).Range(Me.cbLPU_List.RowSource)

-    idx_src = Me.cbLPU_List.ListIndex + 1

-    Me.tb_lpu_name.Text = src.Cells(idx_src, 1)

-    Me.tb_lpu_address.Text = src.Cells(idx_src, 2)

-    Me.tbBedsCount.Text = src.Cells(idx_src, 3)

-End Sub

-

-

-Private Sub cbxLPU_List_Enable_Click()

-    

-    If Me.cbxLPU_List_Enable Then

-        

-        Me.tb_lpu_name.Text = ""

-        Me.tb_lpu_name.Enabled = False

-        

-        Me.tb_lpu_address.Text = ""

-        Me.tb_lpu_address.Enabled = False

-        

-        Me.tbBedsCount.Text = ""

-        Me.tbBedsCount.Enabled = False

-        

-        Me.cbLPU_List.Enabled = True

-        cbLPU_List_Change

-    Else

-        Me.tb_lpu_name.Enabled = True

-        Me.tb_lpu_name.Text = ""

-        

-        Me.tb_lpu_address.Enabled = True

-        Me.tb_lpu_address.Text = ""

-        

-        Me.tbBedsCount.Enabled = True

-        Me.tbBedsCount.Text = ""

-        

-        Me.cbLPU_List.Enabled = False

-    End If

-End Sub

-

-<<<<<<
-======================
-UserInfo
->>>>>>
-Attribute VB_Name = "UserInfo"

-Attribute VB_Base = "0{BA873669-5C2D-400A-8A8B-572ACD8CCE4C}{D11400A0-9912-4240-A78C-44C33731216A}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Tag = vbOK

-End Sub

-

-Private Sub cbCity_Change()

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_CITY") = Me.cbCity.ListIndex

-        .Calculate

-    End With

-End Sub

-

-Private Sub cbRegion_Change()

-    Dim LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        NewRangeOffsetCol = cbRegion.Value * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).address

-        NewSumRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).address

-        .Calculate

-        .Range("IDX_CITY") = 0

-        cbCity.RowSource = NewCbxRange

-

-    End With

-    cbCity.ListIndex = 0

-End Sub

-

-<<<<<<
-======================
-mREGMAN
->>>>>>
-Attribute VB_Name = "mREGMAN"

-Option Explicit

-

-Sub hwnew()

-    Dim rs As Range

-    Dim re As Object

-    

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    HWReset

-    ReSet_REGMAN_Record

-    With Worksheets("RM_QTR")

-        .ClearRMName

-        .Range("REP_QTR_INPUT_DATA").ClearContents ' Это не ошибка, названия совпадают

-'        .Range("A1").Select

-    End With

-    Worksheets(TITLE_SHEET).Select

-    With Application

-        .DisplayAlerts = False

-        .ThisWorkbook.Save

-        .Quit

-    End With

-End Sub

-

-Function CheckUser() As Boolean

-    Dim objHW() As Long

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    

-    GetHWInfo objHW()

-    i = GetHWRecords(objHW_DB)

-    

-    If i = 0 Then ' First time

-        StoreHWInfo objHW()

-    End If

-    If CheckHWInfo(objHW()) <> True Then

-        CheckUser = False

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    Else

-        CheckUser = SetupUser

-    End If

-End Function

-

-Function SetupUser() As Boolean

-    Dim cREGMAN As tREGMAN

-    Dim idx As Integer

-    Dim dlg_ui As UserInfo

-    

-    Set dlg_ui = New UserInfo

-    

-    cREGMAN = Get_REGMAN_Record()

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_REGION") = cREGMAN.Region

-        .Range("IDX_CITY") = cREGMAN.City

-    End With

-        

-    With dlg_ui

-        .cbRegion = cREGMAN.Region

-        .cbCity = cREGMAN.City

-        .tbFName = cREGMAN.FirstName

-        .tbLName = cREGMAN.LastName

-    End With

-    

-    Worksheets(REGS_SHEET).Calculate

-    

-    Dim test_Ok As Boolean

-    test_Ok = False

-    

-    On Error GoTo l1

-    

-    Do

-        dlg_ui.Show

-        If dlg_ui.Tag = vbOK Then

-            test_Ok = dlg_ui.tbFName.Value <> "" And dlg_ui.tbLName <> ""

-            If test_Ok Then

-                Exit Do

-            Else

-                MsgBox "Введите имя и фамилию", vbOKOnly, PROGRAM_NAME

-            End If

-        Else

-            Exit Do

-        End If

-    Loop Until False

-l1:

-    If test_Ok Then

-        With cREGMAN

-            .Region = dlg_ui.cbRegion.Value

-            .City = dlg_ui.cbCity.Value

-            .FirstName = dlg_ui.tbFName.Value

-            .LastName = dlg_ui.tbLName.Value

-        End With

-        Set_REGMAN_Record cREGMAN

-    Else

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .ThisWorkbook.Saved = True

-            .Quit

-        End With

-    End If

-    SetupUser = test_Ok

-End Function

-

-Sub GetHWInfo(objHW() As Long)

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    i = 1

-    For Each d In dc

-        If d.drivetype = 2 Then ' 2 - HardDisk

-            ReDim Preserve objHW(i)

-            objHW(i) = d.SerialNumber

-            i = i + 1

-        End If

-    Next

-    SortHW objHW

-End Sub

-

-Sub StoreHWInfo(objHW() As Long)

-    UpdateHWRecords objHW

-End Sub

-

-Sub SortHW(objHW() As Long)

-    Dim r As Range

-    Dim rs As Range

-    Dim re As Object

-    Dim i As Integer

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    For i = 1 To UBound(objHW)

-        r = objHW(i)

-        Set r = r.Offset(1, 0)

-    Next i

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).Sort _

-            Key1:=.Range("HW_Number"), _

-            Order1:=xlDescending, _

-            Header:=xlGuess, _

-            OrderCustom:=1, _

-            MatchCase:=False, _

-            Orientation:=xlTopToBottom

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    i = 1

-    Do While r <> ""

-        objHW(i) = r

-        Set r = r.Offset(1, 0)

-        i = i + 1

-    Loop

-End Sub

-

-Function CheckHWInfo(objHW() As Long)

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    CheckHWInfo = False

-        

-    i = GetHWRecords(objHW_DB)

-    If i > 0 Then

-        SortHW objHW_DB

-    End If

-    If UBound(objHW) = UBound(objHW_DB) Then

-        For i = 1 To UBound(objHW)

-            If objHW(i) <> objHW_DB(i) Then

-                Exit Function

-            End If

-        Next i

-        CheckHWInfo = True

-    End If

-End Function

-

-

-<<<<<<
-======================
-dbBudget
->>>>>>
-Attribute VB_Name = "dbBudget"

-Option Explicit

-

-Public Type tBUDGET

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    bdgt_NMG As Long

-    bdgt_NFG As Long

-    sale_PLAN As Long

-End Type

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function GetAll_BDGT_RecordsByLPU_ID(ByRef allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_BDGT_RecordsByLPU_ID = dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection, allBDGT, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function Get_BDGT_Record(ByVal lpu_id As Long, ByVal ent_date As String) As tBUDGET

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    Get_BDGT_Record = dbGet_BDGT_Record(dbConnection, lpu_id, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objBDGT.ID <> 0 then updatre else insert

-Public Sub Insert_BDGT_Record(objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    If objBDGT.id <> 0 Then

-        dbUpdate_BDGT_Record dbConnection, objBDGT

-    Else

-        dbInsert_BDGT_Record dbConnection, objBDGT

-    End If

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Public Sub Delete_BDGT_Record(ByRef objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    dbDelete_BDGT_Record dbConnection, objBDGT

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_BDGT_Record(dbConnection As Object, ByVal lpu_id As Long, ent_date As String) As tBUDGET

-    

-    Dim sql As String

-    Dim objBDGT As tBUDGET

-    

-    With objBDGT

-        .id = 0

-        .lpu_id = lpu_id

-        .entry_date = ent_date

-        .bdgt_NMG = 0

-        .bdgt_NFG = 0

-        .sale_PLAN = 0

-    End With

-        

-    

-    sql = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        With objBDGT

-            .entry_date = dbRecordset("entry_date")

-            .id = dbRecordset("id")

-            .lpu_id = dbRecordset("lpu_id")

-            .bdgt_NFG = dbRecordset("bdgt_NFG")

-            .bdgt_NMG = dbRecordset("bdgt_NMG")

-            .sale_PLAN = dbRecordset("sale_PLAN")

-        End With

-    End If

-    

-    dbGet_BDGT_Record = objBDGT

-End Function

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection As Object, allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_BDGT_SQL As String

-    Dim getAll_BDGT_SQL As String

-    Dim BDGT_Count As Long

-    BDGT_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_BDGT_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        BDGT_Count = dbRecordset("BDGT_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_BDGT_RecordsbyLPU_ID = BDGT_Count

-    

-    If BDGT_Count > 0 Then

-        'we have records

-        ReDim allBDGT(1 To BDGT_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_BDGT_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpBDGT As tBUDGET

-                 With tmpBDGT

-                    .entry_date = dbRecordset("entry_date")

-                    .id = dbRecordset("id")

-                    .lpu_id = dbRecordset("lpu_id")

-                    .bdgt_NFG = dbRecordset("bdgt_NFG")

-                    .bdgt_NMG = dbRecordset("bdgt_NMG")

-                    .sale_PLAN = dbRecordset("sale_PLAN")

-                 End With

-                 

-                 allBDGT(index) = tmpBDGT

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbInsert_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "lpu_budget", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    dbRecordset("entry_date") = objBDGT.entry_date

-    dbRecordset("lpu_id") = objBDGT.lpu_id

-    dbRecordset("bdgt_NMG") = objBDGT.bdgt_NMG

-    dbRecordset("bdgt_NFG") = objBDGT.bdgt_NFG

-    dbRecordset("sale_PLAN") = objBDGT.sale_PLAN

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objBDGT.id = dbRecordset("id")

-  

-End Sub

-

-Public Sub dbUpdate_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu_budget SET " & _

-    "entry_date='" & objBDGT.entry_date & "'," & _

-    "lpu_id=" & objBDGT.lpu_id & "," & _

-    "bdgt_NMG=" & objBDGT.bdgt_NMG & "," & _

-    "bdgt_NFG=" & objBDGT.bdgt_NFG & "," & _

-    "sale_PLAN=" & objBDGT.sale_PLAN & _

-    " WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-Public Sub dbDelete_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_BDGT_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbDatabase
->>>>>>
-Attribute VB_Name = "dbDatabase"

-Option Explicit

-

-

-Sub dbOpenConnection(dbConnection As Object)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-<<<<<<
-======================
-dbLPU
->>>>>>
-Attribute VB_Name = "dbLPU"

-Option Explicit

-

-Public Type tLPU

-    id As Long

-    rep_id As Long

-    name As String

-    address As String

-    beds As Integer

-End Type

-

-Function Get_LPU_Record(ByVal lpu_id As Long) As tLPU

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_LPU_Record = dbGet_LPU_Record(dbConnection, lpu_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_LPU_byQTR(allLPU() As tLPU, ent_date As String, rep_id As Long) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_LPU_byQTR = dbGetAll_LPU_byQTR(dbConnection, allLPU, ent_date, rep_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_Record(dbConnection As Object, ByVal lpu_id As Long) As tLPU

-    

-    Dim sql As String

-    Dim objLPU As tLPU

-    

-    objLPU.id = lpu_id

-    objLPU.name = ""

-    objLPU.address = ""

-    

-    sql = "SELECT * FROM lpu WHERE id=" & lpu_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objLPU.name = dbRecordset("name")

-        objLPU.address = dbRecordset("address")

-        objLPU.rep_id = dbRecordset("rep_id")

-        objLPU.beds = dbRecordset("beds")

-    End If

-    

-    dbGet_LPU_Record = objLPU

-

-End Function

-

-Function dbGetAll_LPU_byQTR(dbConnection As Object, allLPU() As tLPU, ent_date As String, rep_id As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    Dim Where As String

-    Where = "WHERE lpu_budget.entry_date like '" & ent_date & "'" & " AND lpu.id=lpu_budget.lpu_id AND lpu.rep_id=" & rep_id

-

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu_budget, lpu " & Where

-    

-    getAll_LPU_SQL = "SELECT lpu.id as id, lpu.rep_id as rep_id, lpu.name as name, lpu.address as address, lpu.beds AS beds " & _

-    "FROM lpu, lpu_budget " & Where

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_LPU_byQTR = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-dbREP
->>>>>>
-Attribute VB_Name = "dbREP"

-'Option Explicit

-'

-'Public Type tREP

-'    FirstName As String

-'    LastName As String

-'    Region As Integer

-'    City As Integer

-'End Type

-'

-'Function GetREPRecord() As tREP

-'    Dim dbConnection As Object

-'

-'    dbOpenConnection dbConnection

-'    GetREPRecord = dbGetREPRecord(dbConnection)

-'    dbCloseConnection dbConnection

-'End Function

-'

-'Sub SetREPRecord(cUser As tREP)

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbSetREPRecord dbConnection, cUser

-'    dbCloseConnection dbConnection

-'End Sub

-'

-'Sub ReSetREPRecord()

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbReSetREPRecord dbConnection

-'    dbCloseConnection dbConnection

-'End Sub

-'

-'Public Function dbGetREPRecord(dbConnection As Object) As tREP

-'

-'    Dim SQL As String

-'    Dim objREP As tREP

-'

-'    objREP.FirstName = ""

-'    objREP.LastName = ""

-'    objREP.Region = 0

-'    objREP.City = 0

-'    SQL = "SELECT firstname, lastname, region, city FROM " & _

-'          "rep"

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open SQL, dbConnection

-'    ', 3, 3

-'    If Not dbRecordset.BOF Then

-'

-'        objREP.FirstName = dbRecordset("firstname")

-'        objREP.LastName = dbRecordset("lastname")

-'        objREP.Region = dbRecordset("region")

-'        objREP.City = dbRecordset("city")

-'

-'    End If

-'

-'    dbGetREPRecord = objREP

-'

-'End Function

-'

-'Public Sub dbSetREPRecord(dbConnection As Object, ByRef objREP As tREP)

-'

-'    Dim DeleteSQL As String

-'    Dim InsertSQL As String

-'

-'    DeleteSQL = "DELETE FROM rep"

-'    InsertSQL = "INSERT INTO rep (firstname, lastname, region, city) VALUES (" & _

-'    "'" & objREP.FirstName & "', " & _

-'    "'" & objREP.LastName & "', " & _

-'    objREP.Region & ", " & _

-'    objREP.City & ")"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-'

-'End Sub

-'

-'Public Sub dbReSetREPRecord(dbConnection As Object)

-'

-'    Dim DeleteSQL As String

-'

-'    DeleteSQL = "DELETE FROM rep"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-'

-'End Sub

-'

-

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    CheckWorkBooksArround Wb

-End Sub

-

-

-Sub CheckWorkBooksArround(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If app.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKOnly, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-        Exit Sub

-    End If

-

-End Sub

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub SaveExcelState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-        ActiveWorkbook.DisplayDrawingObjects = xlDisplayShapes

-        

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars(STDBAR_NAME).Visible = False

-End Sub

-

-

-Public Sub RestoreExcelState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars(STDBAR_NAME).Visible = True

-End Sub

-

-

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Public Const STDBAR_NAME = "Worksheet Menu Bar"

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Import"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmImport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Export"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 620

-                        .OnAction = "cmExport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Exit && Restore Excel"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 548

-                        .OnAction = "cmExitRestore"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-       End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(flag As Boolean)

-    If flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars(STDBAR_NAME)

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmImport()

-    Worksheets(RM_QTR_SHEET).Select

-    ImportData

-End Sub

-

-Sub cmExport()

-    dbExport

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    Dim dlg As dlgAbout

-    Set dlg = New dlgAbout

-    

-    dlg.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlg.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlg.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlg.Show

-End Sub

-

-Sub cmMail2Support()

-    Dim err_description As String

-    Dim dlg_msg As dlg_Mail

-    Set dlg_msg = New dlg_Mail

-    With dlg_msg

-        .Show

-        If .Tag = vbOK Then

-            ThisWorkbook.Worksheets(VAR_SHEET).Range("ERR_MESSAGE") _

-                = .tbMessage.Text

-            ThisWorkbook.Save

-            ThisWorkbook.SendMail Recipients:="infra@i-rs.ru", Subject:=PROGRAM_NAME & " ver.:" & PROGRAM_VERSION

-            MsgBox "Сообщение об ошибке отправлено. Перезагрузите программу.", vbOKOnly, PROGRAM_NAME

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-    End With

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-'        helppath = "hh.exe " & .Path & "\Telfast.chm"

-'        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub set_work_mode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetupEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-End Sub

-

-Sub cmSetStandaloneMode()

-    set_work_mode

-    ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    Dim dlg As dlgGetPwd

-    rp = common_pwd

-    

-    Set dlg = New dlgGetPwd

-    dlg.edPwd = ""

-    dlg.Show

-    

-    If dlg.edPwd = rp Then

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmHomePage()

-    ThisWorkbook.Worksheets("RM_QTR").Select

-End Sub

-

-Sub cmExitRestore()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = True

-    Application.Quit

-End Sub

-

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    Dim dlg_prn As dlgPrint

-    

-    Set dlg_prn = New dlgPrint

-    

-    With dlg_prn

-        .cbMainReport = True

-        .cbMainBudget = False

-        .cbSrcData = False

-        .cbAllSheets = False

-    

-        .Show

-    

-        If .Tag = vbCancel Then

-            Exit Sub

-        End If

-    End With

-    

-    Dim PrnIdx As Integer

-    

-    With dlg_prn

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("REP_QTR", "budget", "Final")

-    Case 1111

-        plist = Array("REP_QTR", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("REP_QTR")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Clexane bar"

-Public Const common_pwd As String = "crdjhxtyjr"

-

-

-Sub SetupEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    Wb.Worksheets(TITLE_SHEET).Select

-    With Application

-        .Caption = PROGRAM_NAME & " " & PROGRAM_VERSION

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .SaveExcelState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = False

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Wb.Worksheets(TITLE_SHEET).Select

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    If cWindow.Type = xlWorkbook Then

-                        cWindow.DisplayHeadings = True

-                    End If

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu True

-        End If

-        With mobjAppState

-            .RestoreExcelState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Worksheets(TITLE_SHEET).Select

-'        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Option Explicit

-

-Sub UpdateHWRecords(objHW() As Long)

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    dbUpdateHWRecords dbConnection, objHW

-    dbCloseConnection dbConnection

-End Sub

-

-Function GetHWRecords(objHW() As Long) As Integer

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    GetHWRecords = dbGetHWRecords(dbConnection, objHW)

-    dbCloseConnection dbConnection

-End Function

-

-Sub HWReset()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbInsertHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    

-    Dim dbRecordset As Object

-    Dim i As Long

-    

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "hw", dbConnection, 2, 2

-    

-    For i = 1 To UBound(objHW)

-        dbRecordset.addnew

-        dbRecordset("num") = objHW(i)

-        dbRecordset.Update

-    Next i

-    

-End Sub

-

-Sub dbUpdateHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    dbDeleteHWRecord dbConnection

-    dbInsertHWRecords dbConnection, objHW

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-dbHir
->>>>>>
-Attribute VB_Name = "dbHir"

-Option Explicit

-

-Public Type tHIRURGIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    operations_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_ambulator_clexan_40mg As Integer

-    patients_ambulator_clexan_20mg As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-    patients_stationar_clexan_40mg As Integer

-    patients_stationar_clexan_20mg As Integer

-End Type

-

-' if objHir.ID <> 0 then updatre else insert

-Sub Insert_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objHir.id <> 0 Then

-        dbUpdate_Hir_Record dbConnection, objHir

-    Else

-        dbInsert_Hir_Record dbConnection, objHir

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Hir_RecordsByLPU_ID(ByRef allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Hir_RecordsByLPU_ID = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, allHir, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Hir_Record dbConnection, objHir

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objHir.ID <> 0 then updatre else insert

-

-Sub dbInsert_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_hir", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objHir

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("operations_per_quarter") = .operations_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_ambulator_clexan_20mg") = .patients_ambulator_clexan_20mg

-        dbRecordset("patients_ambulator_clexan_40mg") = .patients_ambulator_clexan_40mg

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-        dbRecordset("patients_stationar_clexan_20mg") = .patients_stationar_clexan_20mg

-        dbRecordset("patients_stationar_clexan_40mg") = .patients_stationar_clexan_40mg

-        

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objHir.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim UpdateSQL As String

-    

-    With objHir

-        UpdateSQL = "UPDATE lpu_hir SET " & _

-            "entry_date='" & objHir.entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "operations_per_quarter=" & .operations_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_ambulator_clexan_20mg=" & .patients_ambulator_clexan_20mg & "," & _

-            "patients_ambulator_clexan_40mg=" & .patients_ambulator_clexan_40mg & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & "," & _

-            "patients_stationar_clexan_20mg=" & .patients_stationar_clexan_20mg & "," & _

-            "patients_stationar_clexan_40mg=" & .patients_stationar_clexan_40mg & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_Hir_RecordsbyLPU_ID(dbConnection As Object, allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Hir_SQL As String

-    Dim getAll_Hir_SQL As String

-    Dim Hir_Count As Long

-    Hir_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Hir_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Hir_Count = dbRecordset("HIR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Hir_RecordsbyLPU_ID = Hir_Count

-    

-    If Hir_Count > 0 Then

-        'we have records

-        ReDim allHir(1 To Hir_Count)

-        Dim index As Integer

-        index = 1

-        dbRecordset.Open getAll_Hir_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpHir As tHIRURGIA

-                 With tmpHir

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .operations_per_quarter = dbRecordset("operations_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_ambulator_clexan_20mg = dbRecordset("patients_ambulator_clexan_20mg")

-                    .patients_ambulator_clexan_40mg = dbRecordset("patients_ambulator_clexan_40mg")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                    .patients_stationar_clexan_20mg = dbRecordset("patients_stationar_clexan_20mg")

-                    .patients_stationar_clexan_40mg = dbRecordset("patients_stationar_clexan_40mg")

-                 End With

-                 

-                 allHir(index) = tmpHir

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE ID=" & objHir.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Hir_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbTer
->>>>>>
-Attribute VB_Name = "dbTer"

-Option Explicit

-

-Public Type tTERAPIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objTer.ID <> 0 then updatre else insert

-Sub Insert_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objTer.id <> 0 Then

-        dbUpdate_Ter_Record dbConnection, objTer

-    Else

-        dbInsert_Ter_Record dbConnection, objTer

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Ter_RecordsByLPU_ID(ByRef allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Ter_RecordsByLPU_ID = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, allTer, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Ter_Record dbConnection, objTer

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objTer.ID <> 0 then updatre else insert

-

-Sub dbInsert_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_ter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objTer

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objTer.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim Update_SQL As String

-    

-    With objTer

-        Update_SQL = "UPDATE lpu_ter SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_Ter_RecordsbyLPU_ID(dbConnection As Object, allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Ter_SQL As String

-    Dim getAll_Ter_SQL As String

-    Dim Ter_Count As Long

-    Ter_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Ter_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Ter_Count = dbRecordset("TER_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Ter_RecordsbyLPU_ID = Ter_Count

-    

-    If Ter_Count > 0 Then

-        'we have records

-        ReDim allTer(1 To Ter_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_Ter_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpTer As tTERAPIA

-                 With tmpTer

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 allTer(index) = tmpTer

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE ID=" & objTer.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Ter_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-mLPU_LIST
->>>>>>
-Attribute VB_Name = "mLPU_LIST"

-Option Explicit

-

-Public Const CINP_AREA As String = "B12"

-Public Const CLPU_NAME As Integer = 0

-Public Const CLPU_NAME1 As Integer = 1

-Public Const CLPU_NAME2 As Integer = 2

-Public Const CLPU_ID As Integer = 3

-Public Const CLPU_BEDS As Integer = 4

-Public Const CLPU_NFG As Integer = 5

-Public Const CLPU_NMG As Integer = 6

-Public Const CLPU_HIR As Integer = 7

-Public Const CLPU_TER As Integer = 8

-Public Const CLPU_CAR As Integer = 9

-Public Const CLPU_FACT As Integer = 10

-Public Const CLPU_PLAN As Integer = 11

-Public Const CLPU_PAT_LPU As Integer = 16

-Public Const CLPU_BDGT As Integer = 17

-Public Const CLPU_PAT_ALL As Integer = 16

-

-

-

-Sub EditLPU(cLPU As tLPU, ent_date As String)

-    NoFunc

-End Sub

-

-Sub Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-

-End Sub

-

-Sub Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btLPU_DEL_IT()

-    Dim cLPU As tLPU

-    Dim ent_date As String

-    Dim delete_all As Integer

-    Dim dlg_del As dlg_LPU_delete

-

-    With Worksheets("LPU_LIST")

-        ent_date = .Range("ent_date")

-        cLPU.id = .getCurrentLPU_ID()

-    End With

-

-    If cLPU.id = 0 Then

-        MsgBox "Укажите удаляемый объект", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    cLPU = Get_LPU_Record(cLPU.id)

-

-    Set dlg_del = New dlg_LPU_delete

-    With dlg_del

-        .chbDeleteQTR.Value = True

-        .chbDeleteAll.Value = False

-        .lComment = ent_date & ": Удаление ЛПУ '" _

-        & cLPU.name & "', расположенного по адресу:" _

-        & cLPU.address & " не разрешено."

-        .Show

-    End With

-End Sub

-

-Sub btLPU_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        

-        Wks_select .Range("ret_addr")

-    End With

-

-End Sub

-

-

-Sub btLPU_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim lpu_id As Long

-

-    i = Worksheets(VAR_SHEET).Range("QTR_ACTION").Value

-    With Worksheets("LPU_LIST")

-        ent_date = .getEnt_date()

-

-

-        lpu_id = .getCurrentLPU_ID

-        If lpu_id = 0 And i <> 6 Then

-            i = 1

-        End If

-        Select Case i

-            Case 1

-                .SelectLPU_NAME lpu_id, ent_date

-                .Range("JUMP") = ""

-            Case 2

-                .SelectLPU_BDGT lpu_id, ent_date

-                .Range("JUMP") = "LPU_BDGT"

-            Case 3

-                .SelectLPU_HIR lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_HIR"

-

-            Case 4

-                .SelectLPU_TER lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_TER"

-

-            Case 5

-                .SelectLPU_C_ACS lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        End Select

-    End With

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-dbQTR
->>>>>>
-Attribute VB_Name = "dbQTR"

-Option Explicit

-

-Public Type tQTR

-    id As Long

-    entry_date As String

-    rep_id As Long

-    sale_PLAN As Long

-    ClxnH20mg As Long

-    ClxnH40mg As Long

-    ClxnT40mg As Long

-    ClxnC_IM As Long

-    ClxnC_ACS As Long

-End Type

-

-Function Get_QTR_Record(ByVal QTR_ID As Long) As tQTR

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_QTR_Record = dbGet_QTR_Record(dbConnection, QTR_ID)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_Record(dbConnection As Object, ByVal QTR_ID As Long) As tQTR

-    

-    Dim sql As String

-    Dim objQTR As tQTR

-    

-    With objQTR

-        .ClxnC_ACS = 0

-        .ClxnC_IM = 0

-        .ClxnH20mg = 0

-        .ClxnH40mg = 0

-        .ClxnT40mg = 0

-        .entry_date = ""

-        .id = QTR_ID

-    End With

-    

-    sql = "SELECT * FROM quarter WHERE id=" & QTR_ID

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objQTR.entry_date = dbRecordset("entry_date")

-        objQTR.rep_id = dbRecordset("rep_id")

-        objQTR.sale_PLAN = dbRecordset("sale_plan")

-        objQTR.ClxnH20mg = dbRecordset("ClxnH20mg")

-        objQTR.ClxnH40mg = dbRecordset("ClxnH40mg")

-        objQTR.ClxnT40mg = dbRecordset("ClxnT40mg")

-        objQTR.ClxnC_IM = dbRecordset("ClxnC_IM")

-        objQTR.ClxnC_ACS = dbRecordset("ClxnC_ACS")

-        objQTR.id = dbRecordset("id")

-    End If

-    

-    dbGet_QTR_Record = objQTR

-

-End Function

-

-

-Function Get_QTR_Record_by_REP(ent_date As String, rep_id As Long) As tQTR

-    Dim dbConnection As Object

-    Dim allQTR() As tQTR

-    Dim i As Long

-

-    dbOpenConnection dbConnection

-

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id)

-    If i <> 0 Then

-        Get_QTR_Record_by_REP = allQTR(1)

-    End If

-

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTR_Records_by_REP(ByRef all_QTR() As tQTR, ent_date As String, rep_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-

-    GetAll_QTR_Records_by_REP = dbGetAll_QTR_Records_By_REP(dbConnection, all_QTR, ent_date, rep_id)

-

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGetAll_QTR_Records_By_REP(dbConnection As Object, all_QTR() As tQTR, ent_date As String, rep_id As Long) As Integer

-

-    Dim getCount_QTR_SQL As String

-    Dim getAll_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter " & _

-    "WHERE entry_date like '" & ent_date & "' AND rep_id=" & rep_id

-    getAll_QTR_SQL = "SELECT * FROM quarter " & _

-    "WHERE entry_date like '" & ent_date & "' AND rep_id=" & rep_id & " ORDER BY entry_date"

-

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-

-    dbRecordset.Close

-

-    dbGetAll_QTR_Records_By_REP = QTR_Count

-

-    If QTR_Count > 0 Then

-        'we have records

-        ReDim all_QTR(1 To QTR_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTR_SQL, dbConnection

-

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTR As tQTR

-                 With tmp_QTR

-                    .entry_date = dbRecordset("entry_date")

-                    .rep_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .ClxnH20mg = dbRecordset("ClxnH20mg")

-                    .ClxnH40mg = dbRecordset("ClxnH40mg")

-                    .ClxnT40mg = dbRecordset("ClxnT40mg")

-                    .ClxnC_IM = dbRecordset("ClxnC_IM")

-                    .ClxnC_ACS = dbRecordset("ClxnC_ACS")

-                    .id = dbRecordset("id")

-                 End With

-

-                 all_QTR(index) = tmp_QTR

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-cdbQTR
->>>>>>
-Attribute VB_Name = "cdbQTR"

-Option Explicit

-

-Public Type tQTR_COMMON

-    qtr As tQTR

-    i_lcd As Long           ' число ЛПУ в СПИСКЕ

-    lcd() As tLPU_COMMON    ' список ЛПУ

-    c_beds As Long          ' сумма коек

-    c_bdgt_NFG As Long      ' общий бюджет на НФГ

-    c_bdgt_NMG As Long      ' общий бюджет на НМГ

-    c_bdgt_LPU As Long      ' общий бюджет на гепарины

-    c_sale_PLAN As Long     ' план продаж репа

-    c_sale_ALL As Long      ' продажи

-    c_sale_HIR As Long      ' в хирургии

-    c_sale_TER  As Long     ' в терапии

-    c_sale_CRD  As Long     ' в кардиологии

-    c_pat_HIR   As Long     ' пациенты

-    c_pat_TER   As Long     '

-    c_pat_CRD   As Long     '

-    c_pat_ALL   As Long     '

-    c_pat_LPU   As Long     ' Всего операций

-End Type

-

-Function GetLastQTR_fromDB() As String

-    Dim dbConnection As Object

-    Dim getCount_QTR_SQL As String

-    Dim getLast_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter"

-    getLast_QTR_SQL = "SELECT MAX(entry_date) as ent_date FROM quarter"

-    

-    dbOpenConnection dbConnection

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    If QTR_Count > 0 Then

-        'we have records

-        dbRecordset.Open getLast_QTR_SQL, dbConnection

-        getLast_QTR_SQL = dbRecordset("ent_date")

-    End If

-    GetLastQTR_fromDB = getLast_QTR_SQL

-    dbCloseConnection dbConnection

-End Function

-

-Function Get_QTR_CommonList_by_REP(ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_QTR_CommonList_by_REP = dbGet_QTR_CommonList_by_REP(dbConnection, qcd, ent_date, rep_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_CommonList_by_REP(dbConnection As Object, ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim allQTR() As tQTR

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id)

-    dbGet_QTR_CommonList_by_REP = i

-    If i > 0 Then

-        ReDim qcd(i)

-        For i = 1 To UBound(allQTR)

-            With qcd(i)

-                .qtr = allQTR(i)

-                .c_beds = 0

-                .c_bdgt_NFG = 0

-                .c_bdgt_NMG = 0

-                .c_bdgt_LPU = 0

-                .c_sale_PLAN = 0

-                .c_pat_HIR = 0

-                .c_pat_TER = 0

-                .c_pat_CRD = 0

-                .c_pat_ALL = 0

-                .c_sale_HIR = 0

-                .c_sale_TER = 0

-                .c_sale_CRD = 0

-                .c_sale_ALL = 0

-                .c_pat_LPU = 0

-                

-                j = dbGet_LPU_CommonQTR(dbConnection, .lcd, .qtr)

-                .i_lcd = j

-                If j > 0 Then

-                    For j = 1 To UBound(.lcd)

-                        .c_beds = .c_beds + .lcd(j).lpu.beds

-                        .c_bdgt_NFG = .c_bdgt_NFG + .lcd(j).bdgt.bdgt_NFG

-                        .c_bdgt_NMG = .c_bdgt_NMG + .lcd(j).bdgt.bdgt_NMG

-                        .c_bdgt_LPU = .c_bdgt_LPU + .lcd(j).bdgt_LPU

-                        .c_sale_PLAN = .c_sale_PLAN + .lcd(j).bdgt.sale_PLAN

-                        .c_pat_HIR = .c_pat_HIR + .lcd(j).pat_HIR

-                        .c_pat_TER = .c_pat_TER + .lcd(j).pat_TER

-                        .c_pat_CRD = .c_pat_CRD + .lcd(j).pat_CRD

-                        .c_pat_ALL = .c_pat_ALL + .lcd(j).pat_ALL

-                        .c_sale_HIR = .c_sale_HIR + .lcd(j).sale_HIR

-                        .c_sale_TER = .c_sale_TER + .lcd(j).sale_TER

-                        .c_sale_CRD = .c_sale_CRD + .lcd(j).sale_CRD

-                        .c_sale_ALL = .c_sale_ALL + .lcd(j).sale_ALL

-                        .c_pat_LPU = .c_pat_LPU + .lcd(j).pat_LPU

-                    Next j

-                    

-                End If

-            End With

-        Next i

-    End If

-End Function

-

-Function GetLastQtr() As String

-    Dim s As String

-    Dim r As Range

-    Set r = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Do While r.Cells(1, 1) <> ""

-        s = r.Cells(1, 1)

-        Set r = r.Cells.Offset(1, 0)

-    Loop

-    GetLastQtr = s

-End Function

-

-Function GetNextQTR(ent_date As String) As String

-    Dim rd As Range

-    Dim idx As Integer

-    Dim b As Variant

-    Dim dlg As dlg_newQTR

-    Set dlg = New dlg_newQTR

-    

-    If ent_date = "" Then

-        Dim ir As Variant

-        idx = 0

-        dlg.Show

-        b = dlg.Tag

-            

-        If IsNumeric(b) Then

-            GetNextQTR = dlg.cbQTR

-        Else

-            GetNextQTR = ""

-        End If

-    Else

-        Set rd = Worksheets(VAR_SHEET).Range("Date_Lst")

-        idx = WorksheetFunction.Match(ent_date, rd, 0)

-        GetNextQTR = WorksheetFunction.index(rd, idx + 1, 1)

-    End If

-End Function

-<<<<<<
-======================
-mRestView
->>>>>>
-Attribute VB_Name = "mRestView"

-Option Explicit

-

-Sub xlRestoreView()

-Attribute xlRestoreView.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute xlRestoreView.VB_ProcData.VB_Invoke_Func = " \n14"

-    With Application

-        .CommandBars("Standard").Visible = True

-        .CommandBars("Formatting").Visible = True

-        .DisplayFormulaBar = True

-        .DisplayStatusBar = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = True

-    End With

-End Sub

-<<<<<<
-======================
-dlg_newQTR
->>>>>>
-Attribute VB_Name = "dlg_newQTR"

-Attribute VB_Base = "0{3EA3C15A-5493-445F-9858-2F241E7D6CEA}{849C1FE1-631A-485D-BE54-A7B73124582C}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mDec2TS
->>>>>>
-Attribute VB_Name = "mDec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-CHRT_LPU_BBL
->>>>>>
-Attribute VB_Name = "CHRT_LPU_BBL"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Unprotect

-    Range("view_key") = True

-    On Error Resume Next

-    ChangeLabels

-    Range("A1").Select

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Unprotect

-    Dim s As String

-    s = Range("ret_addr")

-    Protect UserInterfaceOnly:=True

-    Wks_select (s)

-End Sub

-

-Sub BCLabelChng_Click()

-    Unprotect

-    If Range("view_key") Then

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать названия"

-    Else

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать объемы"

-    End If

-    Range("view_key") = Not Range("view_key")

-    ChangeLabels

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub ChangeLabels()

-    Dim i As Integer

-    Dim offset_text As Integer

-    Dim src As Range

-    Set src = Range("CHRT_BBL_DATA")

-    

-    offset_text = 3

-    If Range("view_key") Then

-        offset_text = 4

-    End If

-    

-    With ChartObjects(1).Chart

-        With .SeriesCollection(1)

-            For i = 1 To .Points.count

-                On Error GoTo ExitLabel

-                .Points(i).DataLabel.Characters.Text = Format(src.Cells(i, offset_text))

-            Next i

-        End With

-    End With

-ExitLabel:

-End Sub

-

-<<<<<<
-======================
-CHRT_PAT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PAT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-<<<<<<
-======================
-CHRT_PAT_LPU
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_nextQTR
->>>>>>
-Attribute VB_Name = "dlg_nextQTR"

-Attribute VB_Base = "0{B85FF7F1-50C0-4433-BC6F-8A0F2C9BDDDA}{EC2D2B9E-9ED2-4005-A1E9-EF0626D3B7E7}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-cdbLPU
->>>>>>
-Attribute VB_Name = "cdbLPU"

-Option Explicit

-

-Public Type tLPU_COMMON

-    lpu As tLPU

-    bdgt As tBUDGET

-    i_hir As Long

-    hir() As tHIRURGIA

-    i_ter As Long

-    ter() As tTERAPIA

-    i_ACS As Long

-    ACS() As tACS

-    bdgt_LPU As Long

-    sale_HIR As Long

-    sale_TER As Long

-    sale_CRD As Long

-    sale_ALL As Long

-    pat_HIR As Long

-    pat_TER As Long

-    pat_CRD As Long

-    pat_ALL As Long     ' Сумма всех пациентов на клексане

-    pat_LPU As Long     ' Число потенциальных пациентов для продаж клексана

-End Type

-

-Function Get_LPU_CommonQTR(ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    Get_LPU_CommonQTR = dbGet_LPU_CommonQTR(dbConnection, lcd, objQTR)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_CommonQTR(dbConnection As Object, ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    i = dbGetAll_LPU_byQTR(dbConnection, allLPU, objQTR.entry_date, objQTR.rep_id)

-    dbGet_LPU_CommonQTR = i

-    If i > 0 Then

-        ReDim lcd(i)

-        For i = 1 To UBound(allLPU)

-            dbGet_LPU_Common dbConnection, lcd(i), allLPU(i), objQTR

-        Next i

-    End If

-End Function

-

-Sub Get_LPU_Common(ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    dbGet_LPU_Common dbConnection, lcd, cLPU, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbGet_LPU_Common(dbConnection As Object, ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-

-    lcd.lpu = cLPU

-    lcd.bdgt = dbGet_BDGT_Record(dbConnection, cLPU.id, objQTR.entry_date)

-    lcd.i_hir = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, lcd.hir, cLPU.id, objQTR.entry_date)

-    lcd.i_ter = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, lcd.ter, cLPU.id, objQTR.entry_date)

-    lcd.i_ACS = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, lcd.ACS, cLPU.id, objQTR.entry_date)

-    With lcd

-        .bdgt_LPU = .bdgt.bdgt_NFG + .bdgt.bdgt_NMG

-        .pat_LPU = 0

-        If .i_hir > 0 Then

-            .pat_HIR = .hir(1).patients_ambulator_clexan + .hir(1).patients_stationar_clexan

-            .sale_HIR = objQTR.ClxnH20mg * (.hir(1).patients_ambulator_clexan_20mg + .hir(1).patients_stationar_clexan_20mg)

-            .sale_HIR = .sale_HIR + objQTR.ClxnH40mg * (.hir(1).patients_ambulator_clexan_40mg + .hir(1).patients_stationar_clexan_40mg)

-            .pat_LPU = .pat_LPU + .hir(1).operations_per_quarter

-        End If

-        If .i_ter > 0 Then

-            .pat_TER = .ter(1).patients_ambulator_clexan + .ter(1).patients_stationar_clexan

-            .sale_TER = .pat_TER * objQTR.ClxnT40mg

-            .pat_LPU = .pat_LPU + .ter(1).patients_per_quarter

-        End If

-        If .i_ACS > 0 Then

-            .pat_CRD = .ACS(1).patients_stationar_clexan

-            .sale_CRD = .pat_CRD * objQTR.ClxnC_ACS

-            .pat_LPU = .pat_LPU + .ACS(1).patients_per_quarter

-        End If

-        .pat_ALL = .pat_HIR + .pat_TER + .pat_CRD

-        .sale_ALL = .sale_HIR + .sale_TER + .sale_CRD

-    End With

-End Sub

-

-<<<<<<
-======================
-CHRT_PIE
->>>>>>
-Attribute VB_Name = "CHRT_PIE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    

-    Unprotect

-    

-    On Error Resume Next

-    

-    Range("P5:Q24").Sort _

-        Key1:=Range("Q5"), _

-        Order1:=xlDescending, _

-        Header:=xlGuess, _

-        OrderCustom:=1, _

-        MatchCase:=False, _

-        Orientation:=xlTopToBottom

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PLN_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PLN_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_BDGT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_BDGT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_LPU_delete
->>>>>>
-Attribute VB_Name = "dlg_LPU_delete"

-Attribute VB_Base = "0{EC96F2D1-337D-47DF-B0F1-A6DF3F8CD5CC}{7EB42A63-CBFC-45B0-AE4D-C3E3D8FE7420}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlg_Mail
->>>>>>
-Attribute VB_Name = "dlg_Mail"

-Attribute VB_Base = "0{7B669454-C2AA-4FDF-8311-7ADEDDEF3FF3}{D07A0A02-4923-46C8-8EE8-62769243087D}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dbREP_id
->>>>>>
-Attribute VB_Name = "dbREP_id"

-Public Type tREPID

-    rep_id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function GetAll_REPID_Records_by_QTR(ByRef all_REPID() As tREPID, ent_date As String) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_REPID_Records_by_QTR = dbGetAll_REPID_Records_by_QTR(dbConnection, all_REPID, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-Function Get_REPID_Record(id As Long) As tREPID

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REPID_Record = dbGet_REPID_Record(dbConnection, id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_REPID_Records(ByRef all_REPID() As tREPID) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_REPID_Records = dbGetAll_REPID_Records(dbConnection, all_REPID)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function dbGet_REPID_Record(dbConnection As Object, id As Long) As tREPID

-    

-    Dim sql As String

-    Dim objREPID As tREPID

-    

-    objREPID.FirstName = ""

-    objREPID.LastName = ""

-    objREPID.Region = 0

-    objREPID.City = 0

-    sql = "SELECT rep_id, firstname, lastname, region, city FROM " & _

-          "rep WHERE rep_id=" & id

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREPID.rep_id = dbRecordset("rep_id")

-        objREPID.FirstName = dbRecordset("firstname")

-        objREPID.LastName = dbRecordset("lastname")

-        objREPID.Region = dbRecordset("region")

-        objREPID.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REPID_Record = objREPID

-        

-End Function

-

-Function dbGetAll_REPID_Records_by_QTR(dbConnection As Object, ByRef all_REPID() As tREPID, ent_date As String) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    Dim Where As String

-    

-    REPID_Count = 0

-    Where = " WHERE lpu_budget.entry_date like '" & ent_date & "' " & _

-        "AND rep.rep_id=lpu.rep_id AND lpu.id=lpu_budget.lpu_id"

-    

-    

-    getAll_REPID_SQL = "SELECT distinct rep.* FROM rep, lpu, lpu_budget" & Where

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM (" & getAll_REPID_SQL & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records_by_QTR = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Function dbGetAll_REPID_Records(dbConnection As Object, ByRef all_REPID() As tREPID) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    REPID_Count = 0

-    

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM rep"

-    getAll_REPID_SQL = "SELECT * FROM rep"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-cdbExport
->>>>>>
-Attribute VB_Name = "cdbExport"

-Option Explicit

-

-Function GetDBSN() As String

-    Dim n As Long

-    Randomize Timer

-    n = Int((100000000 - 1000000 + 1) * Rnd + 1000000)

-    GetDBSN = Dec2ThirtySix(n)

-End Function

-

-Sub dbExport()

-    Dim src_file As String

-    Dim dst_file As String

-    

-    On Error GoTo ErrHandler

-    

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & GetLastQTR_fromDB & "_" & GetDBSN() & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Данные экспортированы в файл:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для передачи", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-Exit Sub

-

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-<<<<<<
-======================
-mRegs
->>>>>>
-Attribute VB_Name = "mRegs"

-Option Explicit

-

-Function GetRegionName(idx As Integer) As String

-    GetRegionName = Worksheets(REGS_SHEET).Range("LST_REGIONS").Cells(idx + 1, 1).Text

-End Function

-

-Function GetCityName(idx_reg As Integer, idx_city As Integer) As String

-    GetCityName = Worksheets(REGS_SHEET).Range("CITY_TABLES").Offset(idx_city + 1, idx_reg * 2).Text

-End Function

-

-Sub testReg()

-    Dim r As Integer

-    Dim c As Integer

-    Dim s As String

-    

-    r = 3

-    c = 3

-    s = GetRegionName(r)

-    s = s & ", " & GetCityName(r, c)

-    MsgBox s

-End Sub

-

-<<<<<<
-======================
-RM_QTR
->>>>>>
-Attribute VB_Name = "RM_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CRGN_QT As Integer = 0

-Const CRGN_PLN As Integer = 2

-Const CRGN_FCT As Integer = 3

-Const CRGN_BDG As Integer = 4

-Const CRGN_LPU As Integer = 5

-Const CRGN_REP As Integer = 6

-Const CRGN_HIR As Integer = 7

-Const CRGN_TER As Integer = 8

-Const CRGN_CRD As Integer = 9

-Const CRGN_CLXN_BDG As Integer = 10

-Const CRGN_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub ClearRMName()

-    Unprotect

-    Range("D4") = ""

-    Range("D5") = ""

-    Range("H4") = ""

-End Sub

-

-Sub update_history()

-    Dim objRGN() As tREGION

-    Dim i As Long

-    Dim r As Range

-    Dim cRMan As tREGMAN

-

-    cRMan = Get_REGMAN_Record

-    

-    Range("D4") = cRMan.LastName

-    Range("D5") = cRMan.FirstName

-

-    Range("H4") = GetRegionName(cRMan.Region)

-    

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetRGN_COMM_DATA(objRGN)

-    

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objRGN)

-            r.Offset(i - 1, CRGN_QT) = objRGN(i).ent_date

-            r.Offset(i - 1, CRGN_FCT) = objRGN(i).total_SALE

-            r.Offset(i - 1, CRGN_PLN) = objRGN(i).sale_PLAN

-            r.Offset(i - 1, CRGN_BDG) = objRGN(i).total_BDGT

-            r.Offset(i - 1, CRGN_LPU) = objRGN(i).total_LPU

-            r.Offset(i - 1, CRGN_REP) = objRGN(i).total_REP

-            r.Offset(i - 1, CRGN_HIR) = objRGN(i).total_HIR

-            r.Offset(i - 1, CRGN_TER) = objRGN(i).total_TER

-            r.Offset(i - 1, CRGN_CRD) = objRGN(i).total_ACS

-            If objRGN(i).total_BDGT <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_BDG) = objRGN(i).total_SALE / objRGN(i).total_BDGT

-            End If

-            If objRGN(i).total_BDGT_NMG <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_NMG) = objRGN(i).total_SALE / objRGN(i).total_BDGT_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRGN_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRM_QtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR_RM

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR_RM

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR_RM

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = RM_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect UserInterfaceOnly:=True

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CRGN_QT + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    If r = "" Then

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = currRange.address

-        With Worksheets("REP_LIST")

-            .Range("ret_addr") = "RM_QTR"

-            .Range("ent_date") = r

-            .Range("VIEW_ONLY") = True

-        End With

-    End If

-    Cancel = True

-    btRM_QTR_Do_IT

-End Sub

-

-<<<<<<
-======================
-dbREG_MAN
->>>>>>
-Attribute VB_Name = "dbREG_MAN"

-Option Explicit

-

-Public Type tREGMAN

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function Get_REGMAN_Record() As tREGMAN

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REGMAN_Record = dbGet_REGMAN_Record(dbConnection)

-    dbCloseConnection dbConnection

-End Function

-

-Sub Set_REGMAN_Record(cREGMAN As tREGMAN)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbSet_REGMAN_Record dbConnection, cREGMAN

-    dbCloseConnection dbConnection

-End Sub

-

-Sub ReSet_REGMAN_Record()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbReSet_REGMAN_Record dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_REGMAN_Record(dbConnection As Object) As tREGMAN

-    

-    Dim sql As String

-    Dim objREGMAN As tREGMAN

-    

-    objREGMAN.FirstName = ""

-    objREGMAN.LastName = ""

-    objREGMAN.Region = 0

-    objREGMAN.City = 0

-    sql = "SELECT firstname, lastname, region, city FROM " & _

-          "reg_man"

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREGMAN.FirstName = dbRecordset("firstname")

-        objREGMAN.LastName = dbRecordset("lastname")

-        objREGMAN.Region = dbRecordset("region")

-        objREGMAN.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REGMAN_Record = objREGMAN

-        

-End Function

-

-Public Sub dbSet_REGMAN_Record(dbConnection As Object, ByRef objREGMAN As tREGMAN)

-  

-    Dim DeleteSQL As String

-    Dim InsertSQL As String

-    

-    DeleteSQL = "DELETE FROM reg_man"

-    InsertSQL = "INSERT INTO reg_man (firstname, lastname, region, city) VALUES (" & _

-    "'" & objREGMAN.FirstName & "', " & _

-    "'" & objREGMAN.LastName & "', " & _

-    objREGMAN.Region & ", " & _

-    objREGMAN.City & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    dbRecordset.Open InsertSQL, dbConnection

-       

-End Sub

-

-Public Sub dbReSet_REGMAN_Record(dbConnection As Object)

-  

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM reg_man"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    

-End Sub

-

-

-<<<<<<
-======================
-dbDatabaseMerge
->>>>>>
-Attribute VB_Name = "dbDatabaseMerge"

-Option Explicit

-

-Public Type tDBFIELD

-    name As String

-End Type

-

-Public Type tDBTABLE

-    name As String

-    field() As tDBFIELD

-End Type

-

-

-Function dbGetConnection(dbAccessFileFullPath As String) As Object

-    Dim dbConnection As Object

-    Dim dbAccessFilePasswd As String

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFileFullPath & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    Set dbGetConnection = dbConnection

-End Function

-

-Sub dbCloseOpenedConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteOpenedSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-Function dbMergeREP(from_dbConnection As Object, to_dbConnection As Object) As Long

-

-    Dim getRecordset As Object

-    Dim getREPData_SQL As String

-    Dim REP_fn As String

-    Dim REP_ln As String

-    Dim REP_region As String

-    Dim REP_city As String

-

-

-    getREPData_SQL = "SELECT * FROM rep"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getREPData_SQL, from_dbConnection

-        

-        If Not getRecordset.BOF Then

-            REP_fn = getRecordset("firstname")

-            REP_ln = getRecordset("lastname")

-            REP_city = getRecordset("city")

-            REP_region = getRecordset("region")

-        Else

-            MsgBox "There is no information about rep! This database cannot be merged!!!"

-            dbMergeREP = -1

-            Exit Function

-        End If

-    

-    Dim insertRecordset As Object

-    Set insertRecordset = CreateObject("ADODB.Recordset")

-        

-    insertRecordset.Open "rep", to_dbConnection, 2, 2

-    insertRecordset.addnew

-        

-    insertRecordset("firstname") = REP_fn

-    insertRecordset("lastname") = REP_ln

-    insertRecordset("region") = REP_region

-    insertRecordset("city") = REP_city

-    insertRecordset.Update

-    insertRecordset.MoveLast

-    'new ID

-    

-    dbMergeREP = insertRecordset("rep_id")

-    

-End Function

-

-Sub dbMergeLPU(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getLPU_SQL As String

-    Dim getRecordset As Object

-    Dim idx As Long

-    idx = 1

-    

-    getLPU_SQL = "SELECT * FROM lpu"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getLPU_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            ReDim Preserve objLPU(1 To idx)

-            objLPU(idx).old_lpu_id = getRecordset("id")

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "lpu", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("name") = getRecordset("name")

-            insRS("address") = getRecordset("address")

-            insRS("beds") = getRecordset("beds")

-            insRS.Update

-            insRS.MoveLast

-            'new ID

-            

-            objLPU(idx).new_lpu_id = insRS("id")

-                        

-            idx = idx + 1

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about LPU! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-

-Sub dbMergeLPURelated(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object)

-

-    ' 6 tables to change

-    Dim tables(1 To 5) As tDBTABLE

-    

-    'lpu budget

-    tables(1).name = "lpu_budget"

-    ReDim tables(1).field(1 To 4)

-    

-    tables(1).field(1).name = "entry_date"

-    tables(1).field(2).name = "bdgt_NMG"

-    tables(1).field(3).name = "bdgt_NFG"

-    tables(1).field(4).name = "sale_PLAN"

-    

-    'lpu hir

-    tables(2).name = "lpu_hir"

-    ReDim tables(2).field(1 To 13)

-    

-    tables(2).field(1).name = "entry_date"

-    tables(2).field(2).name = "operations_per_quarter"

-    tables(2).field(3).name = "risk_percent"

-    tables(2).field(4).name = "patients_with_risk_ON"

-    tables(2).field(5).name = "patients_ambulator"

-    tables(2).field(6).name = "patients_ambulator_nmg"

-    tables(2).field(7).name = "patients_ambulator_clexan"

-    tables(2).field(8).name = "patients_ambulator_clexan_40mg"

-    tables(2).field(9).name = "patients_ambulator_clexan_20mg"

-    tables(2).field(10).name = "patients_stationar_nmg"

-    tables(2).field(11).name = "patients_stationar_clexan"

-    tables(2).field(12).name = "patients_stationar_clexan_40mg"

-    tables(2).field(13).name = "patients_stationar_clexan_20mg"

-    

-    

-    'lpu acs

-    tables(3).name = "lpu_acs"

-    ReDim tables(3).field(1 To 5)

-    

-    tables(3).field(1).name = "entry_date"

-    tables(3).field(2).name = "patients_with_geparins"

-    tables(3).field(3).name = "patients_per_quarter"

-    tables(3).field(4).name = "patients_stationar_nmg"

-    tables(3).field(5).name = "patients_stationar_clexan"

-    

-    'lpu acs

-    tables(4).name = "lpu_im"

-    ReDim tables(4).field(1 To 5)

-    

-    tables(4).field(1).name = "entry_date"

-    tables(4).field(2).name = "patients_with_geparins"

-    tables(4).field(3).name = "patients_per_quarter"

-    tables(4).field(4).name = "patients_stationar_nmg"

-    tables(4).field(5).name = "patients_stationar_clexan"

-    

-    

-    'lpu acs

-    tables(5).name = "lpu_ter"

-    ReDim tables(5).field(1 To 9)

-    

-    tables(5).field(1).name = "entry_date"

-    tables(5).field(2).name = "patients_per_quarter"

-    tables(5).field(3).name = "risk_percent"

-    tables(5).field(4).name = "patients_with_risk_ON"

-    tables(5).field(5).name = "patients_ambulator"

-    tables(5).field(6).name = "patients_ambulator_nmg"

-    tables(5).field(7).name = "patients_ambulator_clexan"

-    tables(5).field(8).name = "patients_stationar_nmg"

-    tables(5).field(9).name = "patients_stationar_clexan"

-    

-    

-    

-    Dim tbl_idx As Integer

-    

-    For tbl_idx = 1 To UBound(tables)

-        

-        Dim getSQL As String

-        Dim getRS As Object

-        

-        

-        

-        Set getRS = CreateObject("ADODB.Recordset")

-        

-        getSQL = "SELECT * FROM " & tables(tbl_idx).name

-        getRS.Open getSQL, from_db

-        

-        If Not getRS.BOF Then

-            Do While Not getRS.EOF

-                Dim insRS As Object

-                Set insRS = CreateObject("ADODB.Recordset")

-                

-                insRS.Open tables(tbl_idx).name, to_db, 2, 2

-                insRS.addnew

-                Dim fld_idx As Integer

-    

-                    For fld_idx = 1 To UBound(tables(tbl_idx).field)

-                        insRS(tables(tbl_idx).field(fld_idx).name) = getRS(tables(tbl_idx).field(fld_idx).name)

-                        insRS("lpu_id") = findNewLPU_IDByOld(objLPU, getRS("lpu_id"))

-                    Next fld_idx

-                    

-                insRS.Update

-                insRS.MoveLast

-                getRS.MoveNext

-            Loop

-        End If

-        

-        

-    Next tbl_idx

-

-End Sub

-

-Function findNewLPU_IDByOld(objLPU() As tLPUCONVERTION, old_id As Long)

-

-Dim i As Integer

-For i = 1 To UBound(objLPU)

-    If objLPU(i).old_lpu_id = old_id Then

-        findNewLPU_IDByOld = objLPU(i).new_lpu_id

-        Exit Function

-    End If

-Next i

-

-findNewLPU_IDByOld = -1

-End Function

-

-

-

-

-

-Sub dbMergeQTR(from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getQTR_SQL As String

-    Dim getRecordset As Object

-    

-    getQTR_SQL = "SELECT * FROM quarter"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getQTR_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "quarter", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("entry_date") = getRecordset("entry_date")

-            insRS("sale_plan") = getRecordset("sale_plan")

-            insRS("ClxnH20mg") = getRecordset("ClxnH20mg")

-            insRS("ClxnH40mg") = getRecordset("ClxnH40mg")

-            insRS("ClxnT40mg") = getRecordset("ClxnT40mg")

-            insRS("ClxnC_IM") = getRecordset("ClxnC_IM")

-            insRS("ClxnC_ACS") = getRecordset("ClxnC_ACS")

-            

-            

-            insRS.Update

-            

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about quarter budget! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-dbMerge
->>>>>>
-Attribute VB_Name = "dbMerge"

-Option Explicit

-

-Public Type tLPUCONVERTION

-    old_lpu_id As Long

-    new_lpu_id As Long

-End Type

-

-Sub Merge_BackUp_All_Data()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim time_stump As String

-    

-    On Error GoTo ErrHandler

-    

-    time_stump = Format(Date, "yy-mm-dd_") & Format(Time, "hh-mm")

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_BACKUPNAME & time_stump & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Старые данные сохранены в файле:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для восстановления данных в случае утери", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-    Exit Sub

-    

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-

-Sub Merge_Clear_All_Data(access_file_full_path As String)

-    

-    Dim db As Object

-    Dim tables_to_clear() As String

-    On Error GoTo ErrHandler

-    

-    ReDim tables_to_clear(1 To 8)

-    tables_to_clear(1) = "rep"

-    tables_to_clear(2) = "lpu"

-    tables_to_clear(3) = "lpu_budget"

-    tables_to_clear(4) = "lpu_hir"

-    tables_to_clear(5) = "lpu_ter"

-    tables_to_clear(6) = "lpu_acs"

-    tables_to_clear(7) = "lpu_im"

-    tables_to_clear(8) = "quarter"

-    

-    Set db = dbGetConnection(access_file_full_path)

-

-    Dim i As Integer

-    

-    For i = 1 To UBound(tables_to_clear)

-        

-        If tables_to_clear(i) <> "" Then

-            Dim Clear_SQL As String

-            Clear_SQL = "DELETE FROM " & tables_to_clear(i)

-            dbExecuteOpenedSQL db, Clear_SQL

-        Else

-            'do nothing or show message

-        End If

-    Next i

-    

-    dbCloseOpenedConnection db

-    Set db = Nothing

-    

-'    Dim Engine As Object

-'    Set Engine = CreateObject("JRO.JetEngine")

-'    Engine.CompactDatabase "Password=password;Data Source=" & access_file_full_path, _

-'    "Password=password;Data Source=c:\tmp\1.mdb"

-    

-Exit Sub

-

-ErrHandler:

-    MsgBox "something wrong: " & err.Description

-    Resume Next

-    

-End Sub

-

-Function MergeREP(from_file As String, to_file As String) As Long

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    Dim new_rep_id As Long

-

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    MergeREP = dbMergeREP(db1, db2)

-    'MsgBox "new rep ID is " & new_rep_id

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Function

-

-Sub MergeQTR(from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeQTR db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-

-Sub MergeLPU(objLPU() As tLPUCONVERTION, from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeLPU objLPU, db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-Sub MergeLPURelated(objLPU() As tLPUCONVERTION, from_file As String, to_file As String)

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    dbMergeLPURelated objLPU, db1, db2

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-

-End Sub

-

-Sub MergeGlobal(rep_files() As String, rm_file As String)

-

-    Dim i As Integer

-    'clear output file content

-    Merge_Clear_All_Data rm_file

-    

-    For i = 1 To UBound(rep_files)

-        

-        Dim rep_file As String

-        'setup input and output files

-        rep_file = rep_files(i)

-        

-        Dim new_rep_id As Long

-        ' insert REP data and get new rep_id

-        new_rep_id = MergeREP(rep_file, rm_file)

-        

-        Dim objLPU() As tLPUCONVERTION

-        'insert all LPU using new generated rep_id

-        'and populate objLPU old->new relation object

-        

-        MergeLPU objLPU, rep_file, rm_file, new_rep_id

-        'insert quarter data using new rep_id

-        MergeQTR rep_file, rm_file, new_rep_id

-        

-        

-        ' and.... insert all another data (5 tables excl version and hw)

-        'using objLPU old->new relation object

-        MergeLPURelated objLPU, rep_file, rm_file

-    

-    

-    Next i

-    

-End Sub

-

-Function GetDBList(MyPath() As String, ByRef dblist() As String) As Integer

-    Dim i As Integer

-    Dim MyName, MyMask

-    MyMask = MyPath(0) & MyPath(1) & PROGRAM_DATAEXT

-    i = 0

-    MyName = Dir(MyMask)      ' Retrieve the first entry.

-    Do While MyName <> ""    ' Start the loop.

-        ' Ignore the current directory and the encompassing directory.

-        If MyName <> "." And MyName <> ".." Then

-            ' Use bitwise comparison to make sure MyName is a directory.

-            i = i + 1

-            ReDim Preserve dblist(i)

-            dblist(i) = MyPath(0) & MyName

-        End If

-        MyName = Dir    ' Get next entry.

-    Loop

-    GetDBList = i

-End Function

-

-<<<<<<
-======================
-dlgImprtDB
->>>>>>
-Attribute VB_Name = "dlgImprtDB"

-Attribute VB_Base = "0{D5892870-2C88-40C8-A817-AC9B1CF37C2C}{9853EBEA-4E48-41F9-89C0-6F753EB6A0C2}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Private Sub btSelAll_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = True

-    Next i

-End Sub

-

-Private Sub btUnselect_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = False

-    Next i

-End Sub

-<<<<<<
-======================
-dbQTR_RM
->>>>>>
-Attribute VB_Name = "dbQTR_RM"

-Option Explicit

-

-Public Type tQTRRM

-    id As Long

-    entry_date As String

-    rm_id As Long

-    sale_PLAN As Long

-End Type

-

-

-Sub Insert_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objQTRRM.id <> 0 Then

-        dbUpdate_QTRRM_Record dbConnection, objQTRRM

-    Else

-        dbInsert_QTRRM_Record dbConnection, objQTRRM

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-Function Get_QTRRM_Record(ent_date As String) As tQTRRM

-    Dim dbConnection As Object

-    Dim allQTRRM() As tQTRRM

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    i = dbGetAll_QTRRM_Records(dbConnection, allQTRRM, ent_date)

-    If i <> 0 Then

-        Get_QTRRM_Record = allQTRRM(1)

-    End If

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTRRM_Records(ByRef all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_QTRRM_Records = dbGetAll_QTRRM_Records(dbConnection, all_QTRRM, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_QTRRM_Record dbConnection, objQTRRM

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objQTRRM.ID <> 0 then updatre else insert

-Sub dbInsert_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "quarter_rm", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objQTRRM

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("sale_plan") = .sale_PLAN

-        dbRecordset("rm_id") = .rm_id

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objQTRRM.id = dbRecordset("id")

-

-End Sub

-

-Sub dbUpdate_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim Update_SQL As String

-    

-    With objQTRRM

-        Update_SQL = "UPDATE quarter_rm SET " & _

-            "entry_date='" & .entry_date & "'" & "," & _

-            "rm_id=" & .rm_id & "," & _

-            "sale_plan=" & .sale_PLAN & "," & _

-            " WHERE id=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if ent_date = % then all_records

-Function dbGetAll_QTRRM_Records(dbConnection As Object, all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    

-    Dim getCount_QTRRM_SQL As String

-    Dim getAll_QTRRM_SQL As String

-    Dim QTRRM_Count As Long

-    QTRRM_Count = 0

-    

-    getCount_QTRRM_SQL = "SELECT COUNT(*) AS QTRRM_TOTAL FROM quarter_rm WHERE entry_date like '" & ent_date & "'"

-    getAll_QTRRM_SQL = "SELECT * FROM quarter_rm WHERE entry_date like '" & ent_date & "' ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTRRM_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTRRM_Count = dbRecordset("QTRRM_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_QTRRM_Records = QTRRM_Count

-    

-    If QTRRM_Count > 0 Then

-        'we have records

-        ReDim all_QTRRM(1 To QTRRM_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTRRM_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTRRM As tQTRRM

-                 With tmp_QTRRM

-                    .entry_date = dbRecordset("entry_date")

-                    .rm_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .id = dbRecordset("id")

-                 End With

-                 

-                 all_QTRRM(index) = tmp_QTRRM

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM quarter_rm " & _

-    "WHERE id=" & objQTRRM.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-    

-    'delete related budget entries

-    MsgBox "remember delete related"

-'    dbDelete_BDGT_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Hir_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Ter_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_ACS_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-       

-End Sub

-

-

-<<<<<<
-======================
-REP_LIST
->>>>>>
-Attribute VB_Name = "REP_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentREP_ID() As Long

-    Dim r As Range

-

-    With Worksheets("REP_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CREP_ID)

-    End With

-

-    getCurrentREP_ID = r

-End Function

-

-Public Sub REP_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Rep_Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Rep_Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Rep_Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Rep_Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectREP_LPU(rep_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim r_id As Long

-    

-    Range("JUMP") = "LPU_LIST"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-        .Range("ent_date") = ent_date

-    End With

-End Sub

-

-Public Sub SelectREP_QTR(rep_id As Long)

-    Dim vo As Boolean

-    Dim r_id As Long

-    

-    Range("JUMP") = "REP_QTR"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("REP_QTR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateREPList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim rep_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CREP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CREP_AREA).row, CREP_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    rep_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CREP_AREA).Column

-    

-    If i < 4 Then

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 1

-    Else

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 2

-    End If

-    

-    If rep_id = 0 Then

-        Range("LAST_FOCUS") = Range(CREP_AREA).address

-    End If

-

-    If rep_id = 0 Then

-        i = CREP_NAME

-        Range("JUMP") = ""

-    Else

-        btREP_LIST_DO_IT

-    End If

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateREPList()

-    Dim rcd() As tREPID_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-

-    ent_date = getEnt_date

-

-    i = Get_REP_CommonList_by_QTR(rcd, ent_date)

-

-    With ThisWorkbook.Worksheets("REP_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(rcd)

-            r.Offset(i - 1, CREP_NAME) = rcd(i).rep.FirstName & " " & rcd(i).rep.LastName

-            r.Offset(i - 1, CREP_ID) = rcd(i).rep.rep_id

-            r.Offset(i - 1, CREP_BEDS) = rcd(i).qtrs(1).c_beds

-

-            r.Offset(i - 1, CREP_NFG) = rcd(i).qtrs(1).c_bdgt_NFG

-            r.Offset(i - 1, CREP_NMG) = rcd(i).qtrs(1).c_bdgt_NMG

-

-            r.Offset(i - 1, CREP_PLAN) = rcd(i).qtrs(1).qtr.sale_PLAN

-

-            r.Offset(i - 1, CREP_HIR) = rcd(i).qtrs(1).c_pat_HIR

-            r.Offset(i - 1, CREP_TER) = rcd(i).qtrs(1).c_pat_TER

-            r.Offset(i - 1, CREP_CAR) = rcd(i).qtrs(1).c_pat_CRD

-            r.Offset(i - 1, CREP_FACT) = rcd(i).qtrs(1).c_sale_ALL

-            r.Offset(i - 1, CREP_PAT_LPU) = rcd(i).qtrs(1).c_pat_LPU

-            r.Offset(i - 1, CREP_BDGT) = rcd(i).qtrs(1).c_bdgt_LPU

-            If rcd(i).qtrs(1).c_bdgt_LPU > 0 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = rcd(i).qtrs(1).c_sale_ALL / rcd(i).qtrs(1).c_bdgt_LPU

-            End If

-            If r.Offset(i - 1, CREP_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-

-

-<<<<<<
-======================
-mREP_LIST
->>>>>>
-Attribute VB_Name = "mREP_LIST"

-Option Explicit

-

-Public Const CREP_AREA As String = "B12"

-Public Const CREP_NAME As Integer = 0

-Public Const CREP_NAME1 As Integer = 1

-Public Const CREP_NAME2 As Integer = 2

-Public Const CREP_ID As Integer = 3

-Public Const CREP_BEDS As Integer = 4

-Public Const CREP_NFG As Integer = 5

-Public Const CREP_NMG As Integer = 6

-Public Const CREP_HIR As Integer = 7

-Public Const CREP_TER As Integer = 8

-Public Const CREP_CAR As Integer = 9

-Public Const CREP_FACT As Integer = 10

-Public Const CREP_PLAN As Integer = 11

-Public Const CREP_PAT_LPU As Integer = 16

-Public Const CREP_BDGT As Integer = 17

-Public Const CREP_PAT_ALL As Integer = 16

-

-

-

-Sub EditREP(cRep As tREPID, ent_date As String)

-    NoFunc

-End Sub

-

-Sub Rep_Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btREP_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = "RM_QTR"

-    End With

-    ThisWorkbook.Worksheets("RM_QTR").Activate

-End Sub

-

-

-Sub btREP_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim rep_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("REP_LST_DETALS")

-    With Worksheets("REP_LIST")

-        rep_id = .getCurrentREP_ID

-        

-        Select Case i

-            Case 1:

-                .SelectREP_QTR rep_id

-            Case 2:

-                ent_date = .getEnt_date()

-                .SelectREP_LPU rep_id, ent_date

-        End Select

-    End With

-    

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-

-

-

-<<<<<<
-======================
-cdbREP
->>>>>>
-Attribute VB_Name = "cdbREP"

-Option Explicit

-

-Public Type tREPID_COMMON

-    rep As tREPID

-    i_qtrs As Integer

-    qtrs() As tQTR_COMMON

-End Type

-

-Function Get_REP_CommonList_by_QTR(ByRef rcd() As tREPID_COMMON, ent_date As String) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_REP_CommonList_by_QTR = dbGet_REP_CommonList_by_QTR(dbConnection, rcd, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_REP_CommonList_by_QTR(dbConnection As Object, ByRef rcd() As tREPID_COMMON, ent_date As String) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim k As Long

-    Dim allREPID() As tREPID

-    

-    i = dbGetAll_REPID_Records_by_QTR(dbConnection, allREPID, ent_date)

-    dbGet_REP_CommonList_by_QTR = i

-    If i > 0 Then

-        ReDim rcd(i)

-        For i = 1 To UBound(allREPID)

-            rcd(i).rep = allREPID(i)

-            rcd(i).i_qtrs = Get_QTR_CommonList_by_REP(rcd(i).qtrs, ent_date, allREPID(i).rep_id)

-        Next i

-    End If

-End Function

-

-

-

-<<<<<<
-======================
-CHRT_PAT_LPU_A
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU_A"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-cdbRegion
->>>>>>
-Attribute VB_Name = "cdbRegion"

-Option Explicit

-

-Type tREGION

-    ent_date As String

-    total_SALE As Long ' общий объем продаж

-    total_BDGT As Long ' бюджет всех ЛПУ

-    total_BDGT_NMG As Long ' бюджет всех ЛПУ на НМГ

-    total_LPU As Long ' число ЛПУ

-    total_REP   As Long ' число репов

-    total_BEDS As Long ' общее число коек

-    total_HIR As Long '  общее число пациентов на клексане в хирургии

-    total_TER As Long '  общее число пациентов на клексане в терапии

-    total_ACS As Long '  общее число пациентов на клексане в кардиологии

-    sale_PLAN As Long '  план продаж Авентиса

-End Type

-

-Function GetRGN_COMM_DATA(ByRef reg_data() As tREGION) As Integer

-    Dim q_date() As String

-    Dim q_count As Integer, i As Integer

-    

-    q_count = getAllQTRNames(q_date)

-    If q_count > 0 Then

-        ReDim reg_data(q_count)

-        For i = 1 To q_count

-            Dim current_rep_count As Integer

-            current_rep_count = getREGION_by_QTR(q_date(i), reg_data(i))

-        Next i

-    End If

-    

-    GetRGN_COMM_DATA = q_count

-End Function

-

-Function getAllQTRNames(ByRef qtr_lst() As String) As Integer

-    

-    Dim sql As String

-    Dim i As Integer

-    Dim db As Object, rs As Object

-    

-    

-    sql = "SELECT DISTINCT entry_date FROM lpu_budget"

-    i = 0

-    

-    dbOpenConnection db

-    Set rs = CreateObject("ADODB.Recordset")

-    

-    rs.Open sql, db

-        

-        If Not rs.BOF Then

-            Do While Not rs.EOF

-                i = i + 1

-                ReDim Preserve qtr_lst(i)

-                qtr_lst(i) = rs("entry_date")

-                rs.MoveNext

-            Loop

-        Else

-            getAllQTRNames = 0

-            Exit Function

-        End If

-    getAllQTRNames = i

-    dbCloseConnection db

-End Function

-

-Function getREGION_by_QTR(ent_date As String, treg As tREGION) As Integer

-    Dim rep_count As Integer

-    rep_count = 0

-    

-    Dim reps() As tREPID_COMMON

-    rep_count = Get_REP_CommonList_by_QTR(reps, ent_date)

-    

-    treg.ent_date = ent_date

-    treg.total_BDGT = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.total_BDGT_NMG = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.sale_PLAN = 0 ' quarter.sale_plan

-    treg.total_SALE = 0 'summ of

-    ' hir = (amb40+st40)*pr40 + (amb20+st20)*pr20

-    'ter (amb_clx+stat_clx)*price

-    ' acs xxx

-    'price per rep

-    treg.total_HIR = 0 'patiens clxn

-    treg.total_TER = 0 'patiens clxn

-    treg.total_ACS = 0 'patiens clxn

-    treg.total_LPU = 0 'lpu

-    treg.total_BEDS = 0 'lpu.beds

-    treg.total_REP = 0 '

-    

-    If rep_count > 0 Then

-        Dim i As Integer

-        

-        For i = 1 To UBound(reps)

-            ' current rep is reps(i)

-            With reps(i)

-                treg.total_BDGT = treg.total_BDGT + .qtrs(1).c_bdgt_NFG + .qtrs(1).c_bdgt_NMG

-                treg.total_BDGT_NMG = treg.total_BDGT_NMG + .qtrs(1).c_bdgt_NMG

-                treg.sale_PLAN = treg.sale_PLAN + .qtrs(1).c_sale_PLAN

-                treg.total_SALE = treg.total_SALE + .qtrs(1).c_sale_ALL

-                treg.total_HIR = treg.total_HIR + .qtrs(1).c_pat_HIR

-                treg.total_TER = treg.total_TER + .qtrs(1).c_pat_TER

-                treg.total_ACS = treg.total_ACS + .qtrs(1).c_pat_CRD

-                treg.total_LPU = treg.total_LPU + .qtrs(1).i_lcd

-                treg.total_BEDS = treg.total_BEDS + .qtrs(1).c_beds

-                treg.total_REP = treg.total_REP + 1

-            End With

-            

-        Next i

-        

-    End If

-    

-    getREGION_by_QTR = treg.total_REP

-End Function

-

-<<<<<<
-======================
-mRM_QTR
->>>>>>
-Attribute VB_Name = "mRM_QTR"

-Option Explicit

-

-Sub btRM_QTR_Do_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    

-    idx = Worksheets(VAR_SHEET).Range("RM_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            ImportData

-        Case 2

-            Worksheets("REP_LIST").Select

-        Case 3

-            cmExport

-    End Select

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-End Sub

-

-Sub ImportData()

-    Dim i As Integer

-    Dim def_dir As String

-    Dim flist() As String

-    

-    def_dir = GetWBPath(ThisWorkbook.FullName)

-    If GetImportDirectory(def_dir, flist) Then

-        Dim ImpMask() As String

-        ImpMask = Split(flist(1), Chr(95), Compare:=vbBinaryCompare)

-        flist(1) = ImpMask(0) & "*"

-        Dim db_list() As String

-        i = GetDBList(flist(), db_list)

-        If i > 0 Then

-            Merge_BackUp_All_Data

-            MergeGlobal db_list, GetWBPath(ThisWorkbook.FullName) & "clexane-rm.mdb"

-        End If

-    End If

-    Worksheets(RM_QTR_SHEET).update_history

-End Sub

-<<<<<<
-======================
-mImport
->>>>>>
-Attribute VB_Name = "mImport"

-    Option Explicit

-

-Const OFN_ALLOWMULTISELECT As Long = 512

-Const OFN_EXPLORER As Long = 524288

-Const OFN_HIDEREADONLY As Long = 4

-Const OFN_NONETWORKBUTTON As Long = 131072

-Const OFN_READONLY As Long = 1

-       

-Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _

-    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

-

-Private Type OPENFILENAME

-    lStructSize As Long

-    hWndOwner As Long

-    hInstance As Long

-    lpstrFilter As String

-    lpstrCustomFilter As String

-    nMaxCustFilter As Long

-    nFilterIndex As Long

-    lpstrFile As String

-    nMaxFile As Long

-    lpstrFileTitle As String

-    nMaxFileTitle As Long

-    lpstrInitialDir As String

-    lpstrTitle As String

-    flags As Long

-    nFileOffset As Integer

-    nFileExtension As Integer

-    lpstrDefExt As String

-    lCustData As Long

-    lpfnHook As Long

-    lpTemplateName As String

-End Type

-

-Function GetImportDirectory(DB_dir As String, flist() As String) As Boolean

-    Dim OpenFile As OPENFILENAME

-    Dim lReturn As Long

-    Dim sFilter As String

-    

-    OpenFile.lStructSize = Len(OpenFile)

-    '         OpenFile.hwndOwner = Form1.hWnd

-    '         OpenFile.hInstance = App.hInstance

-    sFilter = "Clexane Data Files" & Chr(0) & "mr*.mdb" & Chr(0)

-    OpenFile.lpstrFilter = sFilter

-    OpenFile.nFilterIndex = 1

-    OpenFile.lpstrFile = String(257, 0)

-    OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1

-    OpenFile.lpstrFileTitle = OpenFile.lpstrFile

-    OpenFile.nMaxFileTitle = OpenFile.nMaxFile

-    OpenFile.lpstrInitialDir = DB_dir

-    OpenFile.lpstrTitle = "Импорт данных"

-    OpenFile.flags = OFN_HIDEREADONLY + OFN_EXPLORER

-    lReturn = GetOpenFileName(OpenFile)

-    If lReturn = 0 Then

-        GetImportDirectory = False

-    Else

-        GetImportDirectory = True

-        flist = Split(OpenFile.lpstrFile, Chr(0), Compare:=vbBinaryCompare)

-        Dim i As Integer

-        i = 0

-        Do While flist(i) <> ""

-            i = i + 1

-        Loop

-        If i = 1 Then

-            flist(1) = flist(0)

-            flist(0) = GetWBPath(flist(1))

-            flist(1) = GetWBName(flist(1))

-        Else

-            flist(0) = flist(0) & "\"

-        End If

-    End If

-End Function

-<<<<<<
-Project Name : 'ClexaneMR'
-Quirk - duff tag length======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).ClearRepName

-    

-    Application.EnableEvents = True

-    Set MyAppEvents.app = Application

-    

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    

-    MyAppEvents.CheckWorkBooksArround ThisWorkbook

-    

-    cmSetStandaloneMode

-    

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-    

-    Application.ScreenUpdating = True

-    

-    If CheckUser Then

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-        ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-        ThisWorkbook.Worksheets(REP_QTR_SHEET).update_history

-        Application.Calculate

-    End If

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    

-    Dim RestMode As Boolean

-    RestMode = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE")

-    

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-'        If RestMode Then

-            ThisWorkbook.Saved = True

-'        Else

-'            ThisWorkbook.Save

-'        End If

-    End If

-    If RestMode Then

-        xlRestoreView

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    End If

-    Application.Caption = Empty

-    Application.CommandBars(STDBAR_NAME).Reset

-    

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-    Dim MaxX, MaxY As Integer

-    With ThisWorkbook.Worksheets(REP_QTR_SHEET)

-        MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-        MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-    End With

-

-    With ThisWorkbook.Application

-        .ScreenUpdating = False

-        .WindowState = xlNormal

-        .Height = MaxY

-        .Width = MaxX

-    End With

-End Sub

-

-

-

-

-

-<<<<<<
-======================
-REP_QTR
->>>>>>
-Attribute VB_Name = "REP_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CQTR_QT As Integer = 0

-Const CQTR_ID As Integer = 1

-Const CQTR_PLN As Integer = 2

-Const CQTR_FCT As Integer = 3

-Const CQTR_BDG As Integer = 4

-Const CQTR_CNT As Integer = 5

-Const CQTR_BEDS As Integer = 6

-Const CQTR_HIR As Integer = 7

-Const CQTR_TER As Integer = 8

-Const CQTR_CRD As Integer = 9

-Const CQTR_CLXN_BDG As Integer = 10

-Const CQTR_CLXN_NMG As Integer = 11

-Const CQTR_PAT_ALL As Integer = 16

-Const CQTR_BDGT_ALL As Integer = 17

-

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub ClearRepName()

-    Unprotect

-    Range("D4") = ""

-    Range("D5") = ""

-    Range("H4") = ""

-    Range("H5") = ""

-End Sub

-

-Sub update_history()

-    Dim objQTR() As tQTR

-    Dim i As Long

-    Dim r As Range

-    Dim cRep As tREP

-    

-    cRep = GetREPRecord

-    Range("D4") = cRep.LastName

-    Range("D5") = cRep.FirstName

-    

-    Range("H4") = GetRegionName(cRep.Region)

-    Range("H5") = GetCityName(cRep.Region, cRep.City)

-    

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    i = GetAll_QTR_Records(objQTR, "%")

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CQTR_QT) = objQTR(i).entry_date

-        Next i

-    End If

-    Dim qcd() As tQTR_COMMON

-    i = Get_QTR_CommonList(qcd)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(qcd)

-            r.Offset(i - 1, CQTR_QT) = qcd(i).qtr.entry_date

-            r.Offset(i - 1, CQTR_ID) = qcd(i).qtr.id

-            r.Offset(i - 1, CQTR_PLN) = qcd(i).qtr.sale_plan

-            r.Offset(i - 1, CQTR_FCT) = qcd(i).c_sale_ALL

-            r.Offset(i - 1, CQTR_BDG) = qcd(i).c_bdgt_LPU

-            r.Offset(i - 1, CQTR_CNT) = qcd(i).i_lcd

-            r.Offset(i - 1, CQTR_BEDS) = qcd(i).c_beds

-            r.Offset(i - 1, CQTR_HIR) = qcd(i).c_pat_HIR

-            r.Offset(i - 1, CQTR_TER) = qcd(i).c_pat_TER

-            r.Offset(i - 1, CQTR_CRD) = qcd(i).c_pat_CRD

-            If qcd(i).c_bdgt_LPU <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_BDG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_LPU

-            End If

-            If qcd(i).c_bdgt_NMG <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_NMG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_BBL_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-

-End Sub

-

-Sub Draw_PAT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CQTR_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRepQtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-

-Private Sub Worksheet_Activate()

-  

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-    

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.Count > 1 And r_sel.Columns.Count < CRow_Width Or r_sel.Rows.Count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.Count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.Count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.Count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CQTR_ID + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    i = currRange.Column - Range(CINP_AREA).Column

-    

-    QTR_ID = r

-

-    If QTR_ID = 0 Then

-        Worksheets(VAR_SHEET).Range("USER_ACTION") = 1

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        If i > CQTR_FCT Then

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-            Range("LAST_FOCUS") = currRange.address

-        Else

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 3

-            Range("LAST_FOCUS") = currRange.address

-        End If

-    End If

-    Cancel = True

-    btHomeDo_IT

-End Sub

-

-<<<<<<
-======================
-mRep_QTR
->>>>>>
-Attribute VB_Name = "mRep_QTR"

-Option Explicit

-

-Sub DO_New_qtr()

-    Dim res As Variant

-    Dim objQTR As tQTR

-    Dim s As String

-    s = GetLastQtr

-    objQTR.entry_date = GetNextQTR(s)

-    

-    If objQTR.entry_date = "" Then

-        Exit Sub

-    End If

-    

-    DO_Price_qtr objQTR.entry_date

-

-End Sub

-

-Sub DO_Price_qtr(ent_date As String)

-    If ent_date = "" Then

-        DO_New_qtr

-    Else

-        Dim qtr As tQTR

-        Dim res As Integer

-        

-        qtr = Get_QTR_Record(ent_date)

-        

-        If qtr.id = 0 Then

-            qtr.entry_date = ent_date

-    

-            With Worksheets(VAR_SHEET)

-                qtr.ClxnH20mg = .Range("ClxnH20mg")

-                qtr.ClxnH40mg = .Range("ClxnH40mg")

-                qtr.ClxnT40mg = .Range("ClxnT40mg")

-                qtr.ClxnC_ACS = .Range("ClxnC_ACS")

-                qtr.ClxnC_IM = .Range("ClxnC_IM")

-            End With

-        End If

-        

-        Dim dlg_nq As dlg_nextQTR

-        Set dlg_nq = New dlg_nextQTR

-        

-        With dlg_nq

-            .tb_qtr_name = qtr.entry_date

-            .tb_bdgt_avts = qtr.sale_plan

-            .tb_qtr_name = qtr.entry_date

-            .tb_ClxnH20mg = qtr.ClxnH20mg

-            .tb_ClxnH40mg = qtr.ClxnH40mg

-            .tb_ClxnT40mg = qtr.ClxnT40mg

-            .tb_ClxnC_ACS = qtr.ClxnC_ACS

-            .tb_ClxnC_IM = qtr.ClxnC_IM

-        End With

-        

-        dlg_nq.Show

-        res = dlg_nq.Tag

-        

-        If res = vbOK Then

-            With dlg_nq

-                If Not IsNumeric(.tb_bdgt_avts) Then

-                    MsgBox "Введите план продаж", vbOK, PROGRAM_NAME

-                Else

-                    If .tb_bdgt_avts = 0 Then

-                        MsgBox "Введите план продаж", vbOK, PROGRAM_NAME

-                        Exit Sub

-                    End If

-                End If

-                Dim bool As Boolean

-                bool = IsNumeric(.tb_ClxnH20mg) _

-                    And IsNumeric(.tb_ClxnH40mg) _

-                    And IsNumeric(.tb_ClxnT40mg) _

-                    And IsNumeric(.tb_ClxnC_ACS) _

-                    And IsNumeric(.tb_ClxnC_IM)

-                If Not bool Then

-                    MsgBox "Вводите правильно цыфры", vbOK, PROGRAM_NAME

-                    Exit Sub

-                End If

-                qtr.sale_plan = .tb_bdgt_avts

-                qtr.entry_date = .tb_qtr_name

-                qtr.ClxnH20mg = .tb_ClxnH20mg

-                qtr.ClxnH40mg = .tb_ClxnH40mg

-                qtr.ClxnT40mg = .tb_ClxnT40mg

-                qtr.ClxnC_ACS = .tb_ClxnC_ACS

-                qtr.ClxnC_IM = .tb_ClxnC_IM

-            End With

-            Insert_QTR_Record qtr

-        End If

-    End If

-End Sub

-

-Sub DO_Edit_qtr(ent_date As String)

-    If ent_date = "" Then

-        DO_New_qtr

-    Else

-        With ThisWorkbook.Worksheets("LPU_LIST")

-            .Range("VIEW_ONLY") = False

-            .Range("ent_date") = ent_date

-            .Select

-        End With

-    End If

-End Sub

-

-Sub DO_Delete_qtr(ent_date As String)

-    If ent_date <> "" Then

-        Dim i As Integer

-        i = MsgBox("Удалить данные за период [" & ent_date & "]?", vbDefaultButton2 + vbOKCancel, PROGRAM_NAME)

-        If i = vbOK Then

-            Dim objQTR As tQTR

-            If ent_date <> "" Then

-                objQTR.entry_date = ent_date

-                objQTR = Get_QTR_Record(ent_date)

-                Delete_QTR_Record objQTR

-                Worksheets(TITLE_SHEET).Select

-                Worksheets(REP_QTR_SHEET).Select

-            End If

-        End If

-    End If

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-

-Sub btHomeDo_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    idx = Worksheets(VAR_SHEET).Range("USER_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            DO_New_qtr

-            ' Обновляем экран

-        Case 2

-            DO_Edit_qtr ent_date

-        Case 3

-            DO_Price_qtr ent_date

-        Case 4

-            dbExport

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    End Select

-    If idx <> 2 Then

-        With ThisWorkbook

-            .Worksheets(TITLE_SHEET).Select

-            .Worksheets(REP_QTR_SHEET).Select

-        End With

-    End If

-End Sub

-

-Sub Delete_qtr()

-    Dim ent_date As String

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    DO_Delete_qtr ent_date

-End Sub

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane[MR]"

-Public Const PROGRAM_VERSION As String = "version 1.6"

-Public Const PROGRAM_FILENAME As String = "clexane-mr"

-Public Const PROGRAM_EXPORTNAME As String = "mr-ex-"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20030329

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "O40"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-End Sub

-

-Function Double2Str(ByVal d As Double, ByVal precision As Integer, Optional Delim As String = ".") As String

-    Dim s As String

-    If Not precision > 0 Then

-        s = Round(d)

-    Else

-        Dim i As Integer

-        i = Fix(d)

-        s = i & Delim

-        d = Abs(d - i)

-        Do

-            precision = precision - 1

-            d = d * 10

-            If precision > 0 Then

-                i = Fix(d)

-            Else

-                i = Round(d)

-            End If

-            If i < 1 Then

-                s = s & "0"

-            Else

-                s = s & i

-                d = d - i

-            End If

-        Loop While precision > 0

-    End If

-    Double2Str = s

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.Count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.name = VAR_SHEET Or sh.name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-<<<<<<
-======================
-Var
->>>>>>
-Attribute VB_Name = "Var"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-title
->>>>>>
-Attribute VB_Name = "title"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LPU_LIST
->>>>>>
-Attribute VB_Name = "LPU_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentLPU_ID() As Long

-    Dim r As Range

-    

-    With Worksheets("LPU_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CLPU_ID)

-    End With

-    

-    getCurrentLPU_ID = r

-End Function

-

-Public Sub LPU_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectLPU_NAME(lpu_id As Long, ent_date As String)

-    If Range("VIEW_ONLY") = True Then

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    Dim cLPU As tLPU

-    If lpu_id = 0 Then

-        cLPU.id = 0

-        cLPU.rep_id = 0

-        cLPU.address = ""

-        cLPU.name = ""

-    Else

-        cLPU = Get_LPU_Record(lpu_id)

-    End If

-    EditLPU cLPU, getEnt_date

-    Worksheet_Activate

-End Sub

-        

-Sub SelectLPU_BDGT(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    If lpu_id = 0 Then

-        SelectLPU_NAME lpu_id, ent_date

-    Else

-        With ThisWorkbook.Worksheets("LPU_BDGT")

-            .Range("VIEW_ONLY") = vo

-            .Range("ret_addr") = "LPU_LIST"

-            .Range("ent_date") = ent_date

-            .Range("lpu_id") = lpu_id

-        End With

-    End If

-End Sub

-

-Sub SelectLPU_HIR(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_CLSN_HIR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-                   

-Sub SelectLPU_TER(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_CLSN_TER")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-       

-Sub SelectLPU_C_ACS(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_CLSN_C_ACS")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateLPUList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.Count > 1 And r_sel.Columns.Count < CINP_WIDTH Or r_sel.Rows.Count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.Count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.Count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.Count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim lpu_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-    

-    ent_date = getEnt_date

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-    

-    Set r = Range(CINP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CINP_AREA).row, CLPU_ID)

-        

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-    

-    lpu_id = r

-    

-    i = Range(Range("LAST_FOCUS")).Column - Range(CINP_AREA).Column

-    

-    If lpu_id = 0 Then

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    End If

-    

-    If lpu_id = 0 Then

-        i = CLPU_NAME

-        Range("JUMP") = ""

-    End If

-    Select Case i

-        Case CLPU_NAME, CLPU_NAME1, CLPU_NAME2, CLPU_BEDS

-            SelectLPU_NAME lpu_id, ent_date

-            Range("JUMP") = ""

-

-        Case CLPU_NMG, CLPU_NFG, CLPU_PLAN, CLPU_FACT

-            SelectLPU_BDGT lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-            

-        Case CLPU_HIR

-            SelectLPU_HIR lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_HIR"

-        

-        Case CLPU_TER

-            SelectLPU_TER lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_TER"

-        

-        Case CLPU_CAR

-            SelectLPU_C_ACS lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_C_ACS"

-        

-        Case Else

-            Range("JUMP") = ""

-    End Select

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-    

-    is_input_range = INPUT_NO

-    

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateLPUList()

-    Dim lcd() As tLPU_COMMON

-    

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-    Dim objQTR As tQTR

-    Dim cRep As tREP

-    

-    ' ent_date = "%" ' % - all records

-    ent_date = getEnt_date

-    

-    objQTR = Get_QTR_Record(ent_date)

-    i = Get_LPU_CommonQTR(lcd, objQTR)

-     

-    ' стираем ФИО

-    Range("C3:C4").ClearContents

-    cRep = GetREPRecord

-    

-    Range("C3") = cRep.LastName

-    Range("C4") = cRep.FirstName

-    Range("G3") = GetRegionName(cRep.Region)

-    Range("G4") = GetCityName(cRep.Region, cRep.City)

-    Range("G5") = objQTR.sale_plan

-    

-

-    

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-        

-        For i = 1 To UBound(lcd)

-            r.Offset(i - 1, CLPU_NAME) = lcd(i).lpu.name

-            r.Offset(i - 1, CLPU_ID) = lcd(i).lpu.id

-            r.Offset(i - 1, CLPU_BEDS) = lcd(i).lpu.beds

-            

-         

-            r.Offset(i - 1, CLPU_NFG) = lcd(i).bdgt.bdgt_NFG

-            r.Offset(i - 1, CLPU_NMG) = lcd(i).bdgt.bdgt_NMG

-            r.Offset(i - 1, CLPU_PLAN) = lcd(i).bdgt.sale_plan

-            

-            r.Offset(i - 1, CLPU_HIR) = lcd(i).pat_HIR

-            r.Offset(i - 1, CLPU_TER) = lcd(i).pat_TER

-            r.Offset(i - 1, CLPU_CAR) = lcd(i).pat_CRD

-            r.Offset(i - 1, CLPU_FACT) = lcd(i).sale_ALL

-            r.Offset(i - 1, CLPU_PAT_LPU) = lcd(i).pat_LPU

-            r.Offset(i - 1, CLPU_BDGT) = lcd(i).bdgt_LPU

-            If lcd(i).bdgt_LPU > 0 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = lcd(i).sale_ALL / lcd(i).bdgt_LPU

-            End If

-            If r.Offset(i - 1, CLPU_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = 1

-            End If

-            

-        Next i

-    End If

-End Sub

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{566B33D6-957A-43E4-8444-D8EA3889700C}{42EE65B8-F8C6-4F95-9F52-7738BF6FCEAD}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-dbACS
->>>>>>
-Attribute VB_Name = "dbACS"

-Option Explicit

-

-Public Type tACS

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    patients_with_geparins As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objACS.ID <> 0 then updatre else insert

-Sub Insert_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objACS.id <> 0 Then

-        dbUpdate_ACS_Record dbConnection, objACS

-    Else

-        dbInsert_ACS_Record dbConnection, objACS

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_ACS_RecordsByLPU_ID(ByRef all_ACS_() As tACS, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_ACS_RecordsByLPU_ID = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, all_ACS_, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_ACS_Record dbConnection, objACS

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub dbInsert_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_acs", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objACS

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("patients_with_geparins") = .patients_with_geparins

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objACS.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim Update_SQL As String

-    

-    With objACS

-        Update_SQL = "UPDATE lpu_acs SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "patients_with_geparins=" & .patients_with_geparins & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_ACS_RecordsbyLPU_ID(dbConnection As Object, all_ACS() As tACS, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_ACS_SQL As String

-    Dim getAll_ACS_SQL As String

-    Dim ACS_Count As Long

-    ACS_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_ACS_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        ACS_Count = dbRecordset("ACS_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_ACS_RecordsbyLPU_ID = ACS_Count

-    

-    If ACS_Count > 0 Then

-        'we have records

-        ReDim all_ACS(1 To ACS_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_ACS_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_ACS As tACS

-                 With tmp_ACS

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .patients_with_geparins = dbRecordset("patients_with_geparins")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 all_ACS(index) = tmp_ACS

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE ID=" & objACS.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_ACS_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_HIR
->>>>>>
-Attribute VB_Name = "LPU_CLSN_HIR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-    

-        Dim objHir As tHIRURGIA

-        

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objHir

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .operations_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L9")

-                .patients_ambulator_clexan_20mg = Range("L10")

-                .patients_ambulator_clexan_40mg = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L19")

-                .patients_stationar_clexan_20mg = Range("L20")

-                .patients_stationar_clexan_40mg = Range("L21")

-            End With

-            Insert_Hir_Record objHir

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objHir.id = Range("rec_id")

-                    If objHir.id <> 0 Then

-                        Delete_Hir_Record objHir

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objHir As tHIRURGIA)

-    Dim qtr As tQTR

-    Dim formula As String

-

-    With objHir

-        Range("rec_id") = .id

-        Range("F6") = .operations_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L9") = .patients_ambulator_clexan

-        Range("L10") = .patients_ambulator_clexan_20mg

-        Range("I21") = .patients_stationar_nmg

-        Range("L19") = .patients_stationar_clexan

-        Range("L20") = .patients_stationar_clexan_20mg

-        

-        qtr = Get_QTR_Record(.entry_date)

-        formula = "=" & qtr.ClxnH20mg & "*($L$10+$L$20)+" & qtr.ClxnH40mg & "*($L$11+$L$21)"

-        Range("F11").formula = formula

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-    

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Range("h_DepFlag") = False

-    

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objHir() As tHIRURGIA

-        Dim i As Integer

-        i = GetAll_Hir_RecordsByLPU_ID(objHir, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.3

-        Else

-            SetupData objHir(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-mSapes
->>>>>>
-Attribute VB_Name = "mSapes"

-Option Explicit

-

-Const SHAPE_COLOR As Integer = 1

-Const SHAPE_NAME As Integer = 2

-

-

-Sub ShapeView(r_sh_finite_state As Range)

-    Dim chk As Range

-    Dim s As String

-    Dim c, idx As Integer

-    For Each chk In r_sh_finite_state

-        idx = 0

-        If chk = "+" Then

-            c = chk.Offset(0, idx + SHAPE_COLOR)

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While c <> 0

-                ShapeFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s)), c

-                idx = idx + 2

-                c = chk.Offset(0, idx + SHAPE_COLOR)

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        Else

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While s <> ""

-                ShapeUnFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s))

-                idx = idx + 2

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        End If

-    Next chk

-End Sub

-

-Sub ShapeFill(sh As ShapeRange, ByVal color As Integer)

-    sh.Fill.Visible = msoTrue

-    sh.Fill.Solid

-    sh.Fill.ForeColor.SchemeColor = color

-    sh.Fill.Transparency = 0#

-End Sub

-

-Sub ShapeUnFill(sh As ShapeRange)

-    sh.Fill.Visible = msoFalse

-    sh.Fill.Transparency = 0#

-End Sub

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Public Const INPUT_NO = 0

-Public Const INPUT_NUMBER = 1

-Public Const INPUT_PERCENT = 2

-Public Const INPUT_STRING = 3

-Public Const INPUT_CHECK = 4

-

-Public Const INP_IDX_TYPE = 1

-Public Const INP_IDX_NEXT = 2

-Public Const INP_IDX_MIN = 3

-Public Const INP_IDX_MAX = 4

-Public Const INP_IDX_DEP = 5

-Public Const INP_IDX_ALT = 7

-

-

-Public Type tInputSet

-    vType As Integer

-    vMin As Long

-    vMax As Long

-    rChk As String

-End Type

-

-Function is_input_cell(ByVal Target As Range, inputs As Range) As tInputSet

-    Dim t As Range

-    Dim iset As tInputSet

-    Dim test As Range

-    iset.vType = INPUT_NO

-    iset.vMin = 0

-    iset.vMax = 0

-    iset.rChk = ""

-    is_input_cell = iset

-

-' Закоментировать следующую сточку для работы

-'  Exit Function

-

-    Set test = Target.Cells(1, 1)

-    For Each t In inputs

-        If Range(t).Column = test.Column And Range(t).row = test.row Then

-            iset.vType = t.Offset(0, INP_IDX_TYPE).Value

-            Select Case iset.vType

-                Case INPUT_CHECK

-                    iset.rChk = t.Offset(0, INP_IDX_ALT)

-                Case INPUT_NUMBER, INPUT_PERCENT

-                    iset.vMin = t.Offset(0, INP_IDX_MIN).Value

-                    iset.vMax = t.Offset(0, INP_IDX_MAX).Value

-            End Select

-            is_input_cell = iset

-            Exit Function

-        End If

-    Next t

-End Function

-

-Function GetFocusAddress(ByVal r As Range, f_next As Range) As String

-    Dim chk, t As Range

-    

-    For Each chk In f_next

-        For Each t In r

-            If t.address = chk Then

-                GetFocusAddress = chk

-                Exit Function

-            End If

-            If Range(chk).Column = t.Column - 1 And Range(chk).row = t.row _

-            Or Range(chk).Column = t.Column And Range(chk).row = t.row - 1 _

-            Then

-                If Range(chk) <> "" Then

-                    If Range(chk) = 0 Then

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_ALT)).address

-                    Else

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_NEXT)).address

-                    End If

-                Else

-                    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-                End If

-                Exit Function

-            End If

-        Next t

-    Next chk

-    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-End Function

-

-Sub SetDependet(r As Range, inputs As Range)

-    Dim chk As Range

-    Dim s, serr As String

-    Dim idx As Integer

-    Dim iset As tInputSet

-    Dim err_found As Boolean

-    

-    If r.Count > 1 Then

-        Exit Sub

-    End If

-    

-    err_found = False

-    For Each chk In inputs

-        idx = INP_IDX_DEP

-        

-        

-        iset.vType = chk.Offset(0, INP_IDX_TYPE).Value

-        Select Case iset.vType

-            Case INPUT_NUMBER, INPUT_PERCENT

-                iset.vMin = chk.Offset(0, INP_IDX_MIN).Value

-                iset.vMax = chk.Offset(0, INP_IDX_MAX).Value

-                

-                If Range(chk) > iset.vMax Then

-                    err_found = True

-                    Range(chk) = iset.vMax

-                    serr = "Выход за дозволенный диапазон [" & iset.vMin & ".." & iset.vMax & "]! Данные скорректированы."

-                End If

-                

-                If Range(chk) = "" Then

-                    s = chk.Offset(0, idx)

-                    Do While s <> ""

-                        Range(s) = ""

-                        idx = idx + 1

-                        s = chk.Offset(0, idx)

-                    Loop

-                End If

-        End Select

-    Next chk

-    If err_found Then

-        MsgBox serr, vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Function CheckInputData(inputs As Range) As Boolean

-    Dim r As Range

-    

-    CheckInputData = True

-    For Each r In inputs

-        If Range(r) = "" Then

-            CheckInputData = False

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100.", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Sub Check_Int_Number(Target As Range, Def_Val As Long)

-    Dim err As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    err = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                err = True

-            End If

-        End If

-    Next r

-    If err Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_TER
->>>>>>
-Attribute VB_Name = "LPU_CLSN_TER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim objTer As tTERAPIA

-        

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objTer

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .patients_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L20")

-            End With

-            Insert_Ter_Record objTer

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objTer.id = Range("rec_id")

-                    If objTer.id <> 0 Then

-                        Delete_Ter_Record objTer

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objTer As tTERAPIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    With objTer

-        Range("rec_id") = .id

-        Range("F6") = .patients_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L11") = .patients_ambulator_clexan

-        Range("I21") = .patients_stationar_nmg

-        Range("L20") = .patients_stationar_clexan

-        

-        qtr = Get_QTR_Record(.entry_date)

-        formula = "=" & qtr.ClxnT40mg & "*($L$12+$L$20)"

-        Range("F11").formula = formula

-        

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-    

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Range("h_DepFlag") = False

-    

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objTer() As tTERAPIA

-        Dim i As Integer

-        i = GetAll_Ter_RecordsByLPU_ID(objTer, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.25

-        Else

-            SetupData objTer(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-    

-    Dim s As String

-    Dim iset As tInputSet

-    

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    

-    Select Case iset.vType

-        Case INPUT_NO

-        

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-            

-            Application.ScreenUpdating = False

-            

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-            

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-        

-        Case INPUT_STRING

-        

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{EBA94131-180E-4709-A2A3-B60D48987620}{47A860A1-BF92-4EBB-A333-AB7E83FAB868}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-LPU_BDGT
->>>>>>
-Attribute VB_Name = "LPU_BDGT"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub SetDefFocus()

-    Range(Range("DEF_FOCUS")).Select

-End Sub

-

-Public Sub ClearData()

-    ClearSheetData

-End Sub

-

-Sub ClearSheetData()

-    If Range("F10") = 0 And Range("F13") = 0 Then

-        Range("F11:F18") = ""

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("F11:F13") = ""

-    End If

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim bdgt As tBUDGET

-        Dim sum As Long

-        Dim test As Boolean

-        With bdgt

-            .lpu_id = Range("lpu_id")

-            .id = Range("rec_id")

-            .entry_date = Range("ent_date")

-            .bdgt_NMG = Round(Range("F11").Value, 0)

-            .bdgt_NFG = Round(Range("F12").Value, 0)

-            .sale_plan = Round(Range("F13").Value, 0)

-            

-            sum = .bdgt_NFG + .bdgt_NMG - .sale_plan

-            test = .bdgt_NFG <> 0 Or .bdgt_NMG <> 0 Or .sale_plan <> 0

-        End With

-        If test Then

-            If sum < 0 Then

-                MsgBox _

-                    "Ваш план превышает выделенный на гепарины бюджет. Сохранить данные?", _

-                    vbOKOnly, PROGRAM_NAME

-            End If

-            If test Then

-                Insert_BDGT_Record bdgt

-            End If

-        Else

-            If bdgt.id <> 0 Then

-                If vbYes = MsgBox("Сохранить нулевые значения?", vbYesNo, PROGRAM_NAME) Then

-                    Insert_BDGT_Record bdgt

-                End If

-                ret_back Range("DEF_FOCUS").Worksheet

-                Exit Sub

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-    End If

-    

-   ClearData

-   ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(cLPU As tLPU_COMMON)

-    Dim t_sum As Long

-    t_sum = 0

-' Setup budget data

-    Range("F11") = cLPU.bdgt.bdgt_NMG

-    Range("F12") = cLPU.bdgt.bdgt_NFG

-    Range("F13") = cLPU.bdgt.sale_plan

-    

-    With cLPU

-        Range("F14") = .pat_ALL

-        Range("F15") = .pat_HIR

-        Range("F16") = .pat_TER

-        Range("F17") = .pat_CRD

-        Range("F18") = .sale_ALL

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    ws_activate

-End Sub

-

-

-Sub ws_activate()

-    Dim cLPU As tLPU_COMMON

-    Dim objQTR As tQTR

-    Dim objLPU As tLPU

-    Dim ent_date As String

-    Dim id As Long

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    id = Range("lpu_id").Value

-    ent_date = Range("ent_date")

-    objQTR = Get_QTR_Record(ent_date)

-    objLPU = Get_LPU_Record(id)

-    Get_LPU_Common cLPU, objLPU, objQTR

-    

-    If cLPU.lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = cLPU.lpu.beds

-        Range("lpu_name") = cLPU.lpu.name

-        Range("lpu_addr") = cLPU.lpu.address

-        Range("rec_id") = cLPU.bdgt.id

-        

-        SetupData cLPU

-        

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-'    MsgBox Target.address

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Dim s As String

-    Dim iset As tInputSet

-    

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    

-    Select Case iset.vType

-        Case INPUT_NO

-        

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-            

-        Case INPUT_PERCENT

-        

-        Case INPUT_STRING

-        

-        Case INPUT_CHECK

-            

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{E3F10C5A-A4B4-42FF-A2C9-6F8198210A07}{563D0F3D-F79D-48F1-AFE4-A2136809B982}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mSheets
->>>>>>
-Attribute VB_Name = "mSheets"

-Option Explicit

-

-Function am_load_now() As Boolean

-    am_load_now = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE")

-End Function

-

-Sub Wks_select(RetSheet As String)

-    Dim sheet As Worksheet

-    For Each sheet In ThisWorkbook.Worksheets

-        If sheet.name = RetSheet Then

-            ThisWorkbook.Worksheets(RetSheet).Select

-            Exit Sub

-        End If

-    Next sheet

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub ret_back(sh As Worksheet)

-    Dim RetSheet As String

-    RetSheet = sh.Range("ret_addr")

-    sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    sh.Range("ret_addr") = ""

-    sh.Range("rec_id") = ""

-    sh.Range("lpu_id") = ""

-    sh.Range("ent_date") = ""

-    sh.Range("lpu_name") = ""

-    sh.Range("lpu_addr") = ""

-    sh.Range("lpu_beds") = ""

-    Wks_select RetSheet

-End Sub

-

-Sub ClearSheetData(r_start As Range)

-    If r_start <> "" Then

-        r_start.Worksheet.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        r_start = ""

-    Else

-        ret_back r_start.Worksheet

-    End If

-End Sub

-

-Sub wks_sel_chng(iset As tInputSet, ByVal Target As Range, sh As Worksheet)

-    Dim DebugMode As Boolean

-    Dim in_range As Range

-    

-    DebugMode = Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-

-    If DebugMode Then

-        sh.Unprotect

-    Else

-        sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    End If

-

-    If iset.vType = INPUT_CHECK Then

-        Set in_range = Target.Worksheet.Range(iset.rChk)

-    Else

-        Set in_range = Target

-    End If

-    

-    Dim str As String

-    str = GetFocusAddress(in_range, sh.Range("h_inputs"))

-

-'    MsgBox Target.Address & "; " & str

-    If str <> Target.address Then

-        sh.Range(str).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-Dlg_lpu_card
->>>>>>
-Attribute VB_Name = "Dlg_lpu_card"

-Attribute VB_Base = "0{137EDDE5-3DB4-4BAD-A245-324DC31ABB36}{3BD7159A-BF6C-403F-B3DF-4834FA9E4D92}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbLPU_List_Change()

-    Dim src As Range

-    Dim idx_src As Integer

-    

-    Set src = Worksheets(VAR_SHEET).Range(Me.cbLPU_List.RowSource)

-    idx_src = Me.cbLPU_List.ListIndex + 1

-    Me.tb_lpu_name.Text = src.Cells(idx_src, 1)

-    Me.tb_lpu_address.Text = src.Cells(idx_src, 2)

-    Me.tbBedsCount.Text = src.Cells(idx_src, 3)

-End Sub

-

-

-Private Sub cbxLPU_List_Enable_Click()

-    

-    If Me.cbxLPU_List_Enable Then

-        

-        Me.tb_lpu_name.Text = ""

-        Me.tb_lpu_name.Enabled = False

-        

-        Me.tb_lpu_address.Text = ""

-        Me.tb_lpu_address.Enabled = False

-        

-        Me.tbBedsCount.Text = ""

-        Me.tbBedsCount.Enabled = False

-        

-        Me.cbLPU_List.Enabled = True

-        cbLPU_List_Change

-    Else

-        Me.tb_lpu_name.Enabled = True

-        Me.tb_lpu_name.Text = ""

-        

-        Me.tb_lpu_address.Enabled = True

-        Me.tb_lpu_address.Text = ""

-        

-        Me.tbBedsCount.Enabled = True

-        Me.tbBedsCount.Text = ""

-        

-        Me.cbLPU_List.Enabled = False

-    End If

-End Sub

-

-<<<<<<
-======================
-UserInfo
->>>>>>
-Attribute VB_Name = "UserInfo"

-Attribute VB_Base = "0{8EB80D4C-3476-421A-A370-6332A07DE509}{A7542905-C9F8-4F39-AD67-B62A88F8F4E6}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Tag = vbOK

-End Sub

-

-Private Sub cbCity_Change()

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_CITY") = Me.cbCity.ListIndex

-        .Calculate

-    End With

-End Sub

-

-Private Sub cbRegion_Change()

-    Dim LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        NewRangeOffsetCol = cbRegion.Value * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).address

-        NewSumRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).address

-        .Calculate

-        .Range("IDX_CITY") = 0

-        cbCity.RowSource = NewCbxRange

-

-    End With

-    cbCity.ListIndex = 0

-End Sub

-

-<<<<<<
-======================
-mREP
->>>>>>
-Attribute VB_Name = "mREP"

-Option Explicit

-

-Sub hwnew()

-    Dim rs As Range

-    Dim re As Object

-    

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    HWReset

-    ReSetREPRecord

-    With Worksheets("REP_QTR")

-        .ClearRepName

-        .Range("REP_QTR_INPUT_DATA").ClearContents

-        .Range("QTR_SEL") = ""

-    End With

-    Worksheets(TITLE_SHEET).Select

-    With Application

-        .DisplayAlerts = False

-        .ThisWorkbook.Save

-        .Quit

-    End With

-End Sub

-

-Function CheckUser() As Boolean

-    Dim objHW() As Long

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    

-    GetHWInfo objHW()

-    i = GetHWRecords(objHW_DB)

-    

-    If i = 0 Then ' First time

-        StoreHWInfo objHW()

-        Worksheets("REP_QTR").Range("QTR_SEL") = ""

-    End If

-    If CheckHWInfo(objHW()) <> True Then

-        CheckUser = False

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    Else

-        CheckUser = SetupUser

-    End If

-End Function

-

-Function SetupUser() As Boolean

-    Dim cUser As tREP

-    Dim idx As Integer

-    Dim dlg_ui As UserInfo

-    

-    Set dlg_ui = New UserInfo

-    

-    cUser = GetREPRecord()

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_REGION") = cUser.Region

-        .Range("IDX_CITY") = cUser.City

-    End With

-        

-    With dlg_ui

-        .cbRegion = cUser.Region

-        .cbCity = cUser.City

-        .tbFName = cUser.FirstName

-        .tbLName = cUser.LastName

-    End With

-    

-    Worksheets(REGS_SHEET).Calculate

-    

-    Dim test_Ok As Boolean

-    test_Ok = False

-    

-    On Error GoTo l1

-

-    Do

-        dlg_ui.Show

-        If dlg_ui.Tag = vbOK Then

-            test_Ok = dlg_ui.tbFName.Value <> "" And dlg_ui.tbLName <> ""

-            If test_Ok Then

-                Exit Do

-            Else

-                MsgBox "Введите имя и фамилию", vbOKOnly, PROGRAM_NAME

-            End If

-        Else

-            Exit Do

-        End If

-    Loop Until False

-l1:

-    If test_Ok Then

-        With cUser

-            .Region = dlg_ui.cbRegion.Value

-            .City = dlg_ui.cbCity.Value

-            .FirstName = dlg_ui.tbFName.Value

-            .LastName = dlg_ui.tbLName.Value

-        End With

-        SetREPRecord cUser

-    Else

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .ThisWorkbook.Saved = True

-            .Quit

-        End With

-    End If

-    SetupUser = test_Ok

-End Function

-

-Sub GetHWInfo(objHW() As Long)

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    i = 1

-    For Each d In dc

-        If d.drivetype = 2 Then ' 2 - HardDisk

-            ReDim Preserve objHW(i)

-            objHW(i) = d.SerialNumber

-            i = i + 1

-        End If

-    Next

-    SortHW objHW

-End Sub

-

-Sub StoreHWInfo(objHW() As Long)

-    UpdateHWRecords objHW

-End Sub

-

-Sub SortHW(objHW() As Long)

-    Dim r As Range

-    Dim rs As Range

-    Dim re As Object

-    Dim i As Integer

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    For i = 1 To UBound(objHW)

-        r = objHW(i)

-        Set r = r.Offset(1, 0)

-    Next i

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).Sort _

-            Key1:=.Range("HW_Number"), _

-            Order1:=xlDescending, _

-            Header:=xlGuess, _

-            OrderCustom:=1, _

-            MatchCase:=False, _

-            Orientation:=xlTopToBottom

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    i = 1

-    Do While r <> ""

-        objHW(i) = r

-        Set r = r.Offset(1, 0)

-        i = i + 1

-    Loop

-End Sub

-

-Function CheckHWInfo(objHW() As Long)

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    CheckHWInfo = False

-        

-    i = GetHWRecords(objHW_DB)

-    If i > 0 Then

-        SortHW objHW_DB

-    End If

-    If UBound(objHW) = UBound(objHW_DB) Then

-        For i = 1 To UBound(objHW)

-            If objHW(i) <> objHW_DB(i) Then

-                Exit Function

-            End If

-        Next i

-        CheckHWInfo = True

-    End If

-End Function

-<<<<<<
-======================
-dbBudget
->>>>>>
-Attribute VB_Name = "dbBudget"

-Option Explicit

-

-Public Type tBUDGET

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    bdgt_NMG As Long

-    bdgt_NFG As Long

-    sale_plan As Long

-End Type

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function GetAll_BDGT_RecordsByLPU_ID(ByRef allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_BDGT_RecordsByLPU_ID = dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection, allBDGT, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function Get_BDGT_Record(ByVal lpu_id As Long, ByVal ent_date As String) As tBUDGET

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    Get_BDGT_Record = dbGet_BDGT_Record(dbConnection, lpu_id, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objBDGT.ID <> 0 then updatre else insert

-Public Sub Insert_BDGT_Record(objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    If objBDGT.id <> 0 Then

-        dbUpdate_BDGT_Record dbConnection, objBDGT

-    Else

-        dbInsert_BDGT_Record dbConnection, objBDGT

-    End If

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Public Sub Delete_BDGT_Record(ByRef objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    dbDelete_BDGT_Record dbConnection, objBDGT

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_BDGT_Record(dbConnection As Object, ByVal lpu_id As Long, ent_date As String) As tBUDGET

-    

-    Dim SQL As String

-    Dim objBDGT As tBUDGET

-    

-    With objBDGT

-        .id = 0

-        .lpu_id = lpu_id

-        .entry_date = ent_date

-        .bdgt_NMG = 0

-        .bdgt_NFG = 0

-        .sale_plan = 0

-    End With

-        

-    

-    SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        With objBDGT

-            .entry_date = dbRecordset("entry_date")

-            .id = dbRecordset("id")

-            .lpu_id = dbRecordset("lpu_id")

-            .bdgt_NFG = dbRecordset("bdgt_NFG")

-            .bdgt_NMG = dbRecordset("bdgt_NMG")

-            .sale_plan = dbRecordset("sale_PLAN")

-        End With

-    End If

-    

-    dbGet_BDGT_Record = objBDGT

-End Function

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection As Object, allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_BDGT_SQL As String

-    Dim getAll_BDGT_SQL As String

-    Dim BDGT_Count As Long

-    BDGT_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_BDGT_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        BDGT_Count = dbRecordset("BDGT_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_BDGT_RecordsbyLPU_ID = BDGT_Count

-    

-    If BDGT_Count > 0 Then

-        'we have records

-        ReDim allBDGT(1 To BDGT_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_BDGT_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpBDGT As tBUDGET

-                 With tmpBDGT

-                    .entry_date = dbRecordset("entry_date")

-                    .id = dbRecordset("id")

-                    .lpu_id = dbRecordset("lpu_id")

-                    .bdgt_NFG = dbRecordset("bdgt_NFG")

-                    .bdgt_NMG = dbRecordset("bdgt_NMG")

-                    .sale_plan = dbRecordset("sale_PLAN")

-                 End With

-                 

-                 allBDGT(index) = tmpBDGT

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbInsert_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "lpu_budget", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    dbRecordset("entry_date") = objBDGT.entry_date

-    dbRecordset("lpu_id") = objBDGT.lpu_id

-    dbRecordset("bdgt_NMG") = objBDGT.bdgt_NMG

-    dbRecordset("bdgt_NFG") = objBDGT.bdgt_NFG

-    dbRecordset("sale_PLAN") = objBDGT.sale_plan

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objBDGT.id = dbRecordset("id")

-  

-End Sub

-

-Public Sub dbUpdate_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu_budget SET " & _

-    "entry_date='" & objBDGT.entry_date & "'," & _

-    "lpu_id=" & objBDGT.lpu_id & "," & _

-    "bdgt_NMG=" & objBDGT.bdgt_NMG & "," & _

-    "bdgt_NFG=" & objBDGT.bdgt_NFG & "," & _

-    "sale_PLAN=" & objBDGT.sale_plan & _

-    " WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-Public Sub dbDelete_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_BDGT_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbDatabase
->>>>>>
-Attribute VB_Name = "dbDatabase"

-Option Explicit

-

-

-Sub dbOpenConnection(dbConnection As Object)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, SQL As String)

-    dbConnection.Execute (SQL)

-End Sub

-

-<<<<<<
-======================
-dbLPU
->>>>>>
-Attribute VB_Name = "dbLPU"

-Option Explicit

-

-Public Type tLPU

-    id As Long

-    rep_id As Long

-    name As String

-    address As String

-    beds As Integer

-End Type

-

-Function Get_LPU_Record(ByVal lpu_id As Long) As tLPU

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_LPU_Record = dbGet_LPU_Record(dbConnection, lpu_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAllLPU(allLPU() As tLPU) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAllLPU = dbGetAllLPU(dbConnection, allLPU)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAllLPUbyQTR(allLPU() As tLPU, ent_date As String) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAllLPUbyQTR = dbGetAllLPUbyQTR(dbConnection, allLPU, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objLPU.id = 0 then insert else update

-Sub Insert_LPU_Record(ByRef objLPU As tLPU)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    If objLPU.id = 0 Then

-        dbInsert_LPU_Record dbConnection, objLPU

-    Else

-        dbUpdate_LPU_Record dbConnection, objLPU

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub Delete_LPU_Record(ByRef objLPU As tLPU)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDelete_LPU_Record dbConnection, objLPU

-    dbCloseConnection dbConnection

-End Sub

-

-Sub Delete_LPU_RecordQTR(ByRef objLPU As tLPU, ent_date As String)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Hir_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Ter_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_ACS_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    

-    dbCloseConnection dbConnection

-    

-End Sub

-

-Function dbGet_LPU_Record(dbConnection As Object, ByVal lpu_id As Long) As tLPU

-    

-    Dim SQL As String

-    Dim objLPU As tLPU

-    

-    objLPU.id = lpu_id

-    objLPU.name = ""

-    objLPU.address = ""

-    

-    SQL = "SELECT * FROM lpu WHERE id=" & lpu_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objLPU.name = dbRecordset("name")

-        objLPU.address = dbRecordset("address")

-        objLPU.rep_id = dbRecordset("rep_id")

-        objLPU.beds = dbRecordset("beds")

-    End If

-    

-    dbGet_LPU_Record = objLPU

-

-End Function

-

-Sub dbInsert_LPU_Record(dbConnection As Object, ByRef objLPU As tLPU)

-  

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu", dbConnection, 2, 2

-    dbRecordset.addnew

-    dbRecordset("name") = objLPU.name

-    dbRecordset("address") = objLPU.address

-    dbRecordset("rep_id") = objLPU.rep_id

-    dbRecordset("beds") = objLPU.beds

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objLPU.id = dbRecordset("id")

-  

-End Sub

-

-Sub dbUpdate_LPU_Record(dbConnection As Object, ByRef objLPU As tLPU)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu SET " & _

-    "name='" & objLPU.name & "'," & _

-    "address='" & objLPU.address & "'," & _

-    "beds=" & objLPU.beds & "," & _

-    "rep_id=" & objLPU.rep_id& & _

-    " WHERE id=" & objLPU.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-

-Function dbGetAllLPU(dbConnection As Object, allLPU() As tLPU) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu"

-    getAll_LPU_SQL = "SELECT * FROM lpu"

-

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAllLPU = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-Function dbGetAllLPUbyQTR(dbConnection As Object, allLPU() As tLPU, ent_date As String) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    Dim where As String

-    where = "WHERE lpu_budget.entry_date like '" & ent_date & "'"

-    

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu_budget " & where

-    

-    getAll_LPU_SQL = "SELECT lpu.id as id, lpu.rep_id as rep_id, lpu.name as name, lpu.address as address, lpu.beds AS beds " & _

-    "FROM lpu, lpu_budget " & where & " AND lpu.id=lpu_budget.lpu_id"

-    

-

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAllLPUbyQTR = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-Sub dbDelete_LPU_Record(dbConnection As Object, ByRef objLPU As tLPU)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu " & _

-    "WHERE id=" & objLPU.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByLPU_ID dbConnection, objLPU.id

-    dbDelete_Hir_RecordsByLPU_ID dbConnection, objLPU.id

-    dbDelete_Ter_RecordsByLPU_ID dbConnection, objLPU.id

-    dbDelete_ACS_RecordsByLPU_ID dbConnection, objLPU.id

-    

-End Sub

-

-Sub dbDelete_LPU_RecordQTR(dbConnection As Object, ByRef objLPU As tLPU, ent_date As String)

-    

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Hir_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Ter_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_ACS_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    

-End Sub

-

-<<<<<<
-======================
-dbREP
->>>>>>
-Attribute VB_Name = "dbREP"

-Option Explicit

-

-Public Type tREP

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function GetREPRecord() As tREP

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetREPRecord = dbGetREPRecord(dbConnection)

-    dbCloseConnection dbConnection

-End Function

-

-Sub SetREPRecord(cUser As tREP)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbSetREPRecord dbConnection, cUser

-    dbCloseConnection dbConnection

-End Sub

-

-Sub ReSetREPRecord()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbReSetREPRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGetREPRecord(dbConnection As Object) As tREP

-    

-    Dim SQL As String

-    Dim objREP As tREP

-    

-    objREP.FirstName = ""

-    objREP.LastName = ""

-    objREP.Region = 0

-    objREP.City = 0

-    SQL = "SELECT firstname, lastname, region, city FROM " & _

-          "rep"

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open SQL, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREP.FirstName = dbRecordset("firstname")

-        objREP.LastName = dbRecordset("lastname")

-        objREP.Region = dbRecordset("region")

-        objREP.City = dbRecordset("city")

-        

-    End If

-    

-    dbGetREPRecord = objREP

-        

-End Function

-

-Public Sub dbSetREPRecord(dbConnection As Object, ByRef objREP As tREP)

-  

-    Dim DeleteSQL As String

-    Dim InsertSQL As String

-    

-    DeleteSQL = "DELETE FROM rep"

-    InsertSQL = "INSERT INTO rep (firstname, lastname, region, city) VALUES (" & _

-    "'" & objREP.FirstName & "', " & _

-    "'" & objREP.LastName & "', " & _

-    objREP.Region & ", " & _

-    objREP.City & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    dbRecordset.Open InsertSQL, dbConnection

-End Sub

-

-Public Sub dbReSetREPRecord(dbConnection As Object)

-  

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM rep"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    CheckWorkBooksArround Wb

-End Sub

-

-

-Sub CheckWorkBooksArround(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If app.Workbooks.Count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKOnly, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-        Exit Sub

-    End If

-

-End Sub

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub SaveExcelState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-        ActiveWorkbook.DisplayDrawingObjects = xlDisplayShapes

-        

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.Count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars(STDBAR_NAME).Visible = False

-End Sub

-

-

-Public Sub RestoreExcelState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars(STDBAR_NAME).Visible = True

-End Sub

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Public Const STDBAR_NAME = "Worksheet Menu Bar"

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Export"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 620

-                        .OnAction = "cmExport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Exit && Restore Excel"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 548

-                        .OnAction = "cmExitRestore"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(flag As Boolean)

-    If flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars(STDBAR_NAME)

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmExport()

-    dbExport

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    Dim dlg As dlgAbout

-    Set dlg = New dlgAbout

-    

-    dlg.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlg.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlg.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlg.Show

-End Sub

-

-Sub cmMail2Support()

-    Dim err_description As String

-    Dim dlg_msg As dlg_Mail

-    Set dlg_msg = New dlg_Mail

-    With dlg_msg

-        .Show

-        If .Tag = vbOK Then

-            ThisWorkbook.Worksheets(VAR_SHEET).Range("ERR_MESSAGE") _

-                = .tbMessage.Text

-            ThisWorkbook.Save

-            ThisWorkbook.SendMail Recipients:="infra@i-rs.ru", Subject:=PROGRAM_NAME & " ver.:" & PROGRAM_VERSION

-            MsgBox "Сообщение об ошибке отправлено. Перезагрузите программу.", vbOKOnly, PROGRAM_NAME

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-    End With

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-'        helppath = "hh.exe " & .Path & "\Telfast.chm"

-'        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub set_work_mode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetupEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-End Sub

-

-Sub cmSetStandaloneMode()

-    set_work_mode

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    Dim dlg As dlgGetPwd

-    rp = common_pwd

-    

-    Set dlg = New dlgGetPwd

-    dlg.edPwd = ""

-    dlg.Show

-    

-    If dlg.edPwd = rp Then

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmHomePage()

-    ThisWorkbook.Worksheets("REP_QTR").Select

-End Sub

-

-Sub cmExitRestore()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = True

-    Application.Quit

-End Sub

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    Dim dlg_prn As dlgPrint

-    

-    Set dlg_prn = New dlgPrint

-    

-    With dlg_prn

-        .cbMainReport = True

-        .cbMainBudget = False

-        .cbSrcData = False

-        .cbAllSheets = False

-    

-        .Show

-    

-        If .Tag = vbCancel Then

-            Exit Sub

-        End If

-    End With

-    

-    Dim PrnIdx As Integer

-    

-    With dlg_prn

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("REP_QTR", "budget", "Final")

-    Case 1111

-        plist = Array("REP_QTR", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("REP_QTR")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Clexane bar"

-Public Const common_pwd As String = "crdjhxtyjr"

-

-

-Sub SetupEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    Wb.Worksheets(TITLE_SHEET).Select

-    With Application

-        .Caption = PROGRAM_NAME & " " & PROGRAM_VERSION

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .SaveExcelState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = False

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Wb.Worksheets(TITLE_SHEET).Select

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-'                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    If cWindow.Type = xlWorkbook Then

-                        cWindow.DisplayHeadings = True

-                    End If

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu True

-        End If

-        With mobjAppState

-            .RestoreExcelState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Worksheets(TITLE_SHEET).Select

-'        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Option Explicit

-

-Sub UpdateHWRecords(objHW() As Long)

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    dbUpdateHWRecords dbConnection, objHW

-    dbCloseConnection dbConnection

-End Sub

-

-Function GetHWRecords(objHW() As Long) As Integer

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    GetHWRecords = dbGetHWRecords(dbConnection, objHW)

-    dbCloseConnection dbConnection

-End Function

-

-Sub HWReset()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbInsertHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    

-    Dim dbRecordset As Object

-    Dim i As Long

-    

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "hw", dbConnection, 2, 2

-    

-    For i = 1 To UBound(objHW)

-        dbRecordset.addnew

-        dbRecordset("num") = objHW(i)

-        dbRecordset.Update

-    Next i

-    

-End Sub

-

-Sub dbUpdateHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    dbDeleteHWRecord dbConnection

-    dbInsertHWRecords dbConnection, objHW

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-dbHir
->>>>>>
-Attribute VB_Name = "dbHir"

-Option Explicit

-

-Public Type tHIRURGIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    operations_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_ambulator_clexan_40mg As Integer

-    patients_ambulator_clexan_20mg As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-    patients_stationar_clexan_40mg As Integer

-    patients_stationar_clexan_20mg As Integer

-End Type

-

-' if objHir.ID <> 0 then updatre else insert

-Sub Insert_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objHir.id <> 0 Then

-        dbUpdate_Hir_Record dbConnection, objHir

-    Else

-        dbInsert_Hir_Record dbConnection, objHir

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Hir_RecordsByLPU_ID(ByRef allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Hir_RecordsByLPU_ID = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, allHir, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Hir_Record dbConnection, objHir

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objHir.ID <> 0 then updatre else insert

-

-Sub dbInsert_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_hir", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objHir

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("operations_per_quarter") = .operations_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_ambulator_clexan_20mg") = .patients_ambulator_clexan_20mg

-        dbRecordset("patients_ambulator_clexan_40mg") = .patients_ambulator_clexan_40mg

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-        dbRecordset("patients_stationar_clexan_20mg") = .patients_stationar_clexan_20mg

-        dbRecordset("patients_stationar_clexan_40mg") = .patients_stationar_clexan_40mg

-        

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objHir.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim UpdateSQL As String

-    

-    With objHir

-        UpdateSQL = "UPDATE lpu_hir SET " & _

-            "entry_date='" & objHir.entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "operations_per_quarter=" & .operations_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_ambulator_clexan_20mg=" & .patients_ambulator_clexan_20mg & "," & _

-            "patients_ambulator_clexan_40mg=" & .patients_ambulator_clexan_40mg & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & "," & _

-            "patients_stationar_clexan_20mg=" & .patients_stationar_clexan_20mg & "," & _

-            "patients_stationar_clexan_40mg=" & .patients_stationar_clexan_40mg & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_Hir_RecordsbyLPU_ID(dbConnection As Object, allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Hir_SQL As String

-    Dim getAll_Hir_SQL As String

-    Dim Hir_Count As Long

-    Hir_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Hir_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Hir_Count = dbRecordset("HIR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Hir_RecordsbyLPU_ID = Hir_Count

-    

-    If Hir_Count > 0 Then

-        'we have records

-        ReDim allHir(1 To Hir_Count)

-        Dim index As Integer

-        index = 1

-        dbRecordset.Open getAll_Hir_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpHir As tHIRURGIA

-                 With tmpHir

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .operations_per_quarter = dbRecordset("operations_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_ambulator_clexan_20mg = dbRecordset("patients_ambulator_clexan_20mg")

-                    .patients_ambulator_clexan_40mg = dbRecordset("patients_ambulator_clexan_40mg")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                    .patients_stationar_clexan_20mg = dbRecordset("patients_stationar_clexan_20mg")

-                    .patients_stationar_clexan_40mg = dbRecordset("patients_stationar_clexan_40mg")

-                 End With

-                 

-                 allHir(index) = tmpHir

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE ID=" & objHir.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Hir_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbTer
->>>>>>
-Attribute VB_Name = "dbTer"

-Option Explicit

-

-Public Type tTERAPIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objTer.ID <> 0 then updatre else insert

-Sub Insert_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objTer.id <> 0 Then

-        dbUpdate_Ter_Record dbConnection, objTer

-    Else

-        dbInsert_Ter_Record dbConnection, objTer

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Ter_RecordsByLPU_ID(ByRef allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Ter_RecordsByLPU_ID = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, allTer, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Ter_Record dbConnection, objTer

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objTer.ID <> 0 then updatre else insert

-

-Sub dbInsert_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_ter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objTer

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("risk_percent") = Double2Str(.risk_percent, 3)

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objTer.id = dbRecordset("ID")

-

-End Sub

-

-Sub test()

-    Dim s As String

-    Dim d As Single

-    d = 1235.6789

-    s = Format(d, "####0,00")

-    MsgBox s

-End Sub

-

-Sub dbUpdate_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim Update_SQL As String

-    

-    With objTer

-        Update_SQL = "UPDATE lpu_ter SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_Ter_RecordsbyLPU_ID(dbConnection As Object, allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Ter_SQL As String

-    Dim getAll_Ter_SQL As String

-    Dim Ter_Count As Long

-    Ter_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Ter_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Ter_Count = dbRecordset("TER_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Ter_RecordsbyLPU_ID = Ter_Count

-    

-    If Ter_Count > 0 Then

-        'we have records

-        ReDim allTer(1 To Ter_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_Ter_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpTer As tTERAPIA

-                 With tmpTer

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 allTer(index) = tmpTer

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE ID=" & objTer.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Ter_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-mLPU_LIST
->>>>>>
-Attribute VB_Name = "mLPU_LIST"

-Option Explicit

-

-Public Const CINP_AREA As String = "B12"

-Public Const CLPU_NAME As Integer = 0

-Public Const CLPU_NAME1 As Integer = 1

-Public Const CLPU_NAME2 As Integer = 2

-Public Const CLPU_ID As Integer = 3

-Public Const CLPU_BEDS As Integer = 4

-Public Const CLPU_NFG As Integer = 5

-Public Const CLPU_NMG As Integer = 6

-Public Const CLPU_HIR As Integer = 7

-Public Const CLPU_TER As Integer = 8

-Public Const CLPU_CAR As Integer = 9

-Public Const CLPU_FACT As Integer = 10

-Public Const CLPU_PLAN As Integer = 11

-Public Const CLPU_PAT_LPU As Integer = 16

-Public Const CLPU_BDGT As Integer = 17

-Public Const CLPU_PAT_ALL As Integer = 16

-

-

-

-Sub EditLPU(cLPU As tLPU, ent_date As String)

-    Dim del_request As Integer

-    Dim allLPU() As tLPU

-    Dim lpu_count As Integer

-    Dim i As Integer

-    Dim tmp_LPU_List As Range

-    Dim tmp_LPU_List_Addr As String

-    Dim r_end As Range

-    Dim dlg As Dlg_lpu_card

-    

-    Set dlg = New Dlg_lpu_card

-    

-    lpu_count = GetAllLPU(allLPU)

-    With Worksheets(VAR_SHEET)

-        Set tmp_LPU_List = .Range("tmp_LPU_List")

-        Set r_end = .Range(tmp_LPU_List, tmp_LPU_List.End(xlDown))

-        Set r_end = .Range(r_end, r_end.End(xlToRight))

-        .Range(tmp_LPU_List, r_end).ClearContents

-    End With

-        

-    If lpu_count <> 0 Then

-        dlg.cbxLPU_List_Enable.Enabled = True

-        For i = 1 To UBound(allLPU)

-            tmp_LPU_List.Cells(i, 1) = allLPU(i).name

-            tmp_LPU_List.Cells(i, 2) = allLPU(i).address

-            tmp_LPU_List.Cells(i, 3) = allLPU(i).beds

-            tmp_LPU_List.Cells(i, 4) = allLPU(i).id

-        Next i

-    Else

-        dlg.cbxLPU_List_Enable.Enabled = False

-    End If

-    

-    tmp_LPU_List_Addr = Worksheets(VAR_SHEET).name & "!" & _

-            Worksheets(VAR_SHEET).Range(tmp_LPU_List, tmp_LPU_List.End(xlDown)).address

-

-    With dlg

-        .cbLPU_List.RowSource = tmp_LPU_List_Addr

-        .cbLPU_List.ListIndex = 0

-        .cbxLPU_List_Enable = False

-        .cbLPU_List.Enabled = False

-        If cLPU.id <> 0 Then

-            .cbxLPU_List_Enable.Enabled = False

-        Else

-            If lpu_count <> 0 Then

-                .cbxLPU_List_Enable.Enabled = True

-            Else

-                .cbxLPU_List_Enable.Enabled = False

-            End If

-        End If

-        .tb_lpu_name.Text = cLPU.name

-        .tb_lpu_address.Text = cLPU.address

-        .tbBedsCount = cLPU.beds

-

-        .Tag = vbCancel

-    End With

-    

-    dlg.Show

-    

-    If Not IsNumeric(dlg.Tag) Then

-        Exit Sub

-    End If

-    

-    If dlg.Tag = vbOK Then

-        Dim n As Variant

-        Dim test As Integer

-        test = 0

-        n = dlg.tbBedsCount.Value

-        If Not IsNumeric(n) Then

-            test = 1

-        Else

-            If n = 0 Then

-                test = 1

-            End If

-        End If

-        If test = 0 Then

-            

-            cLPU.name = dlg.tb_lpu_name.Text

-            cLPU.address = dlg.tb_lpu_address.Text

-            cLPU.beds = dlg.tbBedsCount.Value

-                                    

-            If cLPU.name = "" Or cLPU.address = "" Then

-                test = 2

-            End If

-        End If

-        Select Case test

-            Case 0

-                If dlg.cbxLPU_List_Enable.Value = True Then

-                    cLPU.id = tmp_LPU_List.Cells(dlg.cbLPU_List.ListIndex + 1, 4)

-                End If

-                Insert_LPU_Record cLPU

-                ' Проверить наличие данных для ЛПУ в квартале

-                Dim bdgt As tBUDGET

-                bdgt = Get_BDGT_Record(cLPU.id, ent_date)

-                ' Записи нет: создать пустую запись в lpu_budget

-                If bdgt.id = 0 Then

-                    bdgt.lpu_id = cLPU.id

-                    bdgt.entry_date = ent_date

-                    Insert_BDGT_Record bdgt

-                End If

-            Case 1

-                MsgBox "Коечная мощьность измеряется числом более чем 1!", vbOKOnly, PROGRAM_NAME

-            Case 2

-                MsgBox "Наименование и адрес ЛПУ не должны быть пустыми!", vbOKOnly, PROGRAM_NAME

-        End Select

-    End If

-End Sub

-

-Sub Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-

-End Sub

-

-Sub Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btLPU_DEL_IT()

-    Dim cLPU As tLPU

-    Dim ent_date As String

-    Dim delete_all As Integer

-    Dim dlg_del As dlg_LPU_delete

-    

-    With Worksheets("LPU_LIST")

-        ent_date = .Range("ent_date")

-        cLPU.id = .getCurrentLPU_ID()

-    End With

-    

-    If cLPU.id = 0 Then

-        MsgBox "Укажите удаляемый объект", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    cLPU = Get_LPU_Record(cLPU.id)

-    

-    Set dlg_del = New dlg_LPU_delete

-    With dlg_del

-        .chbDeleteQTR.Value = True

-        .chbDeleteAll.Value = False

-        .lComment = ent_date & ": Удаление ЛПУ '" _

-        & cLPU.name & "', расположенного по адресу:" _

-        & cLPU.address & "."

-        .Show

-        

-        If .Tag = vbOK Then

-            If .chbDeleteAll.Value Then

-                delete_all = _

-                    MsgBox("Все записи об ЛПУ с именем '" & cLPU.name & _

-                    "' будут удалены навсегда.", vbOK, PROGRAM_NAME)

-                If delete_all = vbOK Then

-                    Delete_LPU_Record cLPU

-                End If

-            Else

-                Delete_LPU_RecordQTR cLPU, ent_date

-            End If

-        End If

-    End With

-    

-    With ThisWorkbook

-        .Worksheets(TITLE_SHEET).Select

-        .Worksheets("LPU_LIST").Select

-    End With

-End Sub

-

-Sub btLPU_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Activate

-End Sub

-

-

-Sub btLPU_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim lpu_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("QTR_ACTION").Value

-    With Worksheets("LPU_LIST")

-        ent_date = .getEnt_date()

-        

-    

-        lpu_id = .getCurrentLPU_ID

-        If lpu_id <> 0 And i = 1 Then

-            lpu_id = 0

-        End If

-        If lpu_id = 0 Then

-            i = 1

-        End If

-        Select Case i

-            Case 1, 6

-                .SelectLPU_NAME lpu_id, ent_date

-                .Range("JUMP") = ""

-            Case 2

-                If lpu_id <> 0 Then

-                    .SelectLPU_BDGT lpu_id, ent_date

-                    .Range("JUMP") = "LPU_BDGT"

-                End If

-            Case 3

-                If lpu_id <> 0 Then

-                    .SelectLPU_HIR lpu_id, ent_date

-                    .Range("JUMP") = "LPU_CLSN_HIR"

-                End If

-            Case 4

-                If lpu_id <> 0 Then

-                    .SelectLPU_TER lpu_id, ent_date

-                    .Range("JUMP") = "LPU_CLSN_TER"

-                End If

-            Case 5

-                If lpu_id <> 0 Then

-                    .SelectLPU_C_ACS lpu_id, ent_date

-                    .Range("JUMP") = "LPU_CLSN_C_ACS"

-                End If

-        End Select

-    End With

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-dbQTR
->>>>>>
-Attribute VB_Name = "dbQTR"

-Option Explicit

-

-Public Type tQTR

-    id As Long

-    entry_date As String

-    rep_id As Long

-    sale_plan As Long

-    ClxnH20mg As Long

-    ClxnH40mg As Long

-    ClxnT40mg As Long

-    ClxnC_IM As Long

-    ClxnC_ACS As Long

-End Type

-

-

-Function GetLastQTR_fromDB() As String

-    Dim dbConnection As Object

-    Dim getCount_QTR_SQL As String

-    Dim getLast_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter"

-    getLast_QTR_SQL = "SELECT MAX(entry_date) as ent_date FROM quarter"

-    

-    dbOpenConnection dbConnection

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    If QTR_Count > 0 Then

-        'we have records

-        dbRecordset.Open getLast_QTR_SQL, dbConnection

-        getLast_QTR_SQL = dbRecordset("ent_date")

-    Else

-        getLast_QTR_SQL = ""

-    End If

-    

-    GetLastQTR_fromDB = getLast_QTR_SQL

-    dbCloseConnection dbConnection

-End Function

-

-Sub Insert_QTR_Record(ByRef objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objQTR.id <> 0 Then

-        dbUpdate_QTR_Record dbConnection, objQTR

-    Else

-        dbInsert_QTR_Record dbConnection, objQTR

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-Function Get_QTR_Record(ent_date As String) As tQTR

-    Dim dbConnection As Object

-    Dim allQTR() As tQTR

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    i = dbGetAll_QTR_Records(dbConnection, allQTR, ent_date)

-    If i <> 0 Then

-        Get_QTR_Record = allQTR(1)

-    End If

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTR_Records(ByRef All_QTR() As tQTR, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_QTR_Records = dbGetAll_QTR_Records(dbConnection, All_QTR, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_QTR_Record(ByRef objQTR As tQTR)

-    Dim dbConnection As Object

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_QTR_Record dbConnection, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objQTR.ID <> 0 then updatre else insert

-Sub dbInsert_QTR_Record(dbConnection As Object, ByRef objQTR As tQTR)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "quarter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objQTR

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("sale_plan") = .sale_plan

-        dbRecordset("rep_id") = .rep_id

-        dbRecordset("ClxnH20mg") = .ClxnH20mg

-        dbRecordset("ClxnH40mg") = .ClxnH40mg

-        dbRecordset("ClxnT40mg") = .ClxnT40mg

-        dbRecordset("ClxnC_IM") = .ClxnC_IM

-        dbRecordset("ClxnC_ACS") = .ClxnC_ACS

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objQTR.id = dbRecordset("id")

-

-End Sub

-

-Sub dbUpdate_QTR_Record(dbConnection As Object, ByRef objQTR As tQTR)

-    Dim Update_SQL As String

-    

-    With objQTR

-        Update_SQL = "UPDATE quarter SET " & _

-            "entry_date='" & .entry_date & "'" & "," & _

-            "rep_id=" & .rep_id & "," & _

-            "sale_plan=" & .sale_plan & "," & _

-            "ClxnH20mg=" & .ClxnH20mg & "," & _

-            "ClxnH40mg=" & .ClxnH40mg & "," & _

-            "ClxnT40mg=" & .ClxnT40mg & "," & _

-            "ClxnC_IM=" & .ClxnC_IM & "," & _

-            "ClxnC_ACS=" & .ClxnC_ACS & _

-            " WHERE id=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if ent_date = % then all_records

-Function dbGetAll_QTR_Records(dbConnection As Object, All_QTR() As tQTR, ent_date As String) As Integer

-    

-    Dim getCount_QTR_SQL As String

-    Dim getAll_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter WHERE entry_date like '" & ent_date & "'"

-    getAll_QTR_SQL = "SELECT * FROM quarter WHERE entry_date like '" & ent_date & "' ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_QTR_Records = QTR_Count

-    

-    If QTR_Count > 0 Then

-        'we have records

-        ReDim All_QTR(1 To QTR_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTR_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTR As tQTR

-                 With tmp_QTR

-                    .entry_date = dbRecordset("entry_date")

-                    .rep_id = dbRecordset("rep_id")

-                    .sale_plan = dbRecordset("sale_plan")

-                    .ClxnH20mg = dbRecordset("ClxnH20mg")

-                    .ClxnH40mg = dbRecordset("ClxnH40mg")

-                    .ClxnT40mg = dbRecordset("ClxnT40mg")

-                    .ClxnC_IM = dbRecordset("ClxnC_IM")

-                    .ClxnC_ACS = dbRecordset("ClxnC_ACS")

-                    .id = dbRecordset("id")

-                 End With

-                 

-                 All_QTR(index) = tmp_QTR

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_QTR_Record(dbConnection As Object, ByRef objQTR As tQTR)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM quarter " & _

-    "WHERE id=" & objQTR.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByQTR dbConnection, objQTR.entry_date

-    dbDelete_Hir_RecordsByQTR dbConnection, objQTR.entry_date

-    dbDelete_Ter_RecordsByQTR dbConnection, objQTR.entry_date

-    dbDelete_ACS_RecordsByQTR dbConnection, objQTR.entry_date

-       

-End Sub

-<<<<<<
-======================
-cdbQTR
->>>>>>
-Attribute VB_Name = "cdbQTR"

-Option Explicit

-

-Public Type tQTR_COMMON

-    qtr As tQTR

-    i_lcd As Long           ' число ЛПУ в СПИСКЕ

-    lcd() As tLPU_COMMON    ' список ЛПУ

-    c_beds As Long          ' сумма коек

-    c_bdgt_NFG As Long      ' общий бюджет на НФГ

-    c_bdgt_NMG As Long      ' общий бюджет на НМГ

-    c_bdgt_LPU As Long      ' общий бюджет на гепарины

-    c_sale_PLAN As Long     ' план продаж репа

-    c_sale_ALL As Long      ' продажи

-    c_sale_HIR As Long      ' в хирургии

-    c_sale_TER  As Long     ' в терапии

-    c_sale_CRD  As Long     ' в кардиологии

-    c_pat_HIR   As Long     ' пациенты

-    c_pat_TER   As Long     '

-    c_pat_CRD   As Long     '

-    c_pat_ALL   As Long     '

-    c_pat_LPU   As Long     ' Всего операций

-End Type

-

-Function Get_QTR_CommonList(ByRef qcd() As tQTR_COMMON) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_QTR_CommonList = dbGet_QTR_CommonList(dbConnection, qcd)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_CommonList(dbConnection As Object, ByRef qcd() As tQTR_COMMON) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim allQTR() As tQTR

-    i = dbGetAll_QTR_Records(dbConnection, allQTR, "%")

-    dbGet_QTR_CommonList = i

-    If i > 0 Then

-        ReDim qcd(i)

-        For i = 1 To UBound(allQTR)

-            With qcd(i)

-                .qtr = allQTR(i)

-                .c_beds = 0

-                .c_bdgt_NFG = 0

-                .c_bdgt_NMG = 0

-                .c_bdgt_LPU = 0

-                .c_sale_PLAN = 0

-                .c_pat_HIR = 0

-                .c_pat_TER = 0

-                .c_pat_CRD = 0

-                .c_pat_ALL = 0

-                .c_sale_HIR = 0

-                .c_sale_TER = 0

-                .c_sale_CRD = 0

-                .c_sale_ALL = 0

-                .c_pat_LPU = 0

-                

-                j = dbGet_LPU_CommonQTR(dbConnection, .lcd, .qtr)

-                .i_lcd = j

-                If j > 0 Then

-                    For j = 1 To UBound(.lcd)

-                        .c_beds = .c_beds + .lcd(j).lpu.beds

-                        .c_bdgt_NFG = .c_bdgt_NFG + .lcd(j).bdgt.bdgt_NFG

-                        .c_bdgt_NMG = .c_bdgt_NMG + .lcd(j).bdgt.bdgt_NMG

-                        .c_bdgt_LPU = .c_bdgt_LPU + .lcd(j).bdgt_LPU

-                        .c_sale_PLAN = .c_sale_PLAN + .lcd(j).bdgt.sale_plan

-                        .c_pat_HIR = .c_pat_HIR + .lcd(j).pat_HIR

-                        .c_pat_TER = .c_pat_TER + .lcd(j).pat_TER

-                        .c_pat_CRD = .c_pat_CRD + .lcd(j).pat_CRD

-                        .c_pat_ALL = .c_pat_ALL + .lcd(j).pat_ALL

-                        .c_sale_HIR = .c_sale_HIR + .lcd(j).sale_HIR

-                        .c_sale_TER = .c_sale_TER + .lcd(j).sale_TER

-                        .c_sale_CRD = .c_sale_CRD + .lcd(j).sale_CRD

-                        .c_sale_ALL = .c_sale_ALL + .lcd(j).sale_ALL

-                        .c_pat_LPU = .c_pat_LPU + .lcd(j).pat_LPU

-                    Next j

-                    

-                End If

-            End With

-        Next i

-    End If

-End Function

-

-Function GetLastQtr() As String

-    Dim s As String

-    Dim r As Range

-    Set r = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Do While r.Cells(1, 1) <> ""

-        s = r.Cells(1, 1)

-        Set r = r.Cells.Offset(1, 0)

-    Loop

-    GetLastQtr = s

-End Function

-

-Function GetNextQTR(ent_date As String) As String

-    Dim rd As Range

-    Dim idx As Integer

-    Dim b As Variant

-    Dim dlg As dlg_newQTR

-    Set dlg = New dlg_newQTR

-    

-    On Error GoTo l_exit

-    If ent_date = "" Then

-        Dim ir As Variant

-        idx = 0

-        dlg.Show

-        b = dlg.Tag

-            

-        If IsNumeric(b) Then

-            GetNextQTR = dlg.cbQTR

-        Else

-            GetNextQTR = ""

-        End If

-    Else

-        Set rd = Worksheets(VAR_SHEET).Range("Date_Lst")

-        idx = WorksheetFunction.Match(ent_date, rd, 0)

-        GetNextQTR = WorksheetFunction.index(rd, idx + 1, 1)

-    End If

-l_exit:

-End Function

-<<<<<<
-======================
-mRestView
->>>>>>
-Attribute VB_Name = "mRestView"

-Option Explicit

-

-Sub xlRestoreView()

-Attribute xlRestoreView.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute xlRestoreView.VB_ProcData.VB_Invoke_Func = " \n14"

-    With Application

-        .CommandBars("Standard").Visible = True

-        .CommandBars("Formatting").Visible = True

-        .DisplayFormulaBar = True

-        .DisplayStatusBar = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = True

-        .EditDirectlyInCell = True

-    End With

-End Sub

-<<<<<<
-======================
-dlg_newQTR
->>>>>>
-Attribute VB_Name = "dlg_newQTR"

-Attribute VB_Base = "0{2FC04B4C-EB99-433E-ACDB-A920D02B9B5B}{777B85CC-ADE3-4188-94C8-9E07DA8B5076}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mDec2TS
->>>>>>
-Attribute VB_Name = "mDec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-CHRT_LPU_BBL
->>>>>>
-Attribute VB_Name = "CHRT_LPU_BBL"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Unprotect

-    Range("view_key") = True

-    On Error Resume Next

-    ChangeLabels

-    Range("A1").Select

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Unprotect

-    Dim s As String

-    s = Range("ret_addr")

-    Protect UserInterfaceOnly:=True

-    Wks_select (s)

-End Sub

-

-Sub BCLabelChng_Click()

-    Unprotect

-    If Range("view_key") Then

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать названия"

-    Else

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать объемы"

-    End If

-    Range("view_key") = Not Range("view_key")

-    ChangeLabels

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub ChangeLabels()

-    Dim i As Integer

-    Dim offset_text As Integer

-    Dim src As Range

-    Set src = Range("CHRT_BBL_DATA")

-    

-    offset_text = 3

-    If Range("view_key") Then

-        offset_text = 4

-    End If

-    

-    On Error GoTo ExitLabel

-    

-    With ChartObjects(1).Chart

-        With .SeriesCollection(1)

-            For i = 1 To .Points.Count

-                On Error Resume Next

-                .Points(i).DataLabel.Characters.Text = Format(src.Cells(i, offset_text))

-            Next i

-        End With

-    End With

-ExitLabel:

-End Sub

-

-<<<<<<
-======================
-CHRT_PAT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PAT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-<<<<<<
-======================
-CHRT_PAT_LPU
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_nextQTR
->>>>>>
-Attribute VB_Name = "dlg_nextQTR"

-Attribute VB_Base = "0{3F7D7D75-90F6-4829-9E24-CA5391BB2A03}{A1A0F296-0D28-4123-8E38-82FA6EE6F2EF}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-

-<<<<<<
-======================
-cdbLPU
->>>>>>
-Attribute VB_Name = "cdbLPU"

-Option Explicit

-

-Public Type tLPU_COMMON

-    lpu As tLPU

-    bdgt As tBUDGET

-    i_hir As Long

-    hir() As tHIRURGIA

-    i_ter As Long

-    ter() As tTERAPIA

-    i_ACS As Long

-    ACS() As tACS

-    bdgt_LPU As Long

-    sale_HIR As Long

-    sale_TER As Long

-    sale_CRD As Long

-    sale_ALL As Long

-    pat_HIR As Long

-    pat_TER As Long

-    pat_CRD As Long

-    pat_ALL As Long     ' Сумма всех пациентов на клексане

-    pat_LPU As Long     ' Число потенциальных пациентов для продаж клексана

-End Type

-

-Function Get_LPU_CommonQTR(ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    Get_LPU_CommonQTR = dbGet_LPU_CommonQTR(dbConnection, lcd, objQTR)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_CommonQTR(dbConnection As Object, ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    i = dbGetAllLPUbyQTR(dbConnection, allLPU, objQTR.entry_date)

-    dbGet_LPU_CommonQTR = i

-    If i > 0 Then

-        ReDim lcd(i)

-        For i = 1 To UBound(allLPU)

-            dbGet_LPU_Common dbConnection, lcd(i), allLPU(i), objQTR

-        Next i

-    End If

-End Function

-

-Sub Get_LPU_Common(ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    dbGet_LPU_Common dbConnection, lcd, cLPU, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbGet_LPU_Common(dbConnection As Object, ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-

-    lcd.lpu = cLPU

-    lcd.bdgt = dbGet_BDGT_Record(dbConnection, cLPU.id, objQTR.entry_date)

-    lcd.i_hir = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, lcd.hir, cLPU.id, objQTR.entry_date)

-    lcd.i_ter = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, lcd.ter, cLPU.id, objQTR.entry_date)

-    lcd.i_ACS = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, lcd.ACS, cLPU.id, objQTR.entry_date)

-    With lcd

-        .bdgt_LPU = .bdgt.bdgt_NFG + .bdgt.bdgt_NMG

-        .pat_LPU = 0

-        If .i_hir > 0 Then

-            .pat_HIR = .hir(1).patients_ambulator_clexan + .hir(1).patients_stationar_clexan

-            .sale_HIR = objQTR.ClxnH20mg * (.hir(1).patients_ambulator_clexan_20mg + .hir(1).patients_stationar_clexan_20mg)

-            .sale_HIR = .sale_HIR + objQTR.ClxnH40mg * (.hir(1).patients_ambulator_clexan_40mg + .hir(1).patients_stationar_clexan_40mg)

-            .pat_LPU = .pat_LPU + .hir(1).operations_per_quarter

-        End If

-        If .i_ter > 0 Then

-            .pat_TER = .ter(1).patients_ambulator_clexan + .ter(1).patients_stationar_clexan

-            .sale_TER = .pat_TER * objQTR.ClxnT40mg

-            .pat_LPU = .pat_LPU + .ter(1).patients_per_quarter

-        End If

-        If .i_ACS > 0 Then

-            .pat_CRD = .ACS(1).patients_stationar_clexan

-            .sale_CRD = .pat_CRD * objQTR.ClxnC_ACS

-            .pat_LPU = .pat_LPU + .ACS(1).patients_per_quarter

-        End If

-        .pat_ALL = .pat_HIR + .pat_TER + .pat_CRD

-        .sale_ALL = .sale_HIR + .sale_TER + .sale_CRD

-    End With

-End Sub

-

-<<<<<<
-======================
-CHRT_PIE
->>>>>>
-Attribute VB_Name = "CHRT_PIE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-   

-    Unprotect

-    On Error Resume Next

-    Range("P5:Q24").Sort _

-        Key1:=Range("Q5"), _

-        Order1:=xlDescending, _

-        Header:=xlGuess, _

-        OrderCustom:=1, _

-        MatchCase:=False, _

-        Orientation:=xlTopToBottom

-        

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PLN_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PLN_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_BDGT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_BDGT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_LPU_delete
->>>>>>
-Attribute VB_Name = "dlg_LPU_delete"

-Attribute VB_Base = "0{91AE5FA0-01C7-4C10-9E5F-D1D2DDF29401}{5726592A-BC0A-4E79-A963-35D354045716}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlg_Mail
->>>>>>
-Attribute VB_Name = "dlg_Mail"

-Attribute VB_Base = "0{FB055133-927F-41FF-BC90-442833A40591}{11BCAB43-1EDD-440B-AB0E-20CD6E42E11A}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dbREP_id
->>>>>>
-Attribute VB_Name = "dbREP_id"

-Public Type tID_REP

-    id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Public Type tID_REP_COMMON

-    id_rep As tID_REP

-    i_qtr As Long

-    qtrs As tQTR_COMMON

-End Type

-<<<<<<
-======================
-cdbExport
->>>>>>
-Attribute VB_Name = "cdbExport"

-Option Explicit

-

-Function GetDBSN() As String

-    Dim n As Long

-    Randomize Timer

-    n = Int((100000000 - 1000000 + 1) * Rnd + 1000000)

-    GetDBSN = Dec2ThirtySix(n)

-End Function

-

-Sub dbExport()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim last_qtr As String

-    

-    On Error GoTo ErrHandler

-    

-    last_qtr = GetLastQTR_fromDB

-    If last_qtr = "" Then

-        MsgBox "Нет записей в базе данных. Экспорт невозможен.", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & last_qtr & "_" & GetDBSN() & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Данные экспортированы в файл:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для передачи", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-Exit Sub

-

-ErrHandler:

-    If err.number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-<<<<<<
-======================
-mRegs
->>>>>>
-Attribute VB_Name = "mRegs"

-Option Explicit

-

-Function GetRegionName(idx As Integer) As String

-    GetRegionName = Worksheets(REGS_SHEET).Range("LST_REGIONS").Cells(idx + 1, 1).Text

-End Function

-

-Function GetCityName(idx_reg As Integer, idx_city As Integer) As String

-    GetCityName = Worksheets(REGS_SHEET).Range("CITY_TABLES").Offset(idx_city + 1, idx_reg * 2).Text

-End Function

-

-Sub t()

-    Dim r As Integer

-    Dim c As Integer

-    Dim s As String

-    

-    r = 3

-    c = 3

-    s = GetRegionName(r)

-    s = s & ", " & GetCityName(r, c)

-    MsgBox s

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Save

-End Sub

-

-Private Sub Workbook_Open()

-    FindRestoreData

-End Sub

-

-Sub FindRestoreData()

-    Dim i As Integer

-    Dim def_dir As String

-    Dim dbname As String

-    Dim caption As String

-    caption = PROGRAM_NAME + " " + PROGRAM_VERSION

-    If MsgBox("Восстановление данных. Продолжить?", vbYesNo, caption) = vbYes Then

-        def_dir = "C:\CLEXANE"

-        If GetDBName(def_dir, dbname) Then

-            HWReset dbname

-            MsgBox "Данные в файле " + dbname + " восстановлены :)", vbOKOnly, caption

-        Else

-            MsgBox "Выход без изменений"

-        End If

-    End If

-    With Application

-        .DisplayAlerts = False

-        .Quit

-    End With

-End Sub

-

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-mDataBase
->>>>>>
-Attribute VB_Name = "mDataBase"

-Option Explicit

-

-Sub dbOpenConnection(dbConnection As Object, dbname As String)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = dbname

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, SQL As String)

-    dbConnection.Execute (SQL)

-End Sub

-

-

-

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-End Sub

-

-Function Double2Str(ByVal d As Double, ByVal precision As Integer, Optional Delim As String = ".") As String

-    Dim s As String

-    If Not precision > 0 Then

-        s = Round(d)

-    Else

-        Dim i As Integer

-        i = Fix(d)

-        s = i & Delim

-        d = Abs(d - i)

-        Do

-            precision = precision - 1

-            d = d * 10

-            If precision > 0 Then

-                i = Fix(d)

-            Else

-                i = Round(d)

-            End If

-            If i < 1 Then

-                s = s & "0"

-            Else

-                s = s & i

-                d = d - i

-            End If

-        Loop While precision > 0

-    End If

-    Double2Str = s

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetWBName(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBName = Right(FullName, s_len - pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.Count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.Name = VAR_SHEET Or sh.Name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane"

-Public Const PROGRAM_VERSION As String = "version 1.6"

-Public Const PROGRAM_FILENAME As String = "clexane-mr"

-Public Const PROGRAM_EXPORTNAME As String = "mr-ex-"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20030329

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "O40"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Sub HWReset(dbname As String)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection, dbname

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-mGetDBName
->>>>>>
-Attribute VB_Name = "mGetDBName"

-Option Explicit

-

-Const OFN_ALLOWMULTISELECT As Long = 512

-Const OFN_EXPLORER As Long = 524288

-Const OFN_HIDEREADONLY As Long = 4

-Const OFN_NONETWORKBUTTON As Long = 131072

-Const OFN_READONLY As Long = 1

-       

-Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _

-    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

-

-Private Type OPENFILENAME

-    lStructSize As Long

-    hWndOwner As Long

-    hInstance As Long

-    lpstrFilter As String

-    lpstrCustomFilter As String

-    nMaxCustFilter As Long

-    nFilterIndex As Long

-    lpstrFile As String

-    nMaxFile As Long

-    lpstrFileTitle As String

-    nMaxFileTitle As Long

-    lpstrInitialDir As String

-    lpstrTitle As String

-    flags As Long

-    nFileOffset As Integer

-    nFileExtension As Integer

-    lpstrDefExt As String

-    lCustData As Long

-    lpfnHook As Long

-    lpTemplateName As String

-End Type

-

-Function GetDBName(DB_dir As String, dbname As String) As Boolean

-    Dim OpenFile As OPENFILENAME

-    Dim lReturn As Long

-    Dim sFilter As String

-    

-    OpenFile.lStructSize = Len(OpenFile)

-    '         OpenFile.hwndOwner = Form1.hWnd

-    '         OpenFile.hInstance = App.hInstance

-    sFilter = "Clexane Data Files" & Chr(0) & "clexane*.mdb" & Chr(0)

-    OpenFile.lpstrFilter = sFilter

-    OpenFile.nFilterIndex = 1

-    OpenFile.lpstrFile = String(257, 0)

-    OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1

-    OpenFile.lpstrFileTitle = OpenFile.lpstrFile

-    OpenFile.nMaxFileTitle = OpenFile.nMaxFile

-    OpenFile.lpstrInitialDir = DB_dir

-    OpenFile.lpstrTitle = "Исправление данных"

-    OpenFile.flags = OFN_HIDEREADONLY + OFN_EXPLORER

-    lReturn = GetOpenFileName(OpenFile)

-    If lReturn = 0 Then

-        GetDBName = False

-        dbname = ""

-    Else

-        GetDBName = True

-        Dim flist() As String

-        flist = Split(OpenFile.lpstrFile, Chr(0), Compare:=vbBinaryCompare)

-        dbname = flist(0)

-    End If

-End Function

-

-

-<<<<<<
-Project Name : 'ClexaneRM'
-Quirk - duff tag length======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    ThisWorkbook.Worksheets(RM_QTR_SHEET).ClearRMName

-    

-    Application.EnableEvents = True

-    Set MyAppEvents.app = Application

-    

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    

-    MyAppEvents.CheckWorkBooksArround ThisWorkbook

-    

-    cmSetStandaloneMode

-    

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-    

-    Application.ScreenUpdating = True

-    

-    If CheckUser Then

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).update_history

-        Application.Calculate

-    End If

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    

-    Dim RestMode As Boolean

-    RestMode = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE")

-    

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-'        If RestMode Then

-            ThisWorkbook.Saved = True

-'        Else

-'            ThisWorkbook.Save

-'        End If

-    End If

-    Application.Caption = Empty

-    Application.CommandBars(STDBAR_NAME).Reset

-    If RestMode Then

-        xlRestoreView

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    End If

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-    Dim MaxX, MaxY As Integer

-    With ThisWorkbook.Worksheets(TITLE_SHEET)

-        MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-        MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-    End With

-

-    With ThisWorkbook.Application

-        .ScreenUpdating = False

-        .WindowState = xlNormal

-        .Height = MaxY

-        .Width = MaxX

-    End With

-End Sub

-

-

-

-

-

-<<<<<<
-======================
-REP_QTR
->>>>>>
-Attribute VB_Name = "REP_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CQTR_QT As Integer = 0

-Const CQTR_ID As Integer = 1

-Const CQTR_PLN As Integer = 2

-Const CQTR_FCT As Integer = 3

-Const CQTR_BDG As Integer = 4

-Const CQTR_CNT As Integer = 5

-Const CQTR_BEDS As Integer = 6

-Const CQTR_HIR As Integer = 7

-Const CQTR_TER As Integer = 8

-Const CQTR_CRD As Integer = 9

-Const CQTR_CLXN_BDG As Integer = 10

-Const CQTR_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub update_history()

-    Dim objQTR() As tQTR

-    Dim i As Long

-    Dim r As Range

-    Dim cRep As tREPID

-

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    Range("D4") = cRep.LastName

-    Range("D5") = cRep.FirstName

-

-    Range("H4") = GetRegionName(cRep.Region)

-    Range("H5") = GetCityName(cRep.Region, cRep.City)

-

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetAll_QTR_Records_by_REP(objQTR, "%", cRep.rep_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CQTR_QT) = objQTR(i).entry_date

-        Next i

-    End If

-    Dim qcd() As tQTR_COMMON

-    i = Get_QTR_CommonList_by_REP(qcd, "%", cRep.rep_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(qcd)

-            r.Offset(i - 1, CQTR_QT) = qcd(i).qtr.entry_date

-            r.Offset(i - 1, CQTR_ID) = qcd(i).qtr.id

-            r.Offset(i - 1, CQTR_PLN) = qcd(i).qtr.sale_PLAN

-            r.Offset(i - 1, CQTR_FCT) = qcd(i).c_sale_ALL

-            r.Offset(i - 1, CQTR_BDG) = qcd(i).c_bdgt_LPU

-            r.Offset(i - 1, CQTR_CNT) = qcd(i).i_lcd

-            r.Offset(i - 1, CQTR_BEDS) = qcd(i).c_beds

-            r.Offset(i - 1, CQTR_HIR) = qcd(i).c_pat_HIR

-            r.Offset(i - 1, CQTR_TER) = qcd(i).c_pat_TER

-            r.Offset(i - 1, CQTR_CRD) = qcd(i).c_pat_CRD

-            If qcd(i).c_bdgt_LPU <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_BDG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_LPU

-            End If

-            If qcd(i).c_bdgt_NMG <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_NMG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CQTR_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRepQtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect UserInterfaceOnly:=True

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CQTR_ID + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    i = currRange.Column - Range(CINP_AREA).Column

-

-    QTR_ID = r

-

-    If QTR_ID = 0 Then

-        Worksheets(VAR_SHEET).Range("USER_ACTION") = 1

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        If i > CQTR_FCT Then

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-            Range("LAST_FOCUS") = currRange.address

-        Else

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 3

-            Range("LAST_FOCUS") = currRange.address

-        End If

-    End If

-    Cancel = True

-    btHomeDo_IT

-End Sub

-

-<<<<<<
-======================
-mRep_QTR
->>>>>>
-Attribute VB_Name = "mRep_QTR"

-Option Explicit

-

-Sub NoFunc()

-    MsgBox "Функция не доступна", vbOKOnly, PROGRAM_NAME

-End Sub

-

-Sub DO_Price_qtr(ent_date As String)

-    Dim qtr As tQTR

-    Dim res As Integer

-    Dim cRep As tREPID

-

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    qtr = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-

-    If qtr.id = 0 Then

-        qtr.entry_date = ent_date

-

-        With Worksheets(VAR_SHEET)

-            qtr.ClxnH20mg = .Range("ClxnH20mg")

-            qtr.ClxnH40mg = .Range("ClxnH40mg")

-            qtr.ClxnT40mg = .Range("ClxnT40mg")

-            qtr.ClxnC_ACS = .Range("ClxnC_ACS")

-            qtr.ClxnC_IM = .Range("ClxnC_IM")

-        End With

-    End If

-

-    Dim dlg_nq As dlg_nextQTR

-    Set dlg_nq = New dlg_nextQTR

-

-    With dlg_nq

-        .tb_qtr_name = qtr.entry_date

-        .tb_bdgt_avts = qtr.sale_PLAN

-        .tb_qtr_name = qtr.entry_date

-        .tb_ClxnH20mg = qtr.ClxnH20mg

-        .tb_ClxnH40mg = qtr.ClxnH40mg

-        .tb_ClxnT40mg = qtr.ClxnT40mg

-        .tb_ClxnC_ACS = qtr.ClxnC_ACS

-        .tb_ClxnC_IM = qtr.ClxnC_IM

-    End With

-

-    dlg_nq.Show

-End Sub

-

-Sub DO_Edit_qtr(ent_date As String)

-    If ent_date = "" Then

-        NoFunc

-    Else

-        Dim rep_id As Long

-        rep_id = Worksheets(REP_QTR_SHEET).Range("REP_ID")

-        With ThisWorkbook.Worksheets("LPU_LIST")

-            .Range("VIEW_ONLY") = True

-            .Range("ent_date") = ent_date

-            .Range("REP_ID") = rep_id

-            .Select

-        End With

-    End If

-End Sub

-

-Sub DO_Delete_qtr(ent_date As String)

-    If ent_date <> "" Then

-        MsgBox "Удалить данные за период [" & ent_date & "] нельзя ", vbOKOnly, PROGRAM_NAME

-    End If

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-

-Sub btHomeDo_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    idx = Worksheets(VAR_SHEET).Range("USER_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            NoFunc

-            ' Обновляем экран

-        Case 2

-            DO_Edit_qtr ent_date

-        Case 3

-            DO_Price_qtr ent_date

-        Case 4

-            NoFunc

-    End Select

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-Sub Delete_qtr()

-'    Dim ent_date As String

-'    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-'    DO_Delete_qtr ent_date

-End Sub

-

-Sub btREP_QTR_RET_IT()

-    Dim s As String

-    With Worksheets("REP_QTR")

-        .Range("LAST_FOCUS") = ""

-        s = .Range("ret_addr")

-        .Range("ret_addr") = ""

-    End With

-    If s <> "" Then

-        ThisWorkbook.Worksheets(s).Select

-    Else

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane[RM]"

-Public Const PROGRAM_VERSION As String = "version 1.3"

-Public Const PROGRAM_FILENAME As String = "clexane-rm"

-Public Const PROGRAM_BACKUPNAME As String = "rm-backup-"

-Public Const PROGRAM_EXPORTNAME As String = "rm-ex-"

-Public Const PROGRAM_IMPORTNAME As String = "mr-ex-*"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20030329

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "O40"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-Public Const RM_QTR_SHEET As String = "RM_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-

-End Sub

-

-Function Double2Str(ByVal d As Double, ByVal precision As Integer, Optional Delim As String = ".") As String

-    Dim s As String

-    If Not precision > 0 Then

-        s = Round(d)

-    Else

-        Dim i As Integer

-        i = Fix(d)

-        s = i & Delim

-        d = Abs(d - i)

-        Do

-            precision = precision - 1

-            d = d * 10

-            If precision > 0 Then

-                i = Fix(d)

-            Else

-                i = Round(d)

-            End If

-            If i < 1 Then

-                s = s & "0"

-            Else

-                s = s & i

-                d = d - i

-            End If

-        Loop While precision > 0

-    End If

-    Double2Str = s

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetWBName(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBName = Right(FullName, s_len - pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.name = VAR_SHEET Or sh.name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-<<<<<<
-======================
-Var
->>>>>>
-Attribute VB_Name = "Var"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-title
->>>>>>
-Attribute VB_Name = "title"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LPU_LIST
->>>>>>
-Attribute VB_Name = "LPU_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentLPU_ID() As Long

-    Dim r As Range

-

-    With Worksheets("LPU_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CLPU_ID)

-    End With

-

-    getCurrentLPU_ID = r

-End Function

-

-Public Sub LPU_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectLPU_NAME(lpu_id As Long, ent_date As String)

-    If Range("VIEW_ONLY") = True Then

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    Dim cLPU As tLPU

-    If lpu_id = 0 Then

-        cLPU.id = 0

-        cLPU.rep_id = 0

-        cLPU.address = ""

-        cLPU.name = ""

-    Else

-        cLPU = Get_LPU_Record(lpu_id)

-    End If

-    EditLPU cLPU, getEnt_date

-    Worksheet_Activate

-End Sub

-

-Sub SelectLPU_BDGT(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    vo = Range("VIEW_ONLY")

-    If lpu_id = 0 Then

-        SelectLPU_NAME lpu_id, ent_date

-    Else

-        With ThisWorkbook.Worksheets("LPU_BDGT")

-            .Range("VIEW_ONLY") = vo

-            .Range("ret_addr") = "LPU_LIST"

-            .Range("REP_ID") = r_id

-            .Range("ent_date") = ent_date

-            .Range("lpu_id") = lpu_id

-        End With

-    End If

-End Sub

-

-Sub SelectLPU_HIR(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_HIR")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Sub SelectLPU_TER(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_TER")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Sub SelectLPU_C_ACS(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim r_id As Long

-    r_id = Range("REP_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_C_ACS")

-        .Range("REP_ID") = r_id

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect UserInterfaceOnly:=True

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateLPUList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim lpu_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CINP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CINP_AREA).row, CLPU_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    lpu_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CINP_AREA).Column

-

-    If lpu_id = 0 Then

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    End If

-

-    If lpu_id = 0 Then

-        i = CLPU_NAME

-        Range("JUMP") = ""

-    End If

-    Select Case i

-        Case CLPU_NAME, CLPU_NAME1, CLPU_NAME2, CLPU_BEDS

-            SelectLPU_NAME lpu_id, ent_date

-            Range("JUMP") = ""

-

-        Case CLPU_NMG, CLPU_NFG, CLPU_PLAN, CLPU_FACT

-            SelectLPU_BDGT lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-

-        Case CLPU_HIR

-            SelectLPU_HIR lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_HIR"

-

-        Case CLPU_TER

-            SelectLPU_TER lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_TER"

-

-        Case CLPU_CAR

-            SelectLPU_C_ACS lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        Case Else

-            Range("JUMP") = ""

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateLPUList()

-    Dim lcd() As tLPU_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-    Dim objQTR As tQTR

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    ent_date = getEnt_date

-

-'     ent_date = "%" ' % - all records

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-    i = Get_LPU_CommonQTR(lcd, objQTR)

-

-'     стираем ФИО

-    Range("C3:C4").ClearContents

-

-    Range("C3") = cRep.LastName

-    Range("C4") = cRep.FirstName

-    Range("G3") = GetRegionName(cRep.Region)

-    Range("G4") = GetCityName(cRep.Region, cRep.City)

-    Range("G5") = objQTR.sale_PLAN

-

-

-

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(lcd)

-            r.Offset(i - 1, CLPU_NAME) = lcd(i).lpu.name

-            r.Offset(i - 1, CLPU_ID) = lcd(i).lpu.id

-            r.Offset(i - 1, CLPU_BEDS) = lcd(i).lpu.beds

-

-

-            r.Offset(i - 1, CLPU_NFG) = lcd(i).bdgt.bdgt_NFG

-            r.Offset(i - 1, CLPU_NMG) = lcd(i).bdgt.bdgt_NMG

-            r.Offset(i - 1, CLPU_PLAN) = lcd(i).bdgt.sale_PLAN

-

-            r.Offset(i - 1, CLPU_HIR) = lcd(i).pat_HIR

-            r.Offset(i - 1, CLPU_TER) = lcd(i).pat_TER

-            r.Offset(i - 1, CLPU_CAR) = lcd(i).pat_CRD

-            r.Offset(i - 1, CLPU_FACT) = lcd(i).sale_ALL

-            r.Offset(i - 1, CLPU_PAT_LPU) = lcd(i).pat_LPU

-            r.Offset(i - 1, CLPU_BDGT) = lcd(i).bdgt_LPU

-            If lcd(i).bdgt_LPU > 0 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = lcd(i).sale_ALL / lcd(i).bdgt_LPU

-            End If

-            If r.Offset(i - 1, CLPU_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{F2A5159C-AEB6-4066-B85F-339184DAFECD}{712D78F6-CCB6-499E-9674-B992A7482317}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-dbACS
->>>>>>
-Attribute VB_Name = "dbACS"

-Option Explicit

-

-Public Type tACS

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    patients_with_geparins As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objACS.ID <> 0 then updatre else insert

-Sub Insert_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objACS.id <> 0 Then

-        dbUpdate_ACS_Record dbConnection, objACS

-    Else

-        dbInsert_ACS_Record dbConnection, objACS

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_ACS_RecordsByLPU_ID(ByRef all_ACS_() As tACS, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_ACS_RecordsByLPU_ID = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, all_ACS_, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_ACS_Record dbConnection, objACS

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub dbInsert_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_acs", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objACS

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("patients_with_geparins") = .patients_with_geparins

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objACS.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim Update_SQL As String

-    

-    With objACS

-        Update_SQL = "UPDATE lpu_acs SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "patients_with_geparins=" & .patients_with_geparins & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_ACS_RecordsbyLPU_ID(dbConnection As Object, all_ACS() As tACS, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_ACS_SQL As String

-    Dim getAll_ACS_SQL As String

-    Dim ACS_Count As Long

-    ACS_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_ACS_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        ACS_Count = dbRecordset("ACS_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_ACS_RecordsbyLPU_ID = ACS_Count

-    

-    If ACS_Count > 0 Then

-        'we have records

-        ReDim all_ACS(1 To ACS_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_ACS_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_ACS As tACS

-                 With tmp_ACS

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .patients_with_geparins = dbRecordset("patients_with_geparins")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 all_ACS(index) = tmp_ACS

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE ID=" & objACS.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_ACS_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_HIR
->>>>>>
-Attribute VB_Name = "LPU_CLSN_HIR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-

-        Dim objHir As tHIRURGIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objHir

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .operations_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L9")

-                .patients_ambulator_clexan_20mg = Range("L10")

-                .patients_ambulator_clexan_40mg = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L19")

-                .patients_stationar_clexan_20mg = Range("L20")

-                .patients_stationar_clexan_40mg = Range("L21")

-            End With

-            Insert_Hir_Record objHir

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objHir.id = Range("rec_id")

-                    If objHir.id <> 0 Then

-                        Delete_Hir_Record objHir

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objHir As tHIRURGIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    With objHir

-        Range("rec_id") = .id

-        Range("F6") = .operations_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L9") = .patients_ambulator_clexan

-        Range("L10") = .patients_ambulator_clexan_20mg

-        Range("I21") = .patients_stationar_nmg

-        Range("L19") = .patients_stationar_clexan

-        Range("L20") = .patients_stationar_clexan_20mg

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id)

-

-        formula = "=" & qtr.ClxnH20mg & "*($L$10+$L$20)+" & qtr.ClxnH40mg & "*($L$11+$L$21)"

-        Range("F11").formula = formula

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objHir() As tHIRURGIA

-        Dim i As Integer

-        i = GetAll_Hir_RecordsByLPU_ID(objHir, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.3

-        Else

-            SetupData objHir(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-mSapes
->>>>>>
-Attribute VB_Name = "mSapes"

-Option Explicit

-

-Const SHAPE_COLOR As Integer = 1

-Const SHAPE_NAME As Integer = 2

-

-

-Sub ShapeView(r_sh_finite_state As Range)

-    Dim chk As Range

-    Dim s As String

-    Dim c, idx As Integer

-    For Each chk In r_sh_finite_state

-        idx = 0

-        If chk = "+" Then

-            c = chk.Offset(0, idx + SHAPE_COLOR)

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While c <> 0

-                ShapeFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s)), c

-                idx = idx + 2

-                c = chk.Offset(0, idx + SHAPE_COLOR)

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        Else

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While s <> ""

-                ShapeUnFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s))

-                idx = idx + 2

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        End If

-    Next chk

-End Sub

-

-Sub ShapeFill(sh As ShapeRange, ByVal color As Integer)

-    sh.Fill.Visible = msoTrue

-    sh.Fill.Solid

-    sh.Fill.ForeColor.SchemeColor = color

-    sh.Fill.Transparency = 0#

-End Sub

-

-Sub ShapeUnFill(sh As ShapeRange)

-    sh.Fill.Visible = msoFalse

-    sh.Fill.Transparency = 0#

-End Sub

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Public Const INPUT_NO = 0

-Public Const INPUT_NUMBER = 1

-Public Const INPUT_PERCENT = 2

-Public Const INPUT_STRING = 3

-Public Const INPUT_CHECK = 4

-

-Public Const INP_IDX_TYPE = 1

-Public Const INP_IDX_NEXT = 2

-Public Const INP_IDX_MIN = 3

-Public Const INP_IDX_MAX = 4

-Public Const INP_IDX_DEP = 5

-Public Const INP_IDX_ALT = 7

-

-

-Public Type tInputSet

-    vType As Integer

-    vMin As Long

-    vMax As Long

-    rChk As String

-End Type

-

-Function is_input_cell(ByVal Target As Range, inputs As Range) As tInputSet

-    Dim t As Range

-    Dim iset As tInputSet

-    Dim test As Range

-    iset.vType = INPUT_NO

-    iset.vMin = 0

-    iset.vMax = 0

-    iset.rChk = ""

-    is_input_cell = iset

-

-' Закоментировать следующую сточку для работы

-'  Exit Function

-

-    Set test = Target.Cells(1, 1)

-    For Each t In inputs

-        If Range(t).Column = test.Column And Range(t).row = test.row Then

-            iset.vType = t.Offset(0, INP_IDX_TYPE).Value

-            Select Case iset.vType

-                Case INPUT_CHECK

-                    iset.rChk = t.Offset(0, INP_IDX_ALT)

-                Case INPUT_NUMBER, INPUT_PERCENT

-                    iset.vMin = t.Offset(0, INP_IDX_MIN).Value

-                    iset.vMax = t.Offset(0, INP_IDX_MAX).Value

-            End Select

-            is_input_cell = iset

-            Exit Function

-        End If

-    Next t

-End Function

-

-Function GetFocusAddress(ByVal r As Range, f_next As Range) As String

-    Dim chk, t As Range

-    

-    For Each chk In f_next

-        For Each t In r

-            If t.address = chk Then

-                GetFocusAddress = chk

-                Exit Function

-            End If

-            If Range(chk).Column = t.Column - 1 And Range(chk).row = t.row _

-            Or Range(chk).Column = t.Column And Range(chk).row = t.row - 1 _

-            Then

-                If Range(chk) <> "" Then

-                    If Range(chk) = 0 Then

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_ALT)).address

-                    Else

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_NEXT)).address

-                    End If

-                Else

-                    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-                End If

-                Exit Function

-            End If

-        Next t

-    Next chk

-    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-End Function

-

-Sub SetDependet(r As Range, inputs As Range)

-    Dim chk As Range

-    Dim s, serr As String

-    Dim idx As Integer

-    Dim iset As tInputSet

-    Dim err_found As Boolean

-    

-    If r.count > 1 Then

-        Exit Sub

-    End If

-    

-    err_found = False

-    For Each chk In inputs

-        idx = INP_IDX_DEP

-        

-        

-        iset.vType = chk.Offset(0, INP_IDX_TYPE).Value

-        Select Case iset.vType

-            Case INPUT_NUMBER, INPUT_PERCENT

-                iset.vMin = chk.Offset(0, INP_IDX_MIN).Value

-                iset.vMax = chk.Offset(0, INP_IDX_MAX).Value

-                

-                If Range(chk) > iset.vMax Then

-                    err_found = True

-                    Range(chk) = iset.vMax

-                    serr = "Выход за дозволенный диапазон [" & iset.vMin & ".." & iset.vMax & "]! Данные скорректированы."

-                End If

-                

-                If Range(chk) = "" Then

-                    s = chk.Offset(0, idx)

-                    Do While s <> ""

-                        Range(s) = ""

-                        idx = idx + 1

-                        s = chk.Offset(0, idx)

-                    Loop

-                End If

-        End Select

-    Next chk

-    If err_found Then

-        MsgBox serr, vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Function CheckInputData(inputs As Range) As Boolean

-    Dim r As Range

-    

-    CheckInputData = True

-    For Each r In inputs

-        If Range(r) = "" Then

-            CheckInputData = False

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100.", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Sub Check_Int_Number(Target As Range, Def_Val As Long)

-    Dim err As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    err = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                err = True

-            End If

-        End If

-    Next r

-    If err Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_TER
->>>>>>
-Attribute VB_Name = "LPU_CLSN_TER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim objTer As tTERAPIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objTer

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .patients_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L20")

-            End With

-            Insert_Ter_Record objTer

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objTer.id = Range("rec_id")

-                    If objTer.id <> 0 Then

-                        Delete_Ter_Record objTer

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objTer As tTERAPIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    With objTer

-        Range("rec_id") = .id

-        Range("F6") = .patients_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L11") = .patients_ambulator_clexan

-        Range("I21") = .patients_stationar_nmg

-        Range("L20") = .patients_stationar_clexan

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id)

-        formula = "=" & qtr.ClxnT40mg & "*($L$12+$L$20)"

-        Range("F11").formula = formula

-

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objTer() As tTERAPIA

-        Dim i As Integer

-        i = GetAll_Ter_RecordsByLPU_ID(objTer, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.25

-        Else

-            SetupData objTer(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{5D2CB2D2-3E5E-4B6E-9E0C-2EEBA5E10E17}{C891C133-B6B4-43D3-B411-B4A821905C23}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-LPU_BDGT
->>>>>>
-Attribute VB_Name = "LPU_BDGT"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub SetDefFocus()

-    Range(Range("DEF_FOCUS")).Select

-End Sub

-

-Public Sub ClearData()

-    ClearSheetData

-End Sub

-

-Sub ClearSheetData()

-    If Range("F10") = 0 And Range("F13") = 0 Then

-        Range("F11:F18") = ""

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("F11:F13") = ""

-    End If

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim bdgt As tBUDGET

-        Dim test As Boolean

-        Dim sum As Long

-        With bdgt

-            .lpu_id = Range("lpu_id")

-            .id = Range("rec_id")

-            .entry_date = Range("ent_date")

-            .bdgt_NMG = Round(Range("F11").Value, 0)

-            .bdgt_NFG = Round(Range("F12").Value, 0)

-            .sale_PLAN = Round(Range("F13").Value, 0)

-

-            sum = .bdgt_NFG + .bdgt_NMG - .sale_PLAN

-            test = .bdgt_NFG <> 0 Or .bdgt_NMG <> 0 Or .sale_PLAN <> 0

-        End With

-        If test Then

-            If sum < 0 Then

-                MsgBox _

-                    "Ваш план превышает выделенный на гепарины бюджет. Сохранить данные?", _

-                    vbOKOnly, PROGRAM_NAME

-            End If

-            If test Then

-                Insert_BDGT_Record bdgt

-            End If

-        Else

-            If bdgt.id <> 0 Then

-                If vbYes = MsgBox("Удалить данные из базы!", vbYesNo, PROGRAM_NAME) Then

-                    Delete_BDGT_Record bdgt

-                End If

-                ret_back Range("DEF_FOCUS").Worksheet

-                Exit Sub

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-    End If

-

-   ClearData

-   ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(cLPU As tLPU_COMMON)

-    Dim t_sum As Long

-    t_sum = 0

-' Setup budget data

-    Range("F11") = cLPU.bdgt.bdgt_NMG

-    Range("F12") = cLPU.bdgt.bdgt_NFG

-    Range("F13") = cLPU.bdgt.sale_PLAN

-

-    With cLPU

-        Range("F14") = .pat_ALL

-        Range("F15") = .pat_HIR

-        Range("F16") = .pat_TER

-        Range("F17") = .pat_CRD

-        Range("F18") = .sale_ALL

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-    ws_activate

-End Sub

-

-

-Sub ws_activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Dim cLPU As tLPU_COMMON

-    Dim objQTR As tQTR

-    Dim objLPU As tLPU

-    Dim ent_date As String

-    Dim id As Long

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    id = Range("lpu_id").Value

-    ent_date = Range("ent_date")

-    

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id)

-

-    objLPU = Get_LPU_Record(id)

-    Get_LPU_Common cLPU, objLPU, objQTR

-

-    If cLPU.lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = cLPU.lpu.beds

-        Range("lpu_name") = cLPU.lpu.name

-        Range("lpu_addr") = cLPU.lpu.address

-        Range("rec_id") = cLPU.bdgt.id

-

-        SetupData cLPU

-

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-'    MsgBox Target.address

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case INPUT_CHECK

-

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{BB60E38F-A4AB-4AB4-91D0-40AA798D9F5C}{BE9A54D9-F093-4755-9E17-0B47BB5E2546}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mSheets
->>>>>>
-Attribute VB_Name = "mSheets"

-Option Explicit

-

-Function am_load_now() As Boolean

-    am_load_now = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE")

-End Function

-

-Sub Wks_select(RetSheet As String)

-    Dim sheet As Worksheet

-    For Each sheet In ThisWorkbook.Worksheets

-        If sheet.name = RetSheet Then

-            ThisWorkbook.Worksheets(RetSheet).Select

-            Exit Sub

-        End If

-    Next sheet

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub ret_back(sh As Worksheet)

-    Dim RetSheet As String

-    RetSheet = sh.Range("ret_addr")

-    sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    sh.Range("ret_addr") = ""

-    sh.Range("rec_id") = ""

-    sh.Range("lpu_id") = ""

-    sh.Range("ent_date") = ""

-    sh.Range("lpu_name") = ""

-    sh.Range("lpu_addr") = ""

-    sh.Range("lpu_beds") = ""

-    Wks_select RetSheet

-End Sub

-

-Sub ClearSheetData(r_start As Range)

-    If r_start <> "" Then

-        r_start.Worksheet.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        r_start = ""

-    Else

-        ret_back r_start.Worksheet

-    End If

-End Sub

-

-Sub wks_sel_chng(iset As tInputSet, ByVal Target As Range, sh As Worksheet)

-    Dim DebugMode As Boolean

-    Dim in_range As Range

-    

-    DebugMode = Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-

-    If DebugMode Then

-        sh.Unprotect

-    Else

-        sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    End If

-

-    If iset.vType = INPUT_CHECK Then

-        Set in_range = Target.Worksheet.Range(iset.rChk)

-    Else

-        Set in_range = Target

-    End If

-    

-    Dim str As String

-    str = GetFocusAddress(in_range, sh.Range("h_inputs"))

-

-'    MsgBox Target.Address & "; " & str

-    If str <> Target.address Then

-        sh.Range(str).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-Dlg_lpu_card
->>>>>>
-Attribute VB_Name = "Dlg_lpu_card"

-Attribute VB_Base = "0{2C69E842-8DA9-4240-A0A8-F6B0141DC246}{75AAB28C-ADCF-4D1B-9D5A-AF89E80A810C}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbLPU_List_Change()

-    Dim src As Range

-    Dim idx_src As Integer

-    

-    Set src = Worksheets(VAR_SHEET).Range(Me.cbLPU_List.RowSource)

-    idx_src = Me.cbLPU_List.ListIndex + 1

-    Me.tb_lpu_name.Text = src.Cells(idx_src, 1)

-    Me.tb_lpu_address.Text = src.Cells(idx_src, 2)

-    Me.tbBedsCount.Text = src.Cells(idx_src, 3)

-End Sub

-

-

-Private Sub cbxLPU_List_Enable_Click()

-    

-    If Me.cbxLPU_List_Enable Then

-        

-        Me.tb_lpu_name.Text = ""

-        Me.tb_lpu_name.Enabled = False

-        

-        Me.tb_lpu_address.Text = ""

-        Me.tb_lpu_address.Enabled = False

-        

-        Me.tbBedsCount.Text = ""

-        Me.tbBedsCount.Enabled = False

-        

-        Me.cbLPU_List.Enabled = True

-        cbLPU_List_Change

-    Else

-        Me.tb_lpu_name.Enabled = True

-        Me.tb_lpu_name.Text = ""

-        

-        Me.tb_lpu_address.Enabled = True

-        Me.tb_lpu_address.Text = ""

-        

-        Me.tbBedsCount.Enabled = True

-        Me.tbBedsCount.Text = ""

-        

-        Me.cbLPU_List.Enabled = False

-    End If

-End Sub

-

-<<<<<<
-======================
-UserInfo
->>>>>>
-Attribute VB_Name = "UserInfo"

-Attribute VB_Base = "0{BA873669-5C2D-400A-8A8B-572ACD8CCE4C}{D11400A0-9912-4240-A78C-44C33731216A}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Tag = vbOK

-End Sub

-

-Private Sub cbCity_Change()

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_CITY") = Me.cbCity.ListIndex

-        .Calculate

-    End With

-End Sub

-

-Private Sub cbRegion_Change()

-    Dim LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        NewRangeOffsetCol = cbRegion.Value * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).address

-        NewSumRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).address

-        .Calculate

-        .Range("IDX_CITY") = 0

-        cbCity.RowSource = NewCbxRange

-

-    End With

-    cbCity.ListIndex = 0

-End Sub

-

-<<<<<<
-======================
-mREGMAN
->>>>>>
-Attribute VB_Name = "mREGMAN"

-Option Explicit

-

-Sub hwnew()

-    Dim rs As Range

-    Dim re As Object

-    

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    HWReset

-    ReSet_REGMAN_Record

-    With Worksheets("RM_QTR")

-        .ClearRMName

-        .Range("REP_QTR_INPUT_DATA").ClearContents ' Это не ошибка, названия совпадают

-'        .Range("A1").Select

-    End With

-    Worksheets(TITLE_SHEET).Select

-    With Application

-        .DisplayAlerts = False

-        .ThisWorkbook.Save

-        .Quit

-    End With

-End Sub

-

-Function CheckUser() As Boolean

-    Dim objHW() As Long

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    

-    GetHWInfo objHW()

-    i = GetHWRecords(objHW_DB)

-    

-    If i = 0 Then ' First time

-        StoreHWInfo objHW()

-    End If

-    If CheckHWInfo(objHW()) <> True Then

-        CheckUser = False

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    Else

-        CheckUser = SetupUser

-    End If

-End Function

-

-Function SetupUser() As Boolean

-    Dim cREGMAN As tREGMAN

-    Dim idx As Integer

-    Dim dlg_ui As UserInfo

-    

-    Set dlg_ui = New UserInfo

-    

-    cREGMAN = Get_REGMAN_Record()

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_REGION") = cREGMAN.Region

-        .Range("IDX_CITY") = cREGMAN.City

-    End With

-        

-    With dlg_ui

-        .cbRegion = cREGMAN.Region

-        .cbCity = cREGMAN.City

-        .tbFName = cREGMAN.FirstName

-        .tbLName = cREGMAN.LastName

-    End With

-    

-    Worksheets(REGS_SHEET).Calculate

-    

-    Dim test_Ok As Boolean

-    test_Ok = False

-    

-    On Error GoTo l1

-    

-    Do

-        dlg_ui.Show

-        If dlg_ui.Tag = vbOK Then

-            test_Ok = dlg_ui.tbFName.Value <> "" And dlg_ui.tbLName <> ""

-            If test_Ok Then

-                Exit Do

-            Else

-                MsgBox "Введите имя и фамилию", vbOKOnly, PROGRAM_NAME

-            End If

-        Else

-            Exit Do

-        End If

-    Loop Until False

-l1:

-    If test_Ok Then

-        With cREGMAN

-            .Region = dlg_ui.cbRegion.Value

-            .City = dlg_ui.cbCity.Value

-            .FirstName = dlg_ui.tbFName.Value

-            .LastName = dlg_ui.tbLName.Value

-        End With

-        Set_REGMAN_Record cREGMAN

-    Else

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .ThisWorkbook.Saved = True

-            .Quit

-        End With

-    End If

-    SetupUser = test_Ok

-End Function

-

-Sub GetHWInfo(objHW() As Long)

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    i = 1

-    For Each d In dc

-        If d.drivetype = 2 Then ' 2 - HardDisk

-            ReDim Preserve objHW(i)

-            objHW(i) = d.SerialNumber

-            i = i + 1

-        End If

-    Next

-    SortHW objHW

-End Sub

-

-Sub StoreHWInfo(objHW() As Long)

-    UpdateHWRecords objHW

-End Sub

-

-Sub SortHW(objHW() As Long)

-    Dim r As Range

-    Dim rs As Range

-    Dim re As Object

-    Dim i As Integer

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    For i = 1 To UBound(objHW)

-        r = objHW(i)

-        Set r = r.Offset(1, 0)

-    Next i

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).Sort _

-            Key1:=.Range("HW_Number"), _

-            Order1:=xlDescending, _

-            Header:=xlGuess, _

-            OrderCustom:=1, _

-            MatchCase:=False, _

-            Orientation:=xlTopToBottom

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    i = 1

-    Do While r <> ""

-        objHW(i) = r

-        Set r = r.Offset(1, 0)

-        i = i + 1

-    Loop

-End Sub

-

-Function CheckHWInfo(objHW() As Long)

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    CheckHWInfo = False

-        

-    i = GetHWRecords(objHW_DB)

-    If i > 0 Then

-        SortHW objHW_DB

-    End If

-    If UBound(objHW) = UBound(objHW_DB) Then

-        For i = 1 To UBound(objHW)

-            If objHW(i) <> objHW_DB(i) Then

-                Exit Function

-            End If

-        Next i

-        CheckHWInfo = True

-    End If

-End Function

-

-

-<<<<<<
-======================
-dbBudget
->>>>>>
-Attribute VB_Name = "dbBudget"

-Option Explicit

-

-Public Type tBUDGET

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    bdgt_NMG As Long

-    bdgt_NFG As Long

-    sale_PLAN As Long

-End Type

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function GetAll_BDGT_RecordsByLPU_ID(ByRef allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_BDGT_RecordsByLPU_ID = dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection, allBDGT, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function Get_BDGT_Record(ByVal lpu_id As Long, ByVal ent_date As String) As tBUDGET

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    Get_BDGT_Record = dbGet_BDGT_Record(dbConnection, lpu_id, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objBDGT.ID <> 0 then updatre else insert

-Public Sub Insert_BDGT_Record(objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    If objBDGT.id <> 0 Then

-        dbUpdate_BDGT_Record dbConnection, objBDGT

-    Else

-        dbInsert_BDGT_Record dbConnection, objBDGT

-    End If

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Public Sub Delete_BDGT_Record(ByRef objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    dbDelete_BDGT_Record dbConnection, objBDGT

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_BDGT_Record(dbConnection As Object, ByVal lpu_id As Long, ent_date As String) As tBUDGET

-    

-    Dim sql As String

-    Dim objBDGT As tBUDGET

-    

-    With objBDGT

-        .id = 0

-        .lpu_id = lpu_id

-        .entry_date = ent_date

-        .bdgt_NMG = 0

-        .bdgt_NFG = 0

-        .sale_PLAN = 0

-    End With

-        

-    

-    sql = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        With objBDGT

-            .entry_date = dbRecordset("entry_date")

-            .id = dbRecordset("id")

-            .lpu_id = dbRecordset("lpu_id")

-            .bdgt_NFG = dbRecordset("bdgt_NFG")

-            .bdgt_NMG = dbRecordset("bdgt_NMG")

-            .sale_PLAN = dbRecordset("sale_PLAN")

-        End With

-    End If

-    

-    dbGet_BDGT_Record = objBDGT

-End Function

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection As Object, allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_BDGT_SQL As String

-    Dim getAll_BDGT_SQL As String

-    Dim BDGT_Count As Long

-    BDGT_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_BDGT_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        BDGT_Count = dbRecordset("BDGT_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_BDGT_RecordsbyLPU_ID = BDGT_Count

-    

-    If BDGT_Count > 0 Then

-        'we have records

-        ReDim allBDGT(1 To BDGT_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_BDGT_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpBDGT As tBUDGET

-                 With tmpBDGT

-                    .entry_date = dbRecordset("entry_date")

-                    .id = dbRecordset("id")

-                    .lpu_id = dbRecordset("lpu_id")

-                    .bdgt_NFG = dbRecordset("bdgt_NFG")

-                    .bdgt_NMG = dbRecordset("bdgt_NMG")

-                    .sale_PLAN = dbRecordset("sale_PLAN")

-                 End With

-                 

-                 allBDGT(index) = tmpBDGT

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbInsert_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "lpu_budget", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    dbRecordset("entry_date") = objBDGT.entry_date

-    dbRecordset("lpu_id") = objBDGT.lpu_id

-    dbRecordset("bdgt_NMG") = objBDGT.bdgt_NMG

-    dbRecordset("bdgt_NFG") = objBDGT.bdgt_NFG

-    dbRecordset("sale_PLAN") = objBDGT.sale_PLAN

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objBDGT.id = dbRecordset("id")

-  

-End Sub

-

-Public Sub dbUpdate_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu_budget SET " & _

-    "entry_date='" & objBDGT.entry_date & "'," & _

-    "lpu_id=" & objBDGT.lpu_id & "," & _

-    "bdgt_NMG=" & objBDGT.bdgt_NMG & "," & _

-    "bdgt_NFG=" & objBDGT.bdgt_NFG & "," & _

-    "sale_PLAN=" & objBDGT.sale_PLAN & _

-    " WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-Public Sub dbDelete_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_BDGT_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbDatabase
->>>>>>
-Attribute VB_Name = "dbDatabase"

-Option Explicit

-

-

-Sub dbOpenConnection(dbConnection As Object)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-<<<<<<
-======================
-dbLPU
->>>>>>
-Attribute VB_Name = "dbLPU"

-Option Explicit

-

-Public Type tLPU

-    id As Long

-    rep_id As Long

-    name As String

-    address As String

-    beds As Integer

-End Type

-

-Function Get_LPU_Record(ByVal lpu_id As Long) As tLPU

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_LPU_Record = dbGet_LPU_Record(dbConnection, lpu_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_LPU_byQTR(allLPU() As tLPU, ent_date As String, rep_id As Long) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_LPU_byQTR = dbGetAll_LPU_byQTR(dbConnection, allLPU, ent_date, rep_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_Record(dbConnection As Object, ByVal lpu_id As Long) As tLPU

-    

-    Dim sql As String

-    Dim objLPU As tLPU

-    

-    objLPU.id = lpu_id

-    objLPU.name = ""

-    objLPU.address = ""

-    

-    sql = "SELECT * FROM lpu WHERE id=" & lpu_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objLPU.name = dbRecordset("name")

-        objLPU.address = dbRecordset("address")

-        objLPU.rep_id = dbRecordset("rep_id")

-        objLPU.beds = dbRecordset("beds")

-    End If

-    

-    dbGet_LPU_Record = objLPU

-

-End Function

-

-Function dbGetAll_LPU_byQTR(dbConnection As Object, allLPU() As tLPU, ent_date As String, rep_id As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    Dim Where As String

-    Where = "WHERE lpu_budget.entry_date like '" & ent_date & "'" & " AND lpu.id=lpu_budget.lpu_id AND lpu.rep_id=" & rep_id

-

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu_budget, lpu " & Where

-    

-    getAll_LPU_SQL = "SELECT lpu.id as id, lpu.rep_id as rep_id, lpu.name as name, lpu.address as address, lpu.beds AS beds " & _

-    "FROM lpu, lpu_budget " & Where

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_LPU_byQTR = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-dbREP
->>>>>>
-Attribute VB_Name = "dbREP"

-'Option Explicit

-'

-'Public Type tREP

-'    FirstName As String

-'    LastName As String

-'    Region As Integer

-'    City As Integer

-'End Type

-'

-'Function GetREPRecord() As tREP

-'    Dim dbConnection As Object

-'

-'    dbOpenConnection dbConnection

-'    GetREPRecord = dbGetREPRecord(dbConnection)

-'    dbCloseConnection dbConnection

-'End Function

-'

-'Sub SetREPRecord(cUser As tREP)

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbSetREPRecord dbConnection, cUser

-'    dbCloseConnection dbConnection

-'End Sub

-'

-'Sub ReSetREPRecord()

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbReSetREPRecord dbConnection

-'    dbCloseConnection dbConnection

-'End Sub

-'

-'Public Function dbGetREPRecord(dbConnection As Object) As tREP

-'

-'    Dim SQL As String

-'    Dim objREP As tREP

-'

-'    objREP.FirstName = ""

-'    objREP.LastName = ""

-'    objREP.Region = 0

-'    objREP.City = 0

-'    SQL = "SELECT firstname, lastname, region, city FROM " & _

-'          "rep"

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open SQL, dbConnection

-'    ', 3, 3

-'    If Not dbRecordset.BOF Then

-'

-'        objREP.FirstName = dbRecordset("firstname")

-'        objREP.LastName = dbRecordset("lastname")

-'        objREP.Region = dbRecordset("region")

-'        objREP.City = dbRecordset("city")

-'

-'    End If

-'

-'    dbGetREPRecord = objREP

-'

-'End Function

-'

-'Public Sub dbSetREPRecord(dbConnection As Object, ByRef objREP As tREP)

-'

-'    Dim DeleteSQL As String

-'    Dim InsertSQL As String

-'

-'    DeleteSQL = "DELETE FROM rep"

-'    InsertSQL = "INSERT INTO rep (firstname, lastname, region, city) VALUES (" & _

-'    "'" & objREP.FirstName & "', " & _

-'    "'" & objREP.LastName & "', " & _

-'    objREP.Region & ", " & _

-'    objREP.City & ")"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-'

-'End Sub

-'

-'Public Sub dbReSetREPRecord(dbConnection As Object)

-'

-'    Dim DeleteSQL As String

-'

-'    DeleteSQL = "DELETE FROM rep"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-'

-'End Sub

-'

-

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    CheckWorkBooksArround Wb

-End Sub

-

-

-Sub CheckWorkBooksArround(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If app.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKOnly, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-        Exit Sub

-    End If

-

-End Sub

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub SaveExcelState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-        ActiveWorkbook.DisplayDrawingObjects = xlDisplayShapes

-        

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars(STDBAR_NAME).Visible = False

-End Sub

-

-

-Public Sub RestoreExcelState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars(STDBAR_NAME).Visible = True

-End Sub

-

-

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Public Const STDBAR_NAME = "Worksheet Menu Bar"

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Import"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmImport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Export"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 620

-                        .OnAction = "cmExport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Exit && Restore Excel"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 548

-                        .OnAction = "cmExitRestore"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-       End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(flag As Boolean)

-    If flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars(STDBAR_NAME)

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmImport()

-    Worksheets(RM_QTR_SHEET).Select

-    ImportData

-End Sub

-

-Sub cmExport()

-    dbExport

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    Dim dlg As dlgAbout

-    Set dlg = New dlgAbout

-    

-    dlg.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlg.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlg.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlg.Show

-End Sub

-

-Sub cmMail2Support()

-    Dim err_description As String

-    Dim dlg_msg As dlg_Mail

-    Set dlg_msg = New dlg_Mail

-    With dlg_msg

-        .Show

-        If .Tag = vbOK Then

-            ThisWorkbook.Worksheets(VAR_SHEET).Range("ERR_MESSAGE") _

-                = .tbMessage.Text

-            ThisWorkbook.Save

-            ThisWorkbook.SendMail Recipients:="infra@i-rs.ru", Subject:=PROGRAM_NAME & " ver.:" & PROGRAM_VERSION

-            MsgBox "Сообщение об ошибке отправлено. Перезагрузите программу.", vbOKOnly, PROGRAM_NAME

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-    End With

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-'        helppath = "hh.exe " & .Path & "\Telfast.chm"

-'        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub set_work_mode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetupEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-End Sub

-

-Sub cmSetStandaloneMode()

-    set_work_mode

-    ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    Dim dlg As dlgGetPwd

-    rp = common_pwd

-    

-    Set dlg = New dlgGetPwd

-    dlg.edPwd = ""

-    dlg.Show

-    

-    If dlg.edPwd = rp Then

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmHomePage()

-    ThisWorkbook.Worksheets("RM_QTR").Select

-End Sub

-

-Sub cmExitRestore()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = True

-    Application.Quit

-End Sub

-

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    Dim dlg_prn As dlgPrint

-    

-    Set dlg_prn = New dlgPrint

-    

-    With dlg_prn

-        .cbMainReport = True

-        .cbMainBudget = False

-        .cbSrcData = False

-        .cbAllSheets = False

-    

-        .Show

-    

-        If .Tag = vbCancel Then

-            Exit Sub

-        End If

-    End With

-    

-    Dim PrnIdx As Integer

-    

-    With dlg_prn

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("REP_QTR", "budget", "Final")

-    Case 1111

-        plist = Array("REP_QTR", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("REP_QTR")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Clexane bar"

-Public Const common_pwd As String = "crdjhxtyjr"

-

-

-Sub SetupEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    Wb.Worksheets(TITLE_SHEET).Select

-    With Application

-        .Caption = PROGRAM_NAME & " " & PROGRAM_VERSION

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .SaveExcelState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = False

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Wb.Worksheets(TITLE_SHEET).Select

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    If cWindow.Type = xlWorkbook Then

-                        cWindow.DisplayHeadings = True

-                    End If

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu True

-        End If

-        With mobjAppState

-            .RestoreExcelState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Worksheets(TITLE_SHEET).Select

-'        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Option Explicit

-

-Sub UpdateHWRecords(objHW() As Long)

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    dbUpdateHWRecords dbConnection, objHW

-    dbCloseConnection dbConnection

-End Sub

-

-Function GetHWRecords(objHW() As Long) As Integer

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    GetHWRecords = dbGetHWRecords(dbConnection, objHW)

-    dbCloseConnection dbConnection

-End Function

-

-Sub HWReset()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbInsertHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    

-    Dim dbRecordset As Object

-    Dim i As Long

-    

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "hw", dbConnection, 2, 2

-    

-    For i = 1 To UBound(objHW)

-        dbRecordset.addnew

-        dbRecordset("num") = objHW(i)

-        dbRecordset.Update

-    Next i

-    

-End Sub

-

-Sub dbUpdateHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    dbDeleteHWRecord dbConnection

-    dbInsertHWRecords dbConnection, objHW

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-dbHir
->>>>>>
-Attribute VB_Name = "dbHir"

-Option Explicit

-

-Public Type tHIRURGIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    operations_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_ambulator_clexan_40mg As Integer

-    patients_ambulator_clexan_20mg As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-    patients_stationar_clexan_40mg As Integer

-    patients_stationar_clexan_20mg As Integer

-End Type

-

-' if objHir.ID <> 0 then updatre else insert

-Sub Insert_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objHir.id <> 0 Then

-        dbUpdate_Hir_Record dbConnection, objHir

-    Else

-        dbInsert_Hir_Record dbConnection, objHir

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Hir_RecordsByLPU_ID(ByRef allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Hir_RecordsByLPU_ID = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, allHir, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Hir_Record dbConnection, objHir

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objHir.ID <> 0 then updatre else insert

-

-Sub dbInsert_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_hir", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objHir

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("operations_per_quarter") = .operations_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_ambulator_clexan_20mg") = .patients_ambulator_clexan_20mg

-        dbRecordset("patients_ambulator_clexan_40mg") = .patients_ambulator_clexan_40mg

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-        dbRecordset("patients_stationar_clexan_20mg") = .patients_stationar_clexan_20mg

-        dbRecordset("patients_stationar_clexan_40mg") = .patients_stationar_clexan_40mg

-        

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objHir.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim UpdateSQL As String

-    

-    With objHir

-        UpdateSQL = "UPDATE lpu_hir SET " & _

-            "entry_date='" & objHir.entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "operations_per_quarter=" & .operations_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_ambulator_clexan_20mg=" & .patients_ambulator_clexan_20mg & "," & _

-            "patients_ambulator_clexan_40mg=" & .patients_ambulator_clexan_40mg & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & "," & _

-            "patients_stationar_clexan_20mg=" & .patients_stationar_clexan_20mg & "," & _

-            "patients_stationar_clexan_40mg=" & .patients_stationar_clexan_40mg & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_Hir_RecordsbyLPU_ID(dbConnection As Object, allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Hir_SQL As String

-    Dim getAll_Hir_SQL As String

-    Dim Hir_Count As Long

-    Hir_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Hir_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Hir_Count = dbRecordset("HIR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Hir_RecordsbyLPU_ID = Hir_Count

-    

-    If Hir_Count > 0 Then

-        'we have records

-        ReDim allHir(1 To Hir_Count)

-        Dim index As Integer

-        index = 1

-        dbRecordset.Open getAll_Hir_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpHir As tHIRURGIA

-                 With tmpHir

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .operations_per_quarter = dbRecordset("operations_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_ambulator_clexan_20mg = dbRecordset("patients_ambulator_clexan_20mg")

-                    .patients_ambulator_clexan_40mg = dbRecordset("patients_ambulator_clexan_40mg")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                    .patients_stationar_clexan_20mg = dbRecordset("patients_stationar_clexan_20mg")

-                    .patients_stationar_clexan_40mg = dbRecordset("patients_stationar_clexan_40mg")

-                 End With

-                 

-                 allHir(index) = tmpHir

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE ID=" & objHir.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Hir_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbTer
->>>>>>
-Attribute VB_Name = "dbTer"

-Option Explicit

-

-Public Type tTERAPIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objTer.ID <> 0 then updatre else insert

-Sub Insert_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objTer.id <> 0 Then

-        dbUpdate_Ter_Record dbConnection, objTer

-    Else

-        dbInsert_Ter_Record dbConnection, objTer

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Ter_RecordsByLPU_ID(ByRef allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Ter_RecordsByLPU_ID = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, allTer, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Ter_Record dbConnection, objTer

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objTer.ID <> 0 then updatre else insert

-

-Sub dbInsert_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_ter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objTer

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objTer.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim Update_SQL As String

-    

-    With objTer

-        Update_SQL = "UPDATE lpu_ter SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_Ter_RecordsbyLPU_ID(dbConnection As Object, allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Ter_SQL As String

-    Dim getAll_Ter_SQL As String

-    Dim Ter_Count As Long

-    Ter_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Ter_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Ter_Count = dbRecordset("TER_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Ter_RecordsbyLPU_ID = Ter_Count

-    

-    If Ter_Count > 0 Then

-        'we have records

-        ReDim allTer(1 To Ter_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_Ter_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpTer As tTERAPIA

-                 With tmpTer

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 allTer(index) = tmpTer

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE ID=" & objTer.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Ter_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-mLPU_LIST
->>>>>>
-Attribute VB_Name = "mLPU_LIST"

-Option Explicit

-

-Public Const CINP_AREA As String = "B12"

-Public Const CLPU_NAME As Integer = 0

-Public Const CLPU_NAME1 As Integer = 1

-Public Const CLPU_NAME2 As Integer = 2

-Public Const CLPU_ID As Integer = 3

-Public Const CLPU_BEDS As Integer = 4

-Public Const CLPU_NFG As Integer = 5

-Public Const CLPU_NMG As Integer = 6

-Public Const CLPU_HIR As Integer = 7

-Public Const CLPU_TER As Integer = 8

-Public Const CLPU_CAR As Integer = 9

-Public Const CLPU_FACT As Integer = 10

-Public Const CLPU_PLAN As Integer = 11

-Public Const CLPU_PAT_LPU As Integer = 16

-Public Const CLPU_BDGT As Integer = 17

-Public Const CLPU_PAT_ALL As Integer = 16

-

-

-

-Sub EditLPU(cLPU As tLPU, ent_date As String)

-    NoFunc

-End Sub

-

-Sub Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-

-End Sub

-

-Sub Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btLPU_DEL_IT()

-    Dim cLPU As tLPU

-    Dim ent_date As String

-    Dim delete_all As Integer

-    Dim dlg_del As dlg_LPU_delete

-

-    With Worksheets("LPU_LIST")

-        ent_date = .Range("ent_date")

-        cLPU.id = .getCurrentLPU_ID()

-    End With

-

-    If cLPU.id = 0 Then

-        MsgBox "Укажите удаляемый объект", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    cLPU = Get_LPU_Record(cLPU.id)

-

-    Set dlg_del = New dlg_LPU_delete

-    With dlg_del

-        .chbDeleteQTR.Value = True

-        .chbDeleteAll.Value = False

-        .lComment = ent_date & ": Удаление ЛПУ '" _

-        & cLPU.name & "', расположенного по адресу:" _

-        & cLPU.address & " не разрешено."

-        .Show

-    End With

-End Sub

-

-Sub btLPU_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        

-        Wks_select .Range("ret_addr")

-    End With

-

-End Sub

-

-

-Sub btLPU_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim lpu_id As Long

-

-    i = Worksheets(VAR_SHEET).Range("QTR_ACTION").Value

-    With Worksheets("LPU_LIST")

-        ent_date = .getEnt_date()

-

-

-        lpu_id = .getCurrentLPU_ID

-        If lpu_id = 0 And i <> 6 Then

-            i = 1

-        End If

-        Select Case i

-            Case 1

-                .SelectLPU_NAME lpu_id, ent_date

-                .Range("JUMP") = ""

-            Case 2

-                .SelectLPU_BDGT lpu_id, ent_date

-                .Range("JUMP") = "LPU_BDGT"

-            Case 3

-                .SelectLPU_HIR lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_HIR"

-

-            Case 4

-                .SelectLPU_TER lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_TER"

-

-            Case 5

-                .SelectLPU_C_ACS lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        End Select

-    End With

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-dbQTR
->>>>>>
-Attribute VB_Name = "dbQTR"

-Option Explicit

-

-Public Type tQTR

-    id As Long

-    entry_date As String

-    rep_id As Long

-    sale_PLAN As Long

-    ClxnH20mg As Long

-    ClxnH40mg As Long

-    ClxnT40mg As Long

-    ClxnC_IM As Long

-    ClxnC_ACS As Long

-End Type

-

-Function Get_QTR_Record(ByVal QTR_ID As Long) As tQTR

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_QTR_Record = dbGet_QTR_Record(dbConnection, QTR_ID)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_Record(dbConnection As Object, ByVal QTR_ID As Long) As tQTR

-    

-    Dim sql As String

-    Dim objQTR As tQTR

-    

-    With objQTR

-        .ClxnC_ACS = 0

-        .ClxnC_IM = 0

-        .ClxnH20mg = 0

-        .ClxnH40mg = 0

-        .ClxnT40mg = 0

-        .entry_date = ""

-        .id = QTR_ID

-    End With

-    

-    sql = "SELECT * FROM quarter WHERE id=" & QTR_ID

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objQTR.entry_date = dbRecordset("entry_date")

-        objQTR.rep_id = dbRecordset("rep_id")

-        objQTR.sale_PLAN = dbRecordset("sale_plan")

-        objQTR.ClxnH20mg = dbRecordset("ClxnH20mg")

-        objQTR.ClxnH40mg = dbRecordset("ClxnH40mg")

-        objQTR.ClxnT40mg = dbRecordset("ClxnT40mg")

-        objQTR.ClxnC_IM = dbRecordset("ClxnC_IM")

-        objQTR.ClxnC_ACS = dbRecordset("ClxnC_ACS")

-        objQTR.id = dbRecordset("id")

-    End If

-    

-    dbGet_QTR_Record = objQTR

-

-End Function

-

-

-Function Get_QTR_Record_by_REP(ent_date As String, rep_id As Long) As tQTR

-    Dim dbConnection As Object

-    Dim allQTR() As tQTR

-    Dim i As Long

-

-    dbOpenConnection dbConnection

-

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id)

-    If i <> 0 Then

-        Get_QTR_Record_by_REP = allQTR(1)

-    End If

-

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTR_Records_by_REP(ByRef all_QTR() As tQTR, ent_date As String, rep_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-

-    GetAll_QTR_Records_by_REP = dbGetAll_QTR_Records_By_REP(dbConnection, all_QTR, ent_date, rep_id)

-

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGetAll_QTR_Records_By_REP(dbConnection As Object, all_QTR() As tQTR, ent_date As String, rep_id As Long) As Integer

-

-    Dim getCount_QTR_SQL As String

-    Dim getAll_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter " & _

-    "WHERE entry_date like '" & ent_date & "' AND rep_id=" & rep_id

-    getAll_QTR_SQL = "SELECT * FROM quarter " & _

-    "WHERE entry_date like '" & ent_date & "' AND rep_id=" & rep_id & " ORDER BY entry_date"

-

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-

-    dbRecordset.Close

-

-    dbGetAll_QTR_Records_By_REP = QTR_Count

-

-    If QTR_Count > 0 Then

-        'we have records

-        ReDim all_QTR(1 To QTR_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTR_SQL, dbConnection

-

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTR As tQTR

-                 With tmp_QTR

-                    .entry_date = dbRecordset("entry_date")

-                    .rep_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .ClxnH20mg = dbRecordset("ClxnH20mg")

-                    .ClxnH40mg = dbRecordset("ClxnH40mg")

-                    .ClxnT40mg = dbRecordset("ClxnT40mg")

-                    .ClxnC_IM = dbRecordset("ClxnC_IM")

-                    .ClxnC_ACS = dbRecordset("ClxnC_ACS")

-                    .id = dbRecordset("id")

-                 End With

-

-                 all_QTR(index) = tmp_QTR

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-cdbQTR
->>>>>>
-Attribute VB_Name = "cdbQTR"

-Option Explicit

-

-Public Type tQTR_COMMON

-    qtr As tQTR

-    i_lcd As Long           ' число ЛПУ в СПИСКЕ

-    lcd() As tLPU_COMMON    ' список ЛПУ

-    c_beds As Long          ' сумма коек

-    c_bdgt_NFG As Long      ' общий бюджет на НФГ

-    c_bdgt_NMG As Long      ' общий бюджет на НМГ

-    c_bdgt_LPU As Long      ' общий бюджет на гепарины

-    c_sale_PLAN As Long     ' план продаж репа

-    c_sale_ALL As Long      ' продажи

-    c_sale_HIR As Long      ' в хирургии

-    c_sale_TER  As Long     ' в терапии

-    c_sale_CRD  As Long     ' в кардиологии

-    c_pat_HIR   As Long     ' пациенты

-    c_pat_TER   As Long     '

-    c_pat_CRD   As Long     '

-    c_pat_ALL   As Long     '

-    c_pat_LPU   As Long     ' Всего операций

-End Type

-

-Function GetLastQTR_fromDB() As String

-    Dim dbConnection As Object

-    Dim getCount_QTR_SQL As String

-    Dim getLast_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter"

-    getLast_QTR_SQL = "SELECT MAX(entry_date) as ent_date FROM quarter"

-    

-    dbOpenConnection dbConnection

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    If QTR_Count > 0 Then

-        'we have records

-        dbRecordset.Open getLast_QTR_SQL, dbConnection

-        getLast_QTR_SQL = dbRecordset("ent_date")

-    End If

-    GetLastQTR_fromDB = getLast_QTR_SQL

-    dbCloseConnection dbConnection

-End Function

-

-Function Get_QTR_CommonList_by_REP(ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_QTR_CommonList_by_REP = dbGet_QTR_CommonList_by_REP(dbConnection, qcd, ent_date, rep_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_CommonList_by_REP(dbConnection As Object, ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim allQTR() As tQTR

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id)

-    dbGet_QTR_CommonList_by_REP = i

-    If i > 0 Then

-        ReDim qcd(i)

-        For i = 1 To UBound(allQTR)

-            With qcd(i)

-                .qtr = allQTR(i)

-                .c_beds = 0

-                .c_bdgt_NFG = 0

-                .c_bdgt_NMG = 0

-                .c_bdgt_LPU = 0

-                .c_sale_PLAN = 0

-                .c_pat_HIR = 0

-                .c_pat_TER = 0

-                .c_pat_CRD = 0

-                .c_pat_ALL = 0

-                .c_sale_HIR = 0

-                .c_sale_TER = 0

-                .c_sale_CRD = 0

-                .c_sale_ALL = 0

-                .c_pat_LPU = 0

-                

-                j = dbGet_LPU_CommonQTR(dbConnection, .lcd, .qtr)

-                .i_lcd = j

-                If j > 0 Then

-                    For j = 1 To UBound(.lcd)

-                        .c_beds = .c_beds + .lcd(j).lpu.beds

-                        .c_bdgt_NFG = .c_bdgt_NFG + .lcd(j).bdgt.bdgt_NFG

-                        .c_bdgt_NMG = .c_bdgt_NMG + .lcd(j).bdgt.bdgt_NMG

-                        .c_bdgt_LPU = .c_bdgt_LPU + .lcd(j).bdgt_LPU

-                        .c_sale_PLAN = .c_sale_PLAN + .lcd(j).bdgt.sale_PLAN

-                        .c_pat_HIR = .c_pat_HIR + .lcd(j).pat_HIR

-                        .c_pat_TER = .c_pat_TER + .lcd(j).pat_TER

-                        .c_pat_CRD = .c_pat_CRD + .lcd(j).pat_CRD

-                        .c_pat_ALL = .c_pat_ALL + .lcd(j).pat_ALL

-                        .c_sale_HIR = .c_sale_HIR + .lcd(j).sale_HIR

-                        .c_sale_TER = .c_sale_TER + .lcd(j).sale_TER

-                        .c_sale_CRD = .c_sale_CRD + .lcd(j).sale_CRD

-                        .c_sale_ALL = .c_sale_ALL + .lcd(j).sale_ALL

-                        .c_pat_LPU = .c_pat_LPU + .lcd(j).pat_LPU

-                    Next j

-                    

-                End If

-            End With

-        Next i

-    End If

-End Function

-

-Function GetLastQtr() As String

-    Dim s As String

-    Dim r As Range

-    Set r = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Do While r.Cells(1, 1) <> ""

-        s = r.Cells(1, 1)

-        Set r = r.Cells.Offset(1, 0)

-    Loop

-    GetLastQtr = s

-End Function

-

-Function GetNextQTR(ent_date As String) As String

-    Dim rd As Range

-    Dim idx As Integer

-    Dim b As Variant

-    Dim dlg As dlg_newQTR

-    Set dlg = New dlg_newQTR

-    

-    If ent_date = "" Then

-        Dim ir As Variant

-        idx = 0

-        dlg.Show

-        b = dlg.Tag

-            

-        If IsNumeric(b) Then

-            GetNextQTR = dlg.cbQTR

-        Else

-            GetNextQTR = ""

-        End If

-    Else

-        Set rd = Worksheets(VAR_SHEET).Range("Date_Lst")

-        idx = WorksheetFunction.Match(ent_date, rd, 0)

-        GetNextQTR = WorksheetFunction.index(rd, idx + 1, 1)

-    End If

-End Function

-<<<<<<
-======================
-mRestView
->>>>>>
-Attribute VB_Name = "mRestView"

-Option Explicit

-

-Sub xlRestoreView()

-Attribute xlRestoreView.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute xlRestoreView.VB_ProcData.VB_Invoke_Func = " \n14"

-    With Application

-        .CommandBars("Standard").Visible = True

-        .CommandBars("Formatting").Visible = True

-        .DisplayFormulaBar = True

-        .DisplayStatusBar = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = True

-    End With

-End Sub

-<<<<<<
-======================
-dlg_newQTR
->>>>>>
-Attribute VB_Name = "dlg_newQTR"

-Attribute VB_Base = "0{3EA3C15A-5493-445F-9858-2F241E7D6CEA}{849C1FE1-631A-485D-BE54-A7B73124582C}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mDec2TS
->>>>>>
-Attribute VB_Name = "mDec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-CHRT_LPU_BBL
->>>>>>
-Attribute VB_Name = "CHRT_LPU_BBL"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Unprotect

-    Range("view_key") = True

-    On Error Resume Next

-    ChangeLabels

-    Range("A1").Select

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Unprotect

-    Dim s As String

-    s = Range("ret_addr")

-    Protect UserInterfaceOnly:=True

-    Wks_select (s)

-End Sub

-

-Sub BCLabelChng_Click()

-    Unprotect

-    If Range("view_key") Then

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать названия"

-    Else

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать объемы"

-    End If

-    Range("view_key") = Not Range("view_key")

-    ChangeLabels

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub ChangeLabels()

-    Dim i As Integer

-    Dim offset_text As Integer

-    Dim src As Range

-    Set src = Range("CHRT_BBL_DATA")

-    

-    offset_text = 3

-    If Range("view_key") Then

-        offset_text = 4

-    End If

-    

-    With ChartObjects(1).Chart

-        With .SeriesCollection(1)

-            For i = 1 To .Points.count

-                On Error GoTo ExitLabel

-                .Points(i).DataLabel.Characters.Text = Format(src.Cells(i, offset_text))

-            Next i

-        End With

-    End With

-ExitLabel:

-End Sub

-

-<<<<<<
-======================
-CHRT_PAT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PAT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-<<<<<<
-======================
-CHRT_PAT_LPU
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_nextQTR
->>>>>>
-Attribute VB_Name = "dlg_nextQTR"

-Attribute VB_Base = "0{B85FF7F1-50C0-4433-BC6F-8A0F2C9BDDDA}{EC2D2B9E-9ED2-4005-A1E9-EF0626D3B7E7}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-cdbLPU
->>>>>>
-Attribute VB_Name = "cdbLPU"

-Option Explicit

-

-Public Type tLPU_COMMON

-    lpu As tLPU

-    bdgt As tBUDGET

-    i_hir As Long

-    hir() As tHIRURGIA

-    i_ter As Long

-    ter() As tTERAPIA

-    i_ACS As Long

-    ACS() As tACS

-    bdgt_LPU As Long

-    sale_HIR As Long

-    sale_TER As Long

-    sale_CRD As Long

-    sale_ALL As Long

-    pat_HIR As Long

-    pat_TER As Long

-    pat_CRD As Long

-    pat_ALL As Long     ' Сумма всех пациентов на клексане

-    pat_LPU As Long     ' Число потенциальных пациентов для продаж клексана

-End Type

-

-Function Get_LPU_CommonQTR(ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    Get_LPU_CommonQTR = dbGet_LPU_CommonQTR(dbConnection, lcd, objQTR)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_CommonQTR(dbConnection As Object, ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    i = dbGetAll_LPU_byQTR(dbConnection, allLPU, objQTR.entry_date, objQTR.rep_id)

-    dbGet_LPU_CommonQTR = i

-    If i > 0 Then

-        ReDim lcd(i)

-        For i = 1 To UBound(allLPU)

-            dbGet_LPU_Common dbConnection, lcd(i), allLPU(i), objQTR

-        Next i

-    End If

-End Function

-

-Sub Get_LPU_Common(ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    dbGet_LPU_Common dbConnection, lcd, cLPU, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbGet_LPU_Common(dbConnection As Object, ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-

-    lcd.lpu = cLPU

-    lcd.bdgt = dbGet_BDGT_Record(dbConnection, cLPU.id, objQTR.entry_date)

-    lcd.i_hir = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, lcd.hir, cLPU.id, objQTR.entry_date)

-    lcd.i_ter = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, lcd.ter, cLPU.id, objQTR.entry_date)

-    lcd.i_ACS = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, lcd.ACS, cLPU.id, objQTR.entry_date)

-    With lcd

-        .bdgt_LPU = .bdgt.bdgt_NFG + .bdgt.bdgt_NMG

-        .pat_LPU = 0

-        If .i_hir > 0 Then

-            .pat_HIR = .hir(1).patients_ambulator_clexan + .hir(1).patients_stationar_clexan

-            .sale_HIR = objQTR.ClxnH20mg * (.hir(1).patients_ambulator_clexan_20mg + .hir(1).patients_stationar_clexan_20mg)

-            .sale_HIR = .sale_HIR + objQTR.ClxnH40mg * (.hir(1).patients_ambulator_clexan_40mg + .hir(1).patients_stationar_clexan_40mg)

-            .pat_LPU = .pat_LPU + .hir(1).operations_per_quarter

-        End If

-        If .i_ter > 0 Then

-            .pat_TER = .ter(1).patients_ambulator_clexan + .ter(1).patients_stationar_clexan

-            .sale_TER = .pat_TER * objQTR.ClxnT40mg

-            .pat_LPU = .pat_LPU + .ter(1).patients_per_quarter

-        End If

-        If .i_ACS > 0 Then

-            .pat_CRD = .ACS(1).patients_stationar_clexan

-            .sale_CRD = .pat_CRD * objQTR.ClxnC_ACS

-            .pat_LPU = .pat_LPU + .ACS(1).patients_per_quarter

-        End If

-        .pat_ALL = .pat_HIR + .pat_TER + .pat_CRD

-        .sale_ALL = .sale_HIR + .sale_TER + .sale_CRD

-    End With

-End Sub

-

-<<<<<<
-======================
-CHRT_PIE
->>>>>>
-Attribute VB_Name = "CHRT_PIE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    

-    Unprotect

-    

-    On Error Resume Next

-    

-    Range("P5:Q24").Sort _

-        Key1:=Range("Q5"), _

-        Order1:=xlDescending, _

-        Header:=xlGuess, _

-        OrderCustom:=1, _

-        MatchCase:=False, _

-        Orientation:=xlTopToBottom

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PLN_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PLN_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_BDGT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_BDGT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_LPU_delete
->>>>>>
-Attribute VB_Name = "dlg_LPU_delete"

-Attribute VB_Base = "0{EC96F2D1-337D-47DF-B0F1-A6DF3F8CD5CC}{7EB42A63-CBFC-45B0-AE4D-C3E3D8FE7420}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlg_Mail
->>>>>>
-Attribute VB_Name = "dlg_Mail"

-Attribute VB_Base = "0{7B669454-C2AA-4FDF-8311-7ADEDDEF3FF3}{D07A0A02-4923-46C8-8EE8-62769243087D}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dbREP_id
->>>>>>
-Attribute VB_Name = "dbREP_id"

-Public Type tREPID

-    rep_id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function GetAll_REPID_Records_by_QTR(ByRef all_REPID() As tREPID, ent_date As String) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_REPID_Records_by_QTR = dbGetAll_REPID_Records_by_QTR(dbConnection, all_REPID, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-Function Get_REPID_Record(id As Long) As tREPID

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REPID_Record = dbGet_REPID_Record(dbConnection, id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_REPID_Records(ByRef all_REPID() As tREPID) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_REPID_Records = dbGetAll_REPID_Records(dbConnection, all_REPID)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function dbGet_REPID_Record(dbConnection As Object, id As Long) As tREPID

-    

-    Dim sql As String

-    Dim objREPID As tREPID

-    

-    objREPID.FirstName = ""

-    objREPID.LastName = ""

-    objREPID.Region = 0

-    objREPID.City = 0

-    sql = "SELECT rep_id, firstname, lastname, region, city FROM " & _

-          "rep WHERE rep_id=" & id

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREPID.rep_id = dbRecordset("rep_id")

-        objREPID.FirstName = dbRecordset("firstname")

-        objREPID.LastName = dbRecordset("lastname")

-        objREPID.Region = dbRecordset("region")

-        objREPID.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REPID_Record = objREPID

-        

-End Function

-

-Function dbGetAll_REPID_Records_by_QTR(dbConnection As Object, ByRef all_REPID() As tREPID, ent_date As String) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    Dim Where As String

-    

-    REPID_Count = 0

-    Where = " WHERE lpu_budget.entry_date like '" & ent_date & "' " & _

-        "AND rep.rep_id=lpu.rep_id AND lpu.id=lpu_budget.lpu_id"

-    

-    

-    getAll_REPID_SQL = "SELECT distinct rep.* FROM rep, lpu, lpu_budget" & Where

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM (" & getAll_REPID_SQL & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records_by_QTR = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Function dbGetAll_REPID_Records(dbConnection As Object, ByRef all_REPID() As tREPID) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    REPID_Count = 0

-    

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM rep"

-    getAll_REPID_SQL = "SELECT * FROM rep"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-cdbExport
->>>>>>
-Attribute VB_Name = "cdbExport"

-Option Explicit

-

-Function GetDBSN() As String

-    Dim n As Long

-    Randomize Timer

-    n = Int((100000000 - 1000000 + 1) * Rnd + 1000000)

-    GetDBSN = Dec2ThirtySix(n)

-End Function

-

-Sub dbExport()

-    Dim src_file As String

-    Dim dst_file As String

-    

-    On Error GoTo ErrHandler

-    

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & GetLastQTR_fromDB & "_" & GetDBSN() & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Данные экспортированы в файл:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для передачи", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-Exit Sub

-

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-<<<<<<
-======================
-mRegs
->>>>>>
-Attribute VB_Name = "mRegs"

-Option Explicit

-

-Function GetRegionName(idx As Integer) As String

-    GetRegionName = Worksheets(REGS_SHEET).Range("LST_REGIONS").Cells(idx + 1, 1).Text

-End Function

-

-Function GetCityName(idx_reg As Integer, idx_city As Integer) As String

-    GetCityName = Worksheets(REGS_SHEET).Range("CITY_TABLES").Offset(idx_city + 1, idx_reg * 2).Text

-End Function

-

-Sub testReg()

-    Dim r As Integer

-    Dim c As Integer

-    Dim s As String

-    

-    r = 3

-    c = 3

-    s = GetRegionName(r)

-    s = s & ", " & GetCityName(r, c)

-    MsgBox s

-End Sub

-

-<<<<<<
-======================
-RM_QTR
->>>>>>
-Attribute VB_Name = "RM_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CRGN_QT As Integer = 0

-Const CRGN_PLN As Integer = 2

-Const CRGN_FCT As Integer = 3

-Const CRGN_BDG As Integer = 4

-Const CRGN_LPU As Integer = 5

-Const CRGN_REP As Integer = 6

-Const CRGN_HIR As Integer = 7

-Const CRGN_TER As Integer = 8

-Const CRGN_CRD As Integer = 9

-Const CRGN_CLXN_BDG As Integer = 10

-Const CRGN_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub ClearRMName()

-    Unprotect

-    Range("D4") = ""

-    Range("D5") = ""

-    Range("H4") = ""

-End Sub

-

-Sub update_history()

-    Dim objRGN() As tREGION

-    Dim i As Long

-    Dim r As Range

-    Dim cRMan As tREGMAN

-

-    cRMan = Get_REGMAN_Record

-    

-    Range("D4") = cRMan.LastName

-    Range("D5") = cRMan.FirstName

-

-    Range("H4") = GetRegionName(cRMan.Region)

-    

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetRGN_COMM_DATA(objRGN)

-    

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objRGN)

-            r.Offset(i - 1, CRGN_QT) = objRGN(i).ent_date

-            r.Offset(i - 1, CRGN_FCT) = objRGN(i).total_SALE

-            r.Offset(i - 1, CRGN_PLN) = objRGN(i).sale_PLAN

-            r.Offset(i - 1, CRGN_BDG) = objRGN(i).total_BDGT

-            r.Offset(i - 1, CRGN_LPU) = objRGN(i).total_LPU

-            r.Offset(i - 1, CRGN_REP) = objRGN(i).total_REP

-            r.Offset(i - 1, CRGN_HIR) = objRGN(i).total_HIR

-            r.Offset(i - 1, CRGN_TER) = objRGN(i).total_TER

-            r.Offset(i - 1, CRGN_CRD) = objRGN(i).total_ACS

-            If objRGN(i).total_BDGT <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_BDG) = objRGN(i).total_SALE / objRGN(i).total_BDGT

-            End If

-            If objRGN(i).total_BDGT_NMG <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_NMG) = objRGN(i).total_SALE / objRGN(i).total_BDGT_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRGN_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRM_QtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR_RM

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR_RM

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR_RM

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = RM_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect UserInterfaceOnly:=True

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CRGN_QT + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    If r = "" Then

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = currRange.address

-        With Worksheets("REP_LIST")

-            .Range("ret_addr") = "RM_QTR"

-            .Range("ent_date") = r

-            .Range("VIEW_ONLY") = True

-        End With

-    End If

-    Cancel = True

-    btRM_QTR_Do_IT

-End Sub

-

-<<<<<<
-======================
-dbREG_MAN
->>>>>>
-Attribute VB_Name = "dbREG_MAN"

-Option Explicit

-

-Public Type tREGMAN

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function Get_REGMAN_Record() As tREGMAN

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REGMAN_Record = dbGet_REGMAN_Record(dbConnection)

-    dbCloseConnection dbConnection

-End Function

-

-Sub Set_REGMAN_Record(cREGMAN As tREGMAN)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbSet_REGMAN_Record dbConnection, cREGMAN

-    dbCloseConnection dbConnection

-End Sub

-

-Sub ReSet_REGMAN_Record()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbReSet_REGMAN_Record dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_REGMAN_Record(dbConnection As Object) As tREGMAN

-    

-    Dim sql As String

-    Dim objREGMAN As tREGMAN

-    

-    objREGMAN.FirstName = ""

-    objREGMAN.LastName = ""

-    objREGMAN.Region = 0

-    objREGMAN.City = 0

-    sql = "SELECT firstname, lastname, region, city FROM " & _

-          "reg_man"

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREGMAN.FirstName = dbRecordset("firstname")

-        objREGMAN.LastName = dbRecordset("lastname")

-        objREGMAN.Region = dbRecordset("region")

-        objREGMAN.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REGMAN_Record = objREGMAN

-        

-End Function

-

-Public Sub dbSet_REGMAN_Record(dbConnection As Object, ByRef objREGMAN As tREGMAN)

-  

-    Dim DeleteSQL As String

-    Dim InsertSQL As String

-    

-    DeleteSQL = "DELETE FROM reg_man"

-    InsertSQL = "INSERT INTO reg_man (firstname, lastname, region, city) VALUES (" & _

-    "'" & objREGMAN.FirstName & "', " & _

-    "'" & objREGMAN.LastName & "', " & _

-    objREGMAN.Region & ", " & _

-    objREGMAN.City & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    dbRecordset.Open InsertSQL, dbConnection

-       

-End Sub

-

-Public Sub dbReSet_REGMAN_Record(dbConnection As Object)

-  

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM reg_man"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    

-End Sub

-

-

-<<<<<<
-======================
-dbDatabaseMerge
->>>>>>
-Attribute VB_Name = "dbDatabaseMerge"

-Option Explicit

-

-Public Type tDBFIELD

-    name As String

-End Type

-

-Public Type tDBTABLE

-    name As String

-    field() As tDBFIELD

-End Type

-

-

-Function dbGetConnection(dbAccessFileFullPath As String) As Object

-    Dim dbConnection As Object

-    Dim dbAccessFilePasswd As String

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFileFullPath & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    Set dbGetConnection = dbConnection

-End Function

-

-Sub dbCloseOpenedConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteOpenedSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-Function dbMergeREP(from_dbConnection As Object, to_dbConnection As Object) As Long

-

-    Dim getRecordset As Object

-    Dim getREPData_SQL As String

-    Dim REP_fn As String

-    Dim REP_ln As String

-    Dim REP_region As String

-    Dim REP_city As String

-

-

-    getREPData_SQL = "SELECT * FROM rep"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getREPData_SQL, from_dbConnection

-        

-        If Not getRecordset.BOF Then

-            REP_fn = getRecordset("firstname")

-            REP_ln = getRecordset("lastname")

-            REP_city = getRecordset("city")

-            REP_region = getRecordset("region")

-        Else

-            MsgBox "There is no information about rep! This database cannot be merged!!!"

-            dbMergeREP = -1

-            Exit Function

-        End If

-    

-    Dim insertRecordset As Object

-    Set insertRecordset = CreateObject("ADODB.Recordset")

-        

-    insertRecordset.Open "rep", to_dbConnection, 2, 2

-    insertRecordset.addnew

-        

-    insertRecordset("firstname") = REP_fn

-    insertRecordset("lastname") = REP_ln

-    insertRecordset("region") = REP_region

-    insertRecordset("city") = REP_city

-    insertRecordset.Update

-    insertRecordset.MoveLast

-    'new ID

-    

-    dbMergeREP = insertRecordset("rep_id")

-    

-End Function

-

-Sub dbMergeLPU(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getLPU_SQL As String

-    Dim getRecordset As Object

-    Dim idx As Long

-    idx = 1

-    

-    getLPU_SQL = "SELECT * FROM lpu"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getLPU_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            ReDim Preserve objLPU(1 To idx)

-            objLPU(idx).old_lpu_id = getRecordset("id")

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "lpu", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("name") = getRecordset("name")

-            insRS("address") = getRecordset("address")

-            insRS("beds") = getRecordset("beds")

-            insRS.Update

-            insRS.MoveLast

-            'new ID

-            

-            objLPU(idx).new_lpu_id = insRS("id")

-                        

-            idx = idx + 1

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about LPU! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-

-Sub dbMergeLPURelated(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object)

-

-    ' 6 tables to change

-    Dim tables(1 To 5) As tDBTABLE

-    

-    'lpu budget

-    tables(1).name = "lpu_budget"

-    ReDim tables(1).field(1 To 4)

-    

-    tables(1).field(1).name = "entry_date"

-    tables(1).field(2).name = "bdgt_NMG"

-    tables(1).field(3).name = "bdgt_NFG"

-    tables(1).field(4).name = "sale_PLAN"

-    

-    'lpu hir

-    tables(2).name = "lpu_hir"

-    ReDim tables(2).field(1 To 13)

-    

-    tables(2).field(1).name = "entry_date"

-    tables(2).field(2).name = "operations_per_quarter"

-    tables(2).field(3).name = "risk_percent"

-    tables(2).field(4).name = "patients_with_risk_ON"

-    tables(2).field(5).name = "patients_ambulator"

-    tables(2).field(6).name = "patients_ambulator_nmg"

-    tables(2).field(7).name = "patients_ambulator_clexan"

-    tables(2).field(8).name = "patients_ambulator_clexan_40mg"

-    tables(2).field(9).name = "patients_ambulator_clexan_20mg"

-    tables(2).field(10).name = "patients_stationar_nmg"

-    tables(2).field(11).name = "patients_stationar_clexan"

-    tables(2).field(12).name = "patients_stationar_clexan_40mg"

-    tables(2).field(13).name = "patients_stationar_clexan_20mg"

-    

-    

-    'lpu acs

-    tables(3).name = "lpu_acs"

-    ReDim tables(3).field(1 To 5)

-    

-    tables(3).field(1).name = "entry_date"

-    tables(3).field(2).name = "patients_with_geparins"

-    tables(3).field(3).name = "patients_per_quarter"

-    tables(3).field(4).name = "patients_stationar_nmg"

-    tables(3).field(5).name = "patients_stationar_clexan"

-    

-    'lpu acs

-    tables(4).name = "lpu_im"

-    ReDim tables(4).field(1 To 5)

-    

-    tables(4).field(1).name = "entry_date"

-    tables(4).field(2).name = "patients_with_geparins"

-    tables(4).field(3).name = "patients_per_quarter"

-    tables(4).field(4).name = "patients_stationar_nmg"

-    tables(4).field(5).name = "patients_stationar_clexan"

-    

-    

-    'lpu acs

-    tables(5).name = "lpu_ter"

-    ReDim tables(5).field(1 To 9)

-    

-    tables(5).field(1).name = "entry_date"

-    tables(5).field(2).name = "patients_per_quarter"

-    tables(5).field(3).name = "risk_percent"

-    tables(5).field(4).name = "patients_with_risk_ON"

-    tables(5).field(5).name = "patients_ambulator"

-    tables(5).field(6).name = "patients_ambulator_nmg"

-    tables(5).field(7).name = "patients_ambulator_clexan"

-    tables(5).field(8).name = "patients_stationar_nmg"

-    tables(5).field(9).name = "patients_stationar_clexan"

-    

-    

-    

-    Dim tbl_idx As Integer

-    

-    For tbl_idx = 1 To UBound(tables)

-        

-        Dim getSQL As String

-        Dim getRS As Object

-        

-        

-        

-        Set getRS = CreateObject("ADODB.Recordset")

-        

-        getSQL = "SELECT * FROM " & tables(tbl_idx).name

-        getRS.Open getSQL, from_db

-        

-        If Not getRS.BOF Then

-            Do While Not getRS.EOF

-                Dim insRS As Object

-                Set insRS = CreateObject("ADODB.Recordset")

-                

-                insRS.Open tables(tbl_idx).name, to_db, 2, 2

-                insRS.addnew

-                Dim fld_idx As Integer

-    

-                    For fld_idx = 1 To UBound(tables(tbl_idx).field)

-                        insRS(tables(tbl_idx).field(fld_idx).name) = getRS(tables(tbl_idx).field(fld_idx).name)

-                        insRS("lpu_id") = findNewLPU_IDByOld(objLPU, getRS("lpu_id"))

-                    Next fld_idx

-                    

-                insRS.Update

-                insRS.MoveLast

-                getRS.MoveNext

-            Loop

-        End If

-        

-        

-    Next tbl_idx

-

-End Sub

-

-Function findNewLPU_IDByOld(objLPU() As tLPUCONVERTION, old_id As Long)

-

-Dim i As Integer

-For i = 1 To UBound(objLPU)

-    If objLPU(i).old_lpu_id = old_id Then

-        findNewLPU_IDByOld = objLPU(i).new_lpu_id

-        Exit Function

-    End If

-Next i

-

-findNewLPU_IDByOld = -1

-End Function

-

-

-

-

-

-Sub dbMergeQTR(from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getQTR_SQL As String

-    Dim getRecordset As Object

-    

-    getQTR_SQL = "SELECT * FROM quarter"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getQTR_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "quarter", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("entry_date") = getRecordset("entry_date")

-            insRS("sale_plan") = getRecordset("sale_plan")

-            insRS("ClxnH20mg") = getRecordset("ClxnH20mg")

-            insRS("ClxnH40mg") = getRecordset("ClxnH40mg")

-            insRS("ClxnT40mg") = getRecordset("ClxnT40mg")

-            insRS("ClxnC_IM") = getRecordset("ClxnC_IM")

-            insRS("ClxnC_ACS") = getRecordset("ClxnC_ACS")

-            

-            

-            insRS.Update

-            

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about quarter budget! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-dbMerge
->>>>>>
-Attribute VB_Name = "dbMerge"

-Option Explicit

-

-Public Type tLPUCONVERTION

-    old_lpu_id As Long

-    new_lpu_id As Long

-End Type

-

-Sub Merge_BackUp_All_Data()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim time_stump As String

-    

-    On Error GoTo ErrHandler

-    

-    time_stump = Format(Date, "yy-mm-dd_") & Format(Time, "hh-mm")

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_BACKUPNAME & time_stump & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Старые данные сохранены в файле:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для восстановления данных в случае утери", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-    Exit Sub

-    

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-

-Sub Merge_Clear_All_Data(access_file_full_path As String)

-    

-    Dim db As Object

-    Dim tables_to_clear() As String

-    On Error GoTo ErrHandler

-    

-    ReDim tables_to_clear(1 To 8)

-    tables_to_clear(1) = "rep"

-    tables_to_clear(2) = "lpu"

-    tables_to_clear(3) = "lpu_budget"

-    tables_to_clear(4) = "lpu_hir"

-    tables_to_clear(5) = "lpu_ter"

-    tables_to_clear(6) = "lpu_acs"

-    tables_to_clear(7) = "lpu_im"

-    tables_to_clear(8) = "quarter"

-    

-    Set db = dbGetConnection(access_file_full_path)

-

-    Dim i As Integer

-    

-    For i = 1 To UBound(tables_to_clear)

-        

-        If tables_to_clear(i) <> "" Then

-            Dim Clear_SQL As String

-            Clear_SQL = "DELETE FROM " & tables_to_clear(i)

-            dbExecuteOpenedSQL db, Clear_SQL

-        Else

-            'do nothing or show message

-        End If

-    Next i

-    

-    dbCloseOpenedConnection db

-    Set db = Nothing

-    

-'    Dim Engine As Object

-'    Set Engine = CreateObject("JRO.JetEngine")

-'    Engine.CompactDatabase "Password=password;Data Source=" & access_file_full_path, _

-'    "Password=password;Data Source=c:\tmp\1.mdb"

-    

-Exit Sub

-

-ErrHandler:

-    MsgBox "something wrong: " & err.Description

-    Resume Next

-    

-End Sub

-

-Function MergeREP(from_file As String, to_file As String) As Long

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    Dim new_rep_id As Long

-

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    MergeREP = dbMergeREP(db1, db2)

-    'MsgBox "new rep ID is " & new_rep_id

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Function

-

-Sub MergeQTR(from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeQTR db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-

-Sub MergeLPU(objLPU() As tLPUCONVERTION, from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeLPU objLPU, db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-Sub MergeLPURelated(objLPU() As tLPUCONVERTION, from_file As String, to_file As String)

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    dbMergeLPURelated objLPU, db1, db2

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-

-End Sub

-

-Sub MergeGlobal(rep_files() As String, rm_file As String)

-

-    Dim i As Integer

-    'clear output file content

-    Merge_Clear_All_Data rm_file

-    

-    For i = 1 To UBound(rep_files)

-        

-        Dim rep_file As String

-        'setup input and output files

-        rep_file = rep_files(i)

-        

-        Dim new_rep_id As Long

-        ' insert REP data and get new rep_id

-        new_rep_id = MergeREP(rep_file, rm_file)

-        

-        Dim objLPU() As tLPUCONVERTION

-        'insert all LPU using new generated rep_id

-        'and populate objLPU old->new relation object

-        

-        MergeLPU objLPU, rep_file, rm_file, new_rep_id

-        'insert quarter data using new rep_id

-        MergeQTR rep_file, rm_file, new_rep_id

-        

-        

-        ' and.... insert all another data (5 tables excl version and hw)

-        'using objLPU old->new relation object

-        MergeLPURelated objLPU, rep_file, rm_file

-    

-    

-    Next i

-    

-End Sub

-

-Function GetDBList(MyPath() As String, ByRef dblist() As String) As Integer

-    Dim i As Integer

-    Dim MyName, MyMask

-    MyMask = MyPath(0) & MyPath(1) & PROGRAM_DATAEXT

-    i = 0

-    MyName = Dir(MyMask)      ' Retrieve the first entry.

-    Do While MyName <> ""    ' Start the loop.

-        ' Ignore the current directory and the encompassing directory.

-        If MyName <> "." And MyName <> ".." Then

-            ' Use bitwise comparison to make sure MyName is a directory.

-            i = i + 1

-            ReDim Preserve dblist(i)

-            dblist(i) = MyPath(0) & MyName

-        End If

-        MyName = Dir    ' Get next entry.

-    Loop

-    GetDBList = i

-End Function

-

-<<<<<<
-======================
-dlgImprtDB
->>>>>>
-Attribute VB_Name = "dlgImprtDB"

-Attribute VB_Base = "0{D5892870-2C88-40C8-A817-AC9B1CF37C2C}{9853EBEA-4E48-41F9-89C0-6F753EB6A0C2}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Private Sub btSelAll_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = True

-    Next i

-End Sub

-

-Private Sub btUnselect_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = False

-    Next i

-End Sub

-<<<<<<
-======================
-dbQTR_RM
->>>>>>
-Attribute VB_Name = "dbQTR_RM"

-Option Explicit

-

-Public Type tQTRRM

-    id As Long

-    entry_date As String

-    rm_id As Long

-    sale_PLAN As Long

-End Type

-

-

-Sub Insert_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objQTRRM.id <> 0 Then

-        dbUpdate_QTRRM_Record dbConnection, objQTRRM

-    Else

-        dbInsert_QTRRM_Record dbConnection, objQTRRM

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-Function Get_QTRRM_Record(ent_date As String) As tQTRRM

-    Dim dbConnection As Object

-    Dim allQTRRM() As tQTRRM

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    i = dbGetAll_QTRRM_Records(dbConnection, allQTRRM, ent_date)

-    If i <> 0 Then

-        Get_QTRRM_Record = allQTRRM(1)

-    End If

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTRRM_Records(ByRef all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_QTRRM_Records = dbGetAll_QTRRM_Records(dbConnection, all_QTRRM, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_QTRRM_Record dbConnection, objQTRRM

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objQTRRM.ID <> 0 then updatre else insert

-Sub dbInsert_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "quarter_rm", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objQTRRM

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("sale_plan") = .sale_PLAN

-        dbRecordset("rm_id") = .rm_id

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objQTRRM.id = dbRecordset("id")

-

-End Sub

-

-Sub dbUpdate_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim Update_SQL As String

-    

-    With objQTRRM

-        Update_SQL = "UPDATE quarter_rm SET " & _

-            "entry_date='" & .entry_date & "'" & "," & _

-            "rm_id=" & .rm_id & "," & _

-            "sale_plan=" & .sale_PLAN & "," & _

-            " WHERE id=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if ent_date = % then all_records

-Function dbGetAll_QTRRM_Records(dbConnection As Object, all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    

-    Dim getCount_QTRRM_SQL As String

-    Dim getAll_QTRRM_SQL As String

-    Dim QTRRM_Count As Long

-    QTRRM_Count = 0

-    

-    getCount_QTRRM_SQL = "SELECT COUNT(*) AS QTRRM_TOTAL FROM quarter_rm WHERE entry_date like '" & ent_date & "'"

-    getAll_QTRRM_SQL = "SELECT * FROM quarter_rm WHERE entry_date like '" & ent_date & "' ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTRRM_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTRRM_Count = dbRecordset("QTRRM_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_QTRRM_Records = QTRRM_Count

-    

-    If QTRRM_Count > 0 Then

-        'we have records

-        ReDim all_QTRRM(1 To QTRRM_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTRRM_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTRRM As tQTRRM

-                 With tmp_QTRRM

-                    .entry_date = dbRecordset("entry_date")

-                    .rm_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .id = dbRecordset("id")

-                 End With

-                 

-                 all_QTRRM(index) = tmp_QTRRM

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM quarter_rm " & _

-    "WHERE id=" & objQTRRM.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-    

-    'delete related budget entries

-    MsgBox "remember delete related"

-'    dbDelete_BDGT_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Hir_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Ter_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_ACS_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-       

-End Sub

-

-

-<<<<<<
-======================
-REP_LIST
->>>>>>
-Attribute VB_Name = "REP_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentREP_ID() As Long

-    Dim r As Range

-

-    With Worksheets("REP_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CREP_ID)

-    End With

-

-    getCurrentREP_ID = r

-End Function

-

-Public Sub REP_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Rep_Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Rep_Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Rep_Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Rep_Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectREP_LPU(rep_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim r_id As Long

-    

-    Range("JUMP") = "LPU_LIST"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-        .Range("ent_date") = ent_date

-    End With

-End Sub

-

-Public Sub SelectREP_QTR(rep_id As Long)

-    Dim vo As Boolean

-    Dim r_id As Long

-    

-    Range("JUMP") = "REP_QTR"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("REP_QTR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateREPList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim rep_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CREP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CREP_AREA).row, CREP_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    rep_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CREP_AREA).Column

-    

-    If i < 4 Then

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 1

-    Else

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 2

-    End If

-    

-    If rep_id = 0 Then

-        Range("LAST_FOCUS") = Range(CREP_AREA).address

-    End If

-

-    If rep_id = 0 Then

-        i = CREP_NAME

-        Range("JUMP") = ""

-    Else

-        btREP_LIST_DO_IT

-    End If

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateREPList()

-    Dim rcd() As tREPID_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-

-    ent_date = getEnt_date

-

-    i = Get_REP_CommonList_by_QTR(rcd, ent_date)

-

-    With ThisWorkbook.Worksheets("REP_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(rcd)

-            r.Offset(i - 1, CREP_NAME) = rcd(i).rep.FirstName & " " & rcd(i).rep.LastName

-            r.Offset(i - 1, CREP_ID) = rcd(i).rep.rep_id

-            r.Offset(i - 1, CREP_BEDS) = rcd(i).qtrs(1).c_beds

-

-            r.Offset(i - 1, CREP_NFG) = rcd(i).qtrs(1).c_bdgt_NFG

-            r.Offset(i - 1, CREP_NMG) = rcd(i).qtrs(1).c_bdgt_NMG

-

-            r.Offset(i - 1, CREP_PLAN) = rcd(i).qtrs(1).qtr.sale_PLAN

-

-            r.Offset(i - 1, CREP_HIR) = rcd(i).qtrs(1).c_pat_HIR

-            r.Offset(i - 1, CREP_TER) = rcd(i).qtrs(1).c_pat_TER

-            r.Offset(i - 1, CREP_CAR) = rcd(i).qtrs(1).c_pat_CRD

-            r.Offset(i - 1, CREP_FACT) = rcd(i).qtrs(1).c_sale_ALL

-            r.Offset(i - 1, CREP_PAT_LPU) = rcd(i).qtrs(1).c_pat_LPU

-            r.Offset(i - 1, CREP_BDGT) = rcd(i).qtrs(1).c_bdgt_LPU

-            If rcd(i).qtrs(1).c_bdgt_LPU > 0 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = rcd(i).qtrs(1).c_sale_ALL / rcd(i).qtrs(1).c_bdgt_LPU

-            End If

-            If r.Offset(i - 1, CREP_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-

-

-<<<<<<
-======================
-mREP_LIST
->>>>>>
-Attribute VB_Name = "mREP_LIST"

-Option Explicit

-

-Public Const CREP_AREA As String = "B12"

-Public Const CREP_NAME As Integer = 0

-Public Const CREP_NAME1 As Integer = 1

-Public Const CREP_NAME2 As Integer = 2

-Public Const CREP_ID As Integer = 3

-Public Const CREP_BEDS As Integer = 4

-Public Const CREP_NFG As Integer = 5

-Public Const CREP_NMG As Integer = 6

-Public Const CREP_HIR As Integer = 7

-Public Const CREP_TER As Integer = 8

-Public Const CREP_CAR As Integer = 9

-Public Const CREP_FACT As Integer = 10

-Public Const CREP_PLAN As Integer = 11

-Public Const CREP_PAT_LPU As Integer = 16

-Public Const CREP_BDGT As Integer = 17

-Public Const CREP_PAT_ALL As Integer = 16

-

-

-

-Sub EditREP(cRep As tREPID, ent_date As String)

-    NoFunc

-End Sub

-

-Sub Rep_Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub Rep_Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btREP_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = "RM_QTR"

-    End With

-    ThisWorkbook.Worksheets("RM_QTR").Activate

-End Sub

-

-

-Sub btREP_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim rep_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("REP_LST_DETALS")

-    With Worksheets("REP_LIST")

-        rep_id = .getCurrentREP_ID

-        

-        Select Case i

-            Case 1:

-                .SelectREP_QTR rep_id

-            Case 2:

-                ent_date = .getEnt_date()

-                .SelectREP_LPU rep_id, ent_date

-        End Select

-    End With

-    

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-

-

-

-<<<<<<
-======================
-cdbREP
->>>>>>
-Attribute VB_Name = "cdbREP"

-Option Explicit

-

-Public Type tREPID_COMMON

-    rep As tREPID

-    i_qtrs As Integer

-    qtrs() As tQTR_COMMON

-End Type

-

-Function Get_REP_CommonList_by_QTR(ByRef rcd() As tREPID_COMMON, ent_date As String) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_REP_CommonList_by_QTR = dbGet_REP_CommonList_by_QTR(dbConnection, rcd, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_REP_CommonList_by_QTR(dbConnection As Object, ByRef rcd() As tREPID_COMMON, ent_date As String) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim k As Long

-    Dim allREPID() As tREPID

-    

-    i = dbGetAll_REPID_Records_by_QTR(dbConnection, allREPID, ent_date)

-    dbGet_REP_CommonList_by_QTR = i

-    If i > 0 Then

-        ReDim rcd(i)

-        For i = 1 To UBound(allREPID)

-            rcd(i).rep = allREPID(i)

-            rcd(i).i_qtrs = Get_QTR_CommonList_by_REP(rcd(i).qtrs, ent_date, allREPID(i).rep_id)

-        Next i

-    End If

-End Function

-

-

-

-<<<<<<
-======================
-CHRT_PAT_LPU_A
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU_A"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-cdbRegion
->>>>>>
-Attribute VB_Name = "cdbRegion"

-Option Explicit

-

-Type tREGION

-    ent_date As String

-    total_SALE As Long ' общий объем продаж

-    total_BDGT As Long ' бюджет всех ЛПУ

-    total_BDGT_NMG As Long ' бюджет всех ЛПУ на НМГ

-    total_LPU As Long ' число ЛПУ

-    total_REP   As Long ' число репов

-    total_BEDS As Long ' общее число коек

-    total_HIR As Long '  общее число пациентов на клексане в хирургии

-    total_TER As Long '  общее число пациентов на клексане в терапии

-    total_ACS As Long '  общее число пациентов на клексане в кардиологии

-    sale_PLAN As Long '  план продаж Авентиса

-End Type

-

-Function GetRGN_COMM_DATA(ByRef reg_data() As tREGION) As Integer

-    Dim q_date() As String

-    Dim q_count As Integer, i As Integer

-    

-    q_count = getAllQTRNames(q_date)

-    If q_count > 0 Then

-        ReDim reg_data(q_count)

-        For i = 1 To q_count

-            Dim current_rep_count As Integer

-            current_rep_count = getREGION_by_QTR(q_date(i), reg_data(i))

-        Next i

-    End If

-    

-    GetRGN_COMM_DATA = q_count

-End Function

-

-Function getAllQTRNames(ByRef qtr_lst() As String) As Integer

-    

-    Dim sql As String

-    Dim i As Integer

-    Dim db As Object, rs As Object

-    

-    

-    sql = "SELECT DISTINCT entry_date FROM lpu_budget"

-    i = 0

-    

-    dbOpenConnection db

-    Set rs = CreateObject("ADODB.Recordset")

-    

-    rs.Open sql, db

-        

-        If Not rs.BOF Then

-            Do While Not rs.EOF

-                i = i + 1

-                ReDim Preserve qtr_lst(i)

-                qtr_lst(i) = rs("entry_date")

-                rs.MoveNext

-            Loop

-        Else

-            getAllQTRNames = 0

-            Exit Function

-        End If

-    getAllQTRNames = i

-    dbCloseConnection db

-End Function

-

-Function getREGION_by_QTR(ent_date As String, treg As tREGION) As Integer

-    Dim rep_count As Integer

-    rep_count = 0

-    

-    Dim reps() As tREPID_COMMON

-    rep_count = Get_REP_CommonList_by_QTR(reps, ent_date)

-    

-    treg.ent_date = ent_date

-    treg.total_BDGT = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.total_BDGT_NMG = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.sale_PLAN = 0 ' quarter.sale_plan

-    treg.total_SALE = 0 'summ of

-    ' hir = (amb40+st40)*pr40 + (amb20+st20)*pr20

-    'ter (amb_clx+stat_clx)*price

-    ' acs xxx

-    'price per rep

-    treg.total_HIR = 0 'patiens clxn

-    treg.total_TER = 0 'patiens clxn

-    treg.total_ACS = 0 'patiens clxn

-    treg.total_LPU = 0 'lpu

-    treg.total_BEDS = 0 'lpu.beds

-    treg.total_REP = 0 '

-    

-    If rep_count > 0 Then

-        Dim i As Integer

-        

-        For i = 1 To UBound(reps)

-            ' current rep is reps(i)

-            With reps(i)

-                treg.total_BDGT = treg.total_BDGT + .qtrs(1).c_bdgt_NFG + .qtrs(1).c_bdgt_NMG

-                treg.total_BDGT_NMG = treg.total_BDGT_NMG + .qtrs(1).c_bdgt_NMG

-                treg.sale_PLAN = treg.sale_PLAN + .qtrs(1).c_sale_PLAN

-                treg.total_SALE = treg.total_SALE + .qtrs(1).c_sale_ALL

-                treg.total_HIR = treg.total_HIR + .qtrs(1).c_pat_HIR

-                treg.total_TER = treg.total_TER + .qtrs(1).c_pat_TER

-                treg.total_ACS = treg.total_ACS + .qtrs(1).c_pat_CRD

-                treg.total_LPU = treg.total_LPU + .qtrs(1).i_lcd

-                treg.total_BEDS = treg.total_BEDS + .qtrs(1).c_beds

-                treg.total_REP = treg.total_REP + 1

-            End With

-            

-        Next i

-        

-    End If

-    

-    getREGION_by_QTR = treg.total_REP

-End Function

-

-<<<<<<
-======================
-mRM_QTR
->>>>>>
-Attribute VB_Name = "mRM_QTR"

-Option Explicit

-

-Sub btRM_QTR_Do_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    

-    idx = Worksheets(VAR_SHEET).Range("RM_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            ImportData

-        Case 2

-            Worksheets("REP_LIST").Select

-        Case 3

-            cmExport

-    End Select

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-End Sub

-

-Sub ImportData()

-    Dim i As Integer

-    Dim def_dir As String

-    Dim flist() As String

-    

-    def_dir = GetWBPath(ThisWorkbook.FullName)

-    If GetImportDirectory(def_dir, flist) Then

-        Dim ImpMask() As String

-        ImpMask = Split(flist(1), Chr(95), Compare:=vbBinaryCompare)

-        flist(1) = ImpMask(0) & "*"

-        Dim db_list() As String

-        i = GetDBList(flist(), db_list)

-        If i > 0 Then

-            Merge_BackUp_All_Data

-            MergeGlobal db_list, GetWBPath(ThisWorkbook.FullName) & "clexane-rm.mdb"

-        End If

-    End If

-    Worksheets(RM_QTR_SHEET).update_history

-End Sub

-<<<<<<
-======================
-mImport
->>>>>>
-Attribute VB_Name = "mImport"

-    Option Explicit

-

-Const OFN_ALLOWMULTISELECT As Long = 512

-Const OFN_EXPLORER As Long = 524288

-Const OFN_HIDEREADONLY As Long = 4

-Const OFN_NONETWORKBUTTON As Long = 131072

-Const OFN_READONLY As Long = 1

-       

-Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _

-    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

-

-Private Type OPENFILENAME

-    lStructSize As Long

-    hWndOwner As Long

-    hInstance As Long

-    lpstrFilter As String

-    lpstrCustomFilter As String

-    nMaxCustFilter As Long

-    nFilterIndex As Long

-    lpstrFile As String

-    nMaxFile As Long

-    lpstrFileTitle As String

-    nMaxFileTitle As Long

-    lpstrInitialDir As String

-    lpstrTitle As String

-    flags As Long

-    nFileOffset As Integer

-    nFileExtension As Integer

-    lpstrDefExt As String

-    lCustData As Long

-    lpfnHook As Long

-    lpTemplateName As String

-End Type

-

-Function GetImportDirectory(DB_dir As String, flist() As String) As Boolean

-    Dim OpenFile As OPENFILENAME

-    Dim lReturn As Long

-    Dim sFilter As String

-    

-    OpenFile.lStructSize = Len(OpenFile)

-    '         OpenFile.hwndOwner = Form1.hWnd

-    '         OpenFile.hInstance = App.hInstance

-    sFilter = "Clexane Data Files" & Chr(0) & "mr*.mdb" & Chr(0)

-    OpenFile.lpstrFilter = sFilter

-    OpenFile.nFilterIndex = 1

-    OpenFile.lpstrFile = String(257, 0)

-    OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1

-    OpenFile.lpstrFileTitle = OpenFile.lpstrFile

-    OpenFile.nMaxFileTitle = OpenFile.nMaxFile

-    OpenFile.lpstrInitialDir = DB_dir

-    OpenFile.lpstrTitle = "Импорт данных"

-    OpenFile.flags = OFN_HIDEREADONLY + OFN_EXPLORER

-    lReturn = GetOpenFileName(OpenFile)

-    If lReturn = 0 Then

-        GetImportDirectory = False

-    Else

-        GetImportDirectory = True

-        flist = Split(OpenFile.lpstrFile, Chr(0), Compare:=vbBinaryCompare)

-        Dim i As Integer

-        i = 0

-        Do While flist(i) <> ""

-            i = i + 1

-        Loop

-        If i = 1 Then

-            flist(1) = flist(0)

-            flist(0) = GetWBPath(flist(1))

-            flist(1) = GetWBName(flist(1))

-        Else

-            flist(0) = flist(0) & "\"

-        End If

-    End If

-End Function

-<<<<<<
-Project Name : 'ClexanePM'
-Quirk - duff tag length======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-

-    Application.EnableEvents = True

-    Set MyAppEvents.app = Application

-    

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    

-    MyAppEvents.CheckWorkBooksArround ThisWorkbook

-    

-    cmSetStandaloneMode

-    

-    Application.ScreenUpdating = True

-'    CheckUser

-

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).Select

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).update_history

-    Application.Calculate

-

-End Sub

-

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    

-    Dim RestMode As Boolean

-    RestMode = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE")

-    

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-'        If RestMode Then

-            ThisWorkbook.Saved = True

-'        Else

-'            ThisWorkbook.Save

-'        End If

-    End If

-    If RestMode Then

-        xlRestoreView

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    End If

-    Application.Caption = Empty

-    Application.CommandBars(STDBAR_NAME).Reset

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-    Dim MaxX, MaxY As Integer

-    With ThisWorkbook.Worksheets(TITLE_SHEET)

-        MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-        MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-    End With

-

-    With ThisWorkbook.Application

-        .ScreenUpdating = False

-        .WindowState = xlNormal

-        .Height = MaxY

-        .Width = MaxX

-    End With

-End Sub

-

-

-

-

-

-<<<<<<
-======================
-REP_QTR
->>>>>>
-Attribute VB_Name = "REP_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CQTR_QT As Integer = 0

-Const CQTR_ID As Integer = 1

-Const CQTR_PLN As Integer = 2

-Const CQTR_FCT As Integer = 3

-Const CQTR_BDG As Integer = 4

-Const CQTR_CNT As Integer = 5

-Const CQTR_BEDS As Integer = 6

-Const CQTR_HIR As Integer = 7

-Const CQTR_TER As Integer = 8

-Const CQTR_CRD As Integer = 9

-Const CQTR_CLXN_BDG As Integer = 10

-Const CQTR_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Const LOCAL_ENT_DATE As String = "QTR_SEL"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("REP_QTR")

-        s = .Range("D5") & " " & .Range("D4") & ", " & .Range("H5") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub update_history()

-    Dim objQTR() As tQTR

-    Dim i As Long

-    Dim r As Range

-    Dim cRep As tREPID

-    Dim rm_id As Long

-

-    rm_id = Range("RM_ID")

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    Range("D4") = cRep.LastName

-    Range("D5") = cRep.FirstName

-

-    Range("H4") = GetRegionName(cRep.Region)

-    Range("H5") = GetCityName(cRep.Region, cRep.City)

-

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetAll_QTR_Records_by_REP(objQTR, "%", cRep.rep_id, rm_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CQTR_QT) = objQTR(i).entry_date

-        Next i

-    End If

-    Dim qcd() As tQTR_COMMON

-    i = Get_QTR_CommonList_by_REP(qcd, "%", cRep.rep_id, rm_id)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(qcd)

-            r.Offset(i - 1, CQTR_QT) = qcd(i).qtr.entry_date

-            r.Offset(i - 1, CQTR_ID) = qcd(i).qtr.id

-            r.Offset(i - 1, CQTR_PLN) = qcd(i).qtr.sale_PLAN

-            r.Offset(i - 1, CQTR_FCT) = qcd(i).c_sale_ALL

-            r.Offset(i - 1, CQTR_BDG) = qcd(i).c_bdgt_LPU

-            r.Offset(i - 1, CQTR_CNT) = qcd(i).i_lcd

-            r.Offset(i - 1, CQTR_BEDS) = qcd(i).c_beds

-            r.Offset(i - 1, CQTR_HIR) = qcd(i).c_pat_HIR

-            r.Offset(i - 1, CQTR_TER) = qcd(i).c_pat_TER

-            r.Offset(i - 1, CQTR_CRD) = qcd(i).c_pat_CRD

-            If qcd(i).c_bdgt_LPU <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_BDG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_LPU

-            End If

-            If qcd(i).c_bdgt_NMG <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_NMG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CQTR_CRD + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-

-Sub Draw_PLN_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_FCT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PLN_QTR").Range("title") = MakeChartTitle

-End Sub

-

-Sub Draw_BDGT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_CLXN_NMG + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_BDGT_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Public Sub cbxRepQtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CQTR_ID + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    i = currRange.Column - Range(CINP_AREA).Column

-

-    QTR_ID = r

-

-    If QTR_ID = 0 Then

-        Worksheets(VAR_SHEET).Range("USER_ACTION") = 1

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        If i > CQTR_FCT Then

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-            Range("LAST_FOCUS") = currRange.address

-        Else

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 3

-            Range("LAST_FOCUS") = currRange.address

-        End If

-    End If

-    Cancel = True

-    btHomeDo_IT

-End Sub

-

-<<<<<<
-======================
-mRep_QTR
->>>>>>
-Attribute VB_Name = "mRep_QTR"

-Option Explicit

-

-Sub NoFunc()

-    MsgBox "Функция не доступна", vbOKOnly, PROGRAM_NAME

-End Sub

-

-Sub DO_Price_qtr(ent_date As String)

-    Dim qtr As tQTR

-    Dim res As Integer

-    Dim cRep As tREPID

-    Dim rm_id As Long

-

-    rm_id = Worksheets(REP_QTR_SHEET).Range("RM_ID")

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    qtr = Get_QTR_Record_by_REP(ent_date, cRep.rep_id, cRep.rm_id)

-

-    If qtr.id = 0 Then

-        qtr.entry_date = ent_date

-

-        With Worksheets(VAR_SHEET)

-            qtr.ClxnH20mg = .Range("ClxnH20mg")

-            qtr.ClxnH40mg = .Range("ClxnH40mg")

-            qtr.ClxnT40mg = .Range("ClxnT40mg")

-            qtr.ClxnC_ACS = .Range("ClxnC_ACS")

-            qtr.ClxnC_IM = .Range("ClxnC_IM")

-        End With

-    End If

-

-    Dim dlg_nq As dlg_nextQTR

-    Set dlg_nq = New dlg_nextQTR

-

-    With dlg_nq

-        .tb_qtr_name = qtr.entry_date

-        .tb_bdgt_avts = qtr.sale_PLAN

-        .tb_qtr_name = qtr.entry_date

-        .tb_ClxnH20mg = qtr.ClxnH20mg

-        .tb_ClxnH40mg = qtr.ClxnH40mg

-        .tb_ClxnT40mg = qtr.ClxnT40mg

-        .tb_ClxnC_ACS = qtr.ClxnC_ACS

-        .tb_ClxnC_IM = qtr.ClxnC_IM

-    End With

-

-    dlg_nq.Show

-End Sub

-

-Sub DO_Edit_qtr(ent_date As String)

-    If ent_date = "" Then

-        NoFunc

-    Else

-        Dim rep_id As Long

-        rep_id = Worksheets(REP_QTR_SHEET).Range("REP_ID")

-        With ThisWorkbook.Worksheets("LPU_LIST")

-            .Range("VIEW_ONLY") = True

-            .setEnt_date (ent_date)

-            .Range("REP_ID") = rep_id

-            .Select

-        End With

-    End If

-End Sub

-

-Sub DO_Delete_qtr(ent_date As String)

-    If ent_date <> "" Then

-        MsgBox "Удалить данные за период [" & ent_date & "] нельзя ", vbOKOnly, PROGRAM_NAME

-    End If

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-

-Sub btHomeDo_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    idx = Worksheets(VAR_SHEET).Range("USER_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).getEnt_date()

-    Select Case idx

-        Case 1

-            NoFunc

-            ' Обновляем экран

-        Case 2

-            DO_Edit_qtr ent_date

-        Case 3

-            DO_Price_qtr ent_date

-        Case 4

-            NoFunc

-    End Select

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-Sub Delete_qtr()

-'    Dim ent_date As String

-'    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-'    DO_Delete_qtr ent_date

-End Sub

-

-Sub btREP_QTR_RET_IT()

-    Dim s As String

-    With Worksheets("REP_QTR")

-        .Range("LAST_FOCUS") = ""

-        s = .Range("ret_addr")

-        .Range("ret_addr") = ""

-    End With

-    If s <> "" Then

-        ThisWorkbook.Worksheets(s).Select

-    Else

-        ThisWorkbook.Worksheets(RM_QTR_SHEET).Select

-    End If

-End Sub

-

-

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public ppReport As New cPPReport

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane[PM]"

-Public Const PROGRAM_VERSION As String = "Clexane[PM] ver 1.1"

-Public Const PROGRAM_FILENAME As String = "clexane-pm"

-Public Const PROGRAM_BACKUPNAME As String = "pm-backup-"

-Public Const PROGRAM_EXPORTNAME As String = "pm-ex-"

-Public Const PROGRAM_IMPORTNAME As String = "rm-ex*"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-Public Const CHART_DEF_TITLE As String = "* * *"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20031207

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "O41"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-Public Const RM_QTR_SHEET As String = "RM_QTR"

-Public Const PRJ_QTR_SHEET As String = "PRJ_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-Function time_correct(end_date As Long, ByVal theDate As Date) As Boolean

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-    If end_date = NO_ESTIMATION_DATE Then

-        time_correct = True

-        Exit Function

-    End If

-    

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    

-    time_correct = CurDate <= end_date

-    

-End Function

-

-Sub EnableRun(end_date As Long)

-    If Not time_correct(end_date, Now) Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-Sub t()

-    EnableRun ESTIMATION_DATE

-End Sub

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Sub OpenPPT()

-    ppReport.ReportView

-End Sub

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-

-End Sub

-

-Function Double2Str(ByVal d As Double, ByVal precision As Integer, Optional Delim As String = ".") As String

-    Dim s As String

-    If Not precision > 0 Then

-        s = Round(d)

-    Else

-        Dim i As Integer

-        i = Fix(d)

-        s = i & Delim

-        d = Abs(d - i)

-        Do

-            precision = precision - 1

-            d = d * 10

-            If precision > 0 Then

-                i = Fix(d)

-            Else

-                i = Round(d)

-            End If

-            If i < 1 Then

-                s = s & "0"

-            Else

-                s = s & i

-                d = d - i

-            End If

-        Loop While precision > 0

-    End If

-    Double2Str = s

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetWBName(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBName = Right(FullName, s_len - pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.Name = VAR_SHEET Or sh.Name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-<<<<<<
-======================
-Var
->>>>>>
-Attribute VB_Name = "Var"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-title
->>>>>>
-Attribute VB_Name = "title"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LPU_LIST
->>>>>>
-Attribute VB_Name = "LPU_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Const LOCAL_ENT_DATE As String = "C10"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Function getCurrentLPU_ID() As Long

-    Dim r As Range

-

-    With Worksheets("LPU_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CLPU_ID)

-    End With

-

-    getCurrentLPU_ID = r

-End Function

-

-Public Sub LPU_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectLPU_NAME(lpu_id As Long, ent_date As String)

-    SelectLPU_BDGT lpu_id, ent_date

-End Sub

-

-Sub SelectLPU_BDGT(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    If lpu_id = 0 Then

-        SelectLPU_NAME lpu_id, ent_date

-    Else

-        With ThisWorkbook.Worksheets("LPU_BDGT")

-            .Range("VIEW_ONLY") = vo

-            .Range("ret_addr") = "LPU_LIST"

-            .setEnt_date (ent_date)

-            .Range("lpu_id") = lpu_id

-            .Range("REP_ID") = rep_id

-            .Range("RM_ID") = rm_id

-        End With

-    End If

-End Sub

-

-Sub SelectLPU_HIR(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_HIR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .setEnt_date (ent_date)

-        .Range("lpu_id") = lpu_id

-        .Range("REP_ID") = rep_id

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Sub SelectLPU_TER(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_TER")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .setEnt_date (ent_date)

-        .Range("lpu_id") = lpu_id

-        .Range("REP_ID") = rep_id

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Sub SelectLPU_C_ACS(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    

-    Dim rep_id As Long

-    rep_id = Range("REP_ID")

-    

-    Dim rm_id As Long

-    rm_id = Range("RM_ID")

-    

-    With ThisWorkbook.Worksheets("LPU_CLSN_C_ACS")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .setEnt_date (ent_date)

-        .Range("RM_ID") = rm_id

-        .Range("REP_ID") = rep_id

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateLPUList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim lpu_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CINP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CINP_AREA).row, CLPU_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    lpu_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CINP_AREA).Column

-

-    If lpu_id = 0 Then

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    End If

-

-    If lpu_id = 0 Then

-        i = CLPU_NAME

-        Range("JUMP") = ""

-    End If

-    Select Case i

-        Case CLPU_NAME, CLPU_NAME1, CLPU_NAME2, CLPU_BEDS

-            SelectLPU_NAME lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-

-        Case CLPU_NMG, CLPU_NFG, CLPU_PLAN, CLPU_FACT

-            SelectLPU_BDGT lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-

-        Case CLPU_HIR

-            SelectLPU_HIR lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_HIR"

-

-        Case CLPU_TER

-            SelectLPU_TER lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_TER"

-

-        Case CLPU_CAR

-            SelectLPU_C_ACS lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        Case Else

-            Range("JUMP") = ""

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateLPUList()

-    Dim lcd() As tLPU_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-    Dim objQTR As tQTR

-    Dim cRep As tREPID

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    ent_date = getEnt_date

-

-'     ent_date = "%" ' % - all records

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id, cRep.rm_id)

-    i = Get_LPU_CommonQTR(lcd, objQTR)

-

-'     стираем ФИО

-    Range("C3:C4").ClearContents

-

-    Range("C3") = cRep.LastName

-    Range("C4") = cRep.FirstName

-    Range("G3") = GetRegionName(cRep.Region)

-    Range("G4") = GetCityName(cRep.Region, cRep.City)

-    Range("G5") = objQTR.sale_PLAN

-

-

-

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(lcd)

-            r.Offset(i - 1, CLPU_NAME) = lcd(i).lpu.Name

-            r.Offset(i - 1, CLPU_ID) = lcd(i).lpu.id

-            r.Offset(i - 1, CLPU_BEDS) = lcd(i).lpu.beds

-

-

-            r.Offset(i - 1, CLPU_NFG) = lcd(i).bdgt.bdgt_NFG

-            r.Offset(i - 1, CLPU_NMG) = lcd(i).bdgt.bdgt_NMG

-            r.Offset(i - 1, CLPU_PLAN) = lcd(i).bdgt.sale_PLAN

-

-            r.Offset(i - 1, CLPU_HIR) = lcd(i).pat_HIR

-            r.Offset(i - 1, CLPU_TER) = lcd(i).pat_TER

-            r.Offset(i - 1, CLPU_CAR) = lcd(i).pat_CRD

-            r.Offset(i - 1, CLPU_FACT) = lcd(i).sale_ALL

-            r.Offset(i - 1, CLPU_PAT_LPU) = lcd(i).pat_LPU

-            r.Offset(i - 1, CLPU_BDGT) = lcd(i).bdgt_LPU

-            If lcd(i).bdgt_LPU > 0 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = lcd(i).sale_ALL / lcd(i).bdgt_LPU

-            End If

-            If r.Offset(i - 1, CLPU_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{32FB0F3D-6884-41DC-99DB-E2C55B2257C4}{DED79A66-DA60-4CCC-9003-082480235D55}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-dbACS
->>>>>>
-Attribute VB_Name = "dbACS"

-Option Explicit

-

-Public Type tACS

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    patients_with_geparins As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objACS.ID <> 0 then updatre else insert

-Sub Insert_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objACS.id <> 0 Then

-        dbUpdate_ACS_Record dbConnection, objACS

-    Else

-        dbInsert_ACS_Record dbConnection, objACS

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_ACS_RecordsByLPU_ID(ByRef all_ACS_() As tACS, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_ACS_RecordsByLPU_ID = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, all_ACS_, lpu_id, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_ACS_Record dbConnection, objACS

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub dbInsert_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_acs", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objACS

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("patients_with_geparins") = .patients_with_geparins

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objACS.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim Update_SQL As String

-    

-    With objACS

-        Update_SQL = "UPDATE lpu_acs SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "patients_with_geparins=" & .patients_with_geparins & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_ACS_RecordsbyLPU_ID(dbConnection As Object, all_ACS() As tACS, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_ACS_SQL As String

-    Dim getAll_ACS_SQL As String

-    Dim ACS_Count As Long

-    ACS_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    Else

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_ACS_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        ACS_Count = dbRecordset("ACS_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_ACS_RecordsbyLPU_ID = ACS_Count

-    

-    If ACS_Count > 0 Then

-        'we have records

-        ReDim all_ACS(1 To ACS_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_ACS_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_ACS As tACS

-                 With tmp_ACS

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .patients_with_geparins = dbRecordset("patients_with_geparins")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 all_ACS(index) = tmp_ACS

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE ID=" & objACS.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_ACS_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_HIR
->>>>>>
-Attribute VB_Name = "LPU_CLSN_HIR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const LOCAL_ENT_DATE As String = "S38"

-

-Sub PrintCopy()

-    Range("A1:M26").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-

-        Dim objHir As tHIRURGIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objHir

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .operations_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L9")

-                .patients_ambulator_clexan_20mg = Range("L10")

-                .patients_ambulator_clexan_40mg = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L19")

-                .patients_stationar_clexan_20mg = Range("L20")

-                .patients_stationar_clexan_40mg = Range("L21")

-            End With

-            Insert_Hir_Record objHir

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objHir.id = Range("rec_id")

-                    If objHir.id <> 0 Then

-                        Delete_Hir_Record objHir

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-End Sub

-

-Sub SetupData(objHir As tHIRURGIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    With objHir

-        Range("rec_id") = .id

-        Range("F6") = .operations_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L9") = .patients_ambulator_clexan

-        Range("L10") = .patients_ambulator_clexan_20mg

-        Range("I21") = .patients_stationar_nmg

-        Range("L19") = .patients_stationar_clexan

-        Range("L20") = .patients_stationar_clexan_20mg

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id, cRep.rm_id)

-

-        formula = "=" & qtr.ClxnH20mg & "*($L$10+$L$20)+" & qtr.ClxnH40mg & "*($L$11+$L$21)"

-        Range("F11").formula = formula

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id, Range("RM_ID"))

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.Name

-        Range("lpu_addr") = lpu.address

-

-        Dim objHir() As tHIRURGIA

-        Dim i As Integer

-        i = GetAll_Hir_RecordsByLPU_ID(objHir, id, Range("ent_date"), Range("RM_ID"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.3

-        Else

-            SetupData objHir(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-mSapes
->>>>>>
-Attribute VB_Name = "mSapes"

-Option Explicit

-

-Const SHAPE_COLOR As Integer = 1

-Const SHAPE_NAME As Integer = 2

-

-

-Sub ShapeView(r_sh_finite_state As Range)

-    Dim chk As Range

-    Dim s As String

-    Dim c, idx As Integer

-    For Each chk In r_sh_finite_state

-        idx = 0

-        If chk = "+" Then

-            c = chk.Offset(0, idx + SHAPE_COLOR)

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While c <> 0

-                ShapeFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s)), c

-                idx = idx + 2

-                c = chk.Offset(0, idx + SHAPE_COLOR)

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        Else

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While s <> ""

-                ShapeUnFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s))

-                idx = idx + 2

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        End If

-    Next chk

-End Sub

-

-Sub ShapeFill(sh As ShapeRange, ByVal color As Integer)

-    sh.Fill.Visible = msoTrue

-    sh.Fill.Solid

-    sh.Fill.ForeColor.SchemeColor = color

-    sh.Fill.Transparency = 0#

-End Sub

-

-Sub ShapeUnFill(sh As ShapeRange)

-    sh.Fill.Visible = msoFalse

-    sh.Fill.Transparency = 0#

-End Sub

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Public Const INPUT_NO = 0

-Public Const INPUT_NUMBER = 1

-Public Const INPUT_PERCENT = 2

-Public Const INPUT_STRING = 3

-Public Const INPUT_CHECK = 4

-

-Public Const INP_IDX_TYPE = 1

-Public Const INP_IDX_NEXT = 2

-Public Const INP_IDX_MIN = 3

-Public Const INP_IDX_MAX = 4

-Public Const INP_IDX_DEP = 5

-Public Const INP_IDX_ALT = 7

-

-

-Public Type tInputSet

-    vType As Integer

-    vMin As Long

-    vMax As Long

-    rChk As String

-End Type

-

-Function is_input_cell(ByVal Target As Range, inputs As Range) As tInputSet

-    Dim t As Range

-    Dim iset As tInputSet

-    Dim test As Range

-    iset.vType = INPUT_NO

-    iset.vMin = 0

-    iset.vMax = 0

-    iset.rChk = ""

-    is_input_cell = iset

-

-' Закоментировать следующую сточку для работы

-'  Exit Function

-

-    Set test = Target.Cells(1, 1)

-    For Each t In inputs

-        If Range(t).Column = test.Column And Range(t).row = test.row Then

-            iset.vType = t.Offset(0, INP_IDX_TYPE).Value

-            Select Case iset.vType

-                Case INPUT_CHECK

-                    iset.rChk = t.Offset(0, INP_IDX_ALT)

-                Case INPUT_NUMBER, INPUT_PERCENT

-                    iset.vMin = t.Offset(0, INP_IDX_MIN).Value

-                    iset.vMax = t.Offset(0, INP_IDX_MAX).Value

-            End Select

-            is_input_cell = iset

-            Exit Function

-        End If

-    Next t

-End Function

-

-Function GetFocusAddress(ByVal r As Range, f_next As Range) As String

-    Dim chk, t As Range

-    

-    For Each chk In f_next

-        For Each t In r

-            If t.address = chk Then

-                GetFocusAddress = chk

-                Exit Function

-            End If

-            If Range(chk).Column = t.Column - 1 And Range(chk).row = t.row _

-            Or Range(chk).Column = t.Column And Range(chk).row = t.row - 1 _

-            Then

-                If Range(chk) <> "" Then

-                    If Range(chk) = 0 Then

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_ALT)).address

-                    Else

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_NEXT)).address

-                    End If

-                Else

-                    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-                End If

-                Exit Function

-            End If

-        Next t

-    Next chk

-    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-End Function

-

-Sub SetDependet(r As Range, inputs As Range)

-    Dim chk As Range

-    Dim s, serr As String

-    Dim idx As Integer

-    Dim iset As tInputSet

-    Dim err_found As Boolean

-    

-    If r.count > 1 Then

-        Exit Sub

-    End If

-    

-    err_found = False

-    For Each chk In inputs

-        idx = INP_IDX_DEP

-        

-        

-        iset.vType = chk.Offset(0, INP_IDX_TYPE).Value

-        Select Case iset.vType

-            Case INPUT_NUMBER, INPUT_PERCENT

-                iset.vMin = chk.Offset(0, INP_IDX_MIN).Value

-                iset.vMax = chk.Offset(0, INP_IDX_MAX).Value

-                

-                If Range(chk) > iset.vMax Then

-                    err_found = True

-                    Range(chk) = iset.vMax

-                    serr = "Выход за дозволенный диапазон [" & iset.vMin & ".." & iset.vMax & "]! Данные скорректированы."

-                End If

-                

-                If Range(chk) = "" Then

-                    s = chk.Offset(0, idx)

-                    Do While s <> ""

-                        Range(s) = ""

-                        idx = idx + 1

-                        s = chk.Offset(0, idx)

-                    Loop

-                End If

-        End Select

-    Next chk

-    If err_found Then

-        MsgBox serr, vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Function CheckInputData(inputs As Range) As Boolean

-    Dim r As Range

-    

-    CheckInputData = True

-    For Each r In inputs

-        If Range(r) = "" Then

-            CheckInputData = False

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100.", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Sub Check_Int_Number(Target As Range, Def_Val As Long)

-    Dim err As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    err = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                err = True

-            End If

-        End If

-    Next r

-    If err Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_TER
->>>>>>
-Attribute VB_Name = "LPU_CLSN_TER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const LOCAL_ENT_DATE As String = "S38"

-

-Sub PrintCopy()

-    Range("A1:M26").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim objTer As tTERAPIA

-

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objTer

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .patients_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L20")

-            End With

-            Insert_Ter_Record objTer

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objTer.id = Range("rec_id")

-                    If objTer.id <> 0 Then

-                        Delete_Ter_Record objTer

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-

-End Sub

-

-Sub SetupData(objTer As tTERAPIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    Dim cRep As tREPID

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    cRep = Get_REPID_Record(Range("REP_ID"), rm_id)

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-    

-    With objTer

-        Range("rec_id") = .id

-        Range("F6") = .patients_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L11") = .patients_ambulator_clexan

-        Range("I21") = .patients_stationar_nmg

-        Range("L20") = .patients_stationar_clexan

-

-        qtr = Get_QTR_Record_by_REP(.entry_date, cRep.rep_id, cRep.rm_id)

-        formula = "=" & qtr.ClxnT40mg & "*($L$12+$L$20)"

-        Range("F11").formula = formula

-

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-

-    Range("h_DepFlag") = False

-

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id, Range("RM_ID"))

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.Name

-        Range("lpu_addr") = lpu.address

-

-        Dim objTer() As tTERAPIA

-        Dim i As Integer

-        i = GetAll_Ter_RecordsByLPU_ID(objTer, id, Range("ent_date"), Range("RM_ID"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.25

-        Else

-            SetupData objTer(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{0DC9E035-CE0A-49FF-85A2-A4EC5FF8FE96}{D54DDC8A-1EE2-4BB3-8B94-343B521AF098}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-LPU_BDGT
->>>>>>
-Attribute VB_Name = "LPU_BDGT"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const LOCAL_ENT_DATE As String = "S15"

-

-Sub PrintCopy()

-    Range("B1:K21").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Public Sub SetDefFocus()

-    Range(Range("DEF_FOCUS")).Select

-End Sub

-

-Public Sub ClearData()

-    ClearSheetData

-End Sub

-

-Sub ClearSheetData()

-    If Range("F10") = 0 And Range("F13") = 0 Then

-        Range("F11:F18") = ""

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("F11:F13") = ""

-    End If

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim bdgt As tBUDGET

-        Dim sum As Long

-        Dim test As Boolean

-        With bdgt

-            .lpu_id = Range("lpu_id")

-            .id = Range("rec_id")

-            .entry_date = Range("ent_date")

-            .bdgt_NMG = Round(Range("F11").Value, 0)

-            .bdgt_NFG = Round(Range("F12").Value, 0)

-            .sale_PLAN = Round(Range("F13").Value, 0)

-

-            sum = .bdgt_NFG + .bdgt_NMG - .sale_PLAN

-            test = .bdgt_NFG <> 0 Or .bdgt_NMG <> 0 Or .sale_PLAN <> 0

-        End With

-        If test Then

-            If sum < 0 Then

-                MsgBox _

-                    "Ваш план превышает выделенный на гепарины бюджет. Сохранить данные?", _

-                    vbOKOnly, PROGRAM_NAME

-            End If

-            If test Then

-                Insert_BDGT_Record bdgt

-            End If

-        Else

-            If bdgt.id <> 0 Then

-                If vbYes = MsgBox("Удалить данные из базы!", vbYesNo, PROGRAM_NAME) Then

-                    Delete_BDGT_Record bdgt

-                End If

-                ret_back Range("DEF_FOCUS").Worksheet

-                Exit Sub

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-    End If

-

-   ClearData

-   ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(cLPU As tLPU_COMMON)

-    Dim t_sum As Long

-    t_sum = 0

-' Setup budget data

-    Range("F11") = cLPU.bdgt.bdgt_NMG

-    Range("F12") = cLPU.bdgt.bdgt_NFG

-    Range("F13") = cLPU.bdgt.sale_PLAN

-

-    With cLPU

-        Range("F14") = .pat_ALL

-        Range("F15") = .pat_HIR

-        Range("F16") = .pat_TER

-        Range("F17") = .pat_CRD

-        Range("F18") = .sale_ALL

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    ws_activate

-End Sub

-

-

-Sub ws_activate()

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Dim cLPU As tLPU_COMMON

-    Dim objQTR As tQTR

-    Dim objLPU As tLPU

-    Dim ent_date As String

-    Dim id As Long

-    Dim cRep As tREPID

-    

-    cRep = Get_REPID_Record(Range("REP_ID"), Range("RM_ID"))

-    

-    If cRep.rep_id = 0 Then

-        Exit Sub

-    End If

-

-    id = Range("lpu_id").Value

-    ent_date = Range("ent_date")

-    

-    objQTR = Get_QTR_Record_by_REP(ent_date, cRep.rep_id, cRep.rm_id)

-

-    objLPU = Get_LPU_Record(id, Range("RM_ID"))

-    Get_LPU_Common cLPU, objLPU, objQTR

-

-    If cLPU.lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = cLPU.lpu.beds

-        Range("lpu_name") = cLPU.lpu.Name

-        Range("lpu_addr") = cLPU.lpu.address

-        Range("rec_id") = cLPU.bdgt.id

-

-        SetupData cLPU

-

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-'    MsgBox Target.address

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case INPUT_CHECK

-

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{BFB4547C-96A7-4739-AA0A-CEF1E35E2BDC}{C3D618A3-9410-4BC7-9D93-3B049D361132}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mSheets
->>>>>>
-Attribute VB_Name = "mSheets"

-Option Explicit

-

-Function am_load_now() As Boolean

-    am_load_now = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE")

-End Function

-

-Sub Wks_select(RetSheet As String)

-    Dim sheet As Worksheet

-    For Each sheet In ThisWorkbook.Worksheets

-        If sheet.Name = RetSheet Then

-            ThisWorkbook.Worksheets(RetSheet).Select

-            Exit Sub

-        End If

-    Next sheet

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub ret_back(sh As Worksheet)

-    Dim RetSheet As String

-    RetSheet = sh.Range("ret_addr")

-    sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    sh.Range("rec_id") = ""

-    sh.Range("lpu_id") = ""

-    sh.Range("ent_date") = ""

-    sh.Range("lpu_name") = ""

-    sh.Range("lpu_addr") = ""

-    sh.Range("lpu_beds") = ""

-    Wks_select RetSheet

-    sh.Range("ret_addr") = ""

-End Sub

-

-Sub ClearSheetData(r_start As Range)

-    If r_start <> "" Then

-        r_start.Worksheet.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        r_start = ""

-    Else

-        ret_back r_start.Worksheet

-    End If

-End Sub

-

-Sub wks_sel_chng(iset As tInputSet, ByVal Target As Range, sh As Worksheet)

-    Dim DebugMode As Boolean

-    Dim in_range As Range

-    

-    DebugMode = Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-

-    If DebugMode Then

-        sh.Unprotect

-    Else

-        sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    End If

-

-    If iset.vType = INPUT_CHECK Then

-        Set in_range = Target.Worksheet.Range(iset.rChk)

-    Else

-        Set in_range = Target

-    End If

-    

-    Dim str As String

-    str = GetFocusAddress(in_range, sh.Range("h_inputs"))

-

-'    MsgBox Target.Address & "; " & str

-    If str <> Target.address Then

-        sh.Range(str).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-Dlg_lpu_card
->>>>>>
-Attribute VB_Name = "Dlg_lpu_card"

-Attribute VB_Base = "0{9AAD262F-A6C4-4912-9C58-D7A2071181B8}{9470F4EB-DA9F-4584-9159-D09319548D21}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbLPU_List_Change()

-    Dim src As Range

-    Dim idx_src As Integer

-    

-    Set src = Worksheets(VAR_SHEET).Range(Me.cbLPU_List.RowSource)

-    idx_src = Me.cbLPU_List.ListIndex + 1

-    Me.tb_lpu_name.Text = src.Cells(idx_src, 1)

-    Me.tb_lpu_address.Text = src.Cells(idx_src, 2)

-    Me.tbBedsCount.Text = src.Cells(idx_src, 3)

-End Sub

-

-

-Private Sub cbxLPU_List_Enable_Click()

-    

-    If Me.cbxLPU_List_Enable Then

-        

-        Me.tb_lpu_name.Text = ""

-        Me.tb_lpu_name.Enabled = False

-        

-        Me.tb_lpu_address.Text = ""

-        Me.tb_lpu_address.Enabled = False

-        

-        Me.tbBedsCount.Text = ""

-        Me.tbBedsCount.Enabled = False

-        

-        Me.cbLPU_List.Enabled = True

-        cbLPU_List_Change

-    Else

-        Me.tb_lpu_name.Enabled = True

-        Me.tb_lpu_name.Text = ""

-        

-        Me.tb_lpu_address.Enabled = True

-        Me.tb_lpu_address.Text = ""

-        

-        Me.tbBedsCount.Enabled = True

-        Me.tbBedsCount.Text = ""

-        

-        Me.cbLPU_List.Enabled = False

-    End If

-End Sub

-

-<<<<<<
-======================
-UserInfo
->>>>>>
-Attribute VB_Name = "UserInfo"

-Attribute VB_Base = "0{A8FBEE9C-DE59-49DE-971D-07BC9C0E9BD2}{C712732B-D8E4-4C2D-8E78-AC90968E0CD7}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Tag = vbOK

-End Sub

-

-Private Sub cbCity_Change()

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_CITY") = Me.cbCity.ListIndex

-        .Calculate

-    End With

-End Sub

-

-Private Sub cbRegion_Change()

-    Dim LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        NewRangeOffsetCol = cbRegion.Value * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .Name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).address

-        NewSumRange = .Name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).address

-        .Calculate

-        .Range("IDX_CITY") = 0

-        cbCity.RowSource = NewCbxRange

-

-    End With

-    cbCity.ListIndex = 0

-End Sub

-

-<<<<<<
-======================
-mREGMAN
->>>>>>
-Attribute VB_Name = "mREGMAN"

-Option Explicit

-

-Sub hw_reset()

-    Dim rs As Range

-    Dim re As Object

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    HWReset

-    With Application

-        .DisplayAlerts = False

-        .Quit

-    End With

-End Sub

-

-Sub CheckUser()

-    If Range("HW_Number") = "" Then

-        StoreHWInfo

-    End If

-    If CheckHWInfo <> True Then

-        MsgBox "2"

-        cmAbout

-'        With Application

-'            .DisplayAlerts = False

-'            .Quit

-'        End With

-    Else

-        SetupUser

-    End If

-End Sub

-

-

-Sub SetupUser()

-'    Dim cREGMAN As tREGMAN

-'    Dim idx As Integer

-'    Dim dlg_ui As UserInfo

-'

-'    Set dlg_ui = New UserInfo

-'

-'    cREGMAN = Get_REGMAN_Record()

-'

-'    With ThisWorkbook.Worksheets(REGS_SHEET)

-'        .Range("IDX_REGION") = cREGMAN.Region

-'        .Range("IDX_CITY") = cREGMAN.City

-'    End With

-'

-'    With dlg_ui

-'        .cbRegion = cREGMAN.Region

-'        .cbCity = cREGMAN.City

-'        .tbFName = cREGMAN.FirstName

-'        .tbLName = cREGMAN.LastName

-'    End With

-'

-'    dlg_ui.Show

-'    Worksheets(REGS_SHEET).Calculate

-'

-'    If dlg_ui.Tag = vbOK Then

-'        With cREGMAN

-'            .Region = dlg_ui.cbRegion.Value

-'            .City = dlg_ui.cbCity.Value

-'            .FirstName = dlg_ui.tbFName.Value

-'            .LastName = dlg_ui.tbLName.Value

-'        End With

-'        Set_REGMAN_Record cREGMAN

-'    Else

-'        cmAbout

-'        With Application

-'            .DisplayAlerts = False

-'            .Quit

-'        End With

-'    End If

-End Sub

-

-Sub StoreHWInfo()

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim objHW() As Long

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    Set r = Range("HW_Number")

-    i = 1

-    For Each d In dc

-        If d.drivetype = 2 Then

-            r = d.SerialNumber

-            Set r = r.Offset(1, 0)

-            ReDim Preserve objHW(i)

-            objHW(i) = d.SerialNumber

-            i = i + 1

-        End If

-    Next

-    

-    UpdateHWRecords objHW

-End Sub

-

-Function CheckHWInfo()

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim objHW() As Long

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    

-    CheckHWInfo = False

-    

-    i = GetHWRecords(objHW)

-    If i = 0 And Range("HW_Number") <> 0 Then

-        Exit Function

-    End If

-    For Each d In dc

-        If d.drivetype = 2 Then

-            Set r = Range("HW_Number")

-            Do While r <> ""

-                If r = d.SerialNumber Then

-                    For i = 1 To UBound(objHW)

-                        If d.SerialNumber = objHW(i) Then

-                            CheckHWInfo = True

-                            Exit Function

-                        End If

-                    Next i

-                End If

-                Set r = r.Offset(1, 0)

-            Loop

-        End If

-    Next

-End Function

-<<<<<<
-======================
-dbBudget
->>>>>>
-Attribute VB_Name = "dbBudget"

-Option Explicit

-

-Public Type tBUDGET

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    rm_id As Long

-    bdgt_NMG As Long

-    bdgt_NFG As Long

-    sale_PLAN As Long

-End Type

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function GetAll_BDGT_RecordsByLPU_ID(ByRef allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_BDGT_RecordsByLPU_ID = dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection, allBDGT, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function Get_BDGT_Record(ByVal lpu_id As Long, ByVal ent_date As String, rm_id As Long) As tBUDGET

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    Get_BDGT_Record = dbGet_BDGT_Record(dbConnection, lpu_id, ent_date, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-' if objBDGT.ID <> 0 then updatre else insert

-Public Sub Insert_BDGT_Record(objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    If objBDGT.id <> 0 Then

-        dbUpdate_BDGT_Record dbConnection, objBDGT

-    Else

-        dbInsert_BDGT_Record dbConnection, objBDGT

-    End If

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Public Sub Delete_BDGT_Record(ByRef objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    dbDelete_BDGT_Record dbConnection, objBDGT

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_BDGT_Record(dbConnection As Object, ByVal lpu_id As Long, ent_date As String, rm_id As Long) As tBUDGET

-    

-    Dim sql As String

-    Dim objBDGT As tBUDGET

-    

-    With objBDGT

-        .id = 0

-        .lpu_id = lpu_id

-        .rm_id = rm_id

-        .entry_date = ent_date

-        .bdgt_NMG = 0

-        .bdgt_NFG = 0

-        .sale_PLAN = 0

-    End With

-        

-    

-    sql = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        With objBDGT

-            .entry_date = dbRecordset("entry_date")

-            .id = dbRecordset("id")

-            .lpu_id = dbRecordset("lpu_id")

-            .bdgt_NFG = dbRecordset("bdgt_NFG")

-            .bdgt_NMG = dbRecordset("bdgt_NMG")

-            .sale_PLAN = dbRecordset("sale_PLAN")

-        End With

-    End If

-    

-    dbGet_BDGT_Record = objBDGT

-End Function

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection As Object, allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_BDGT_SQL As String

-    Dim getAll_BDGT_SQL As String

-    Dim BDGT_Count As Long

-    BDGT_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_BDGT_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        BDGT_Count = dbRecordset("BDGT_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_BDGT_RecordsbyLPU_ID = BDGT_Count

-    

-    If BDGT_Count > 0 Then

-        'we have records

-        ReDim allBDGT(1 To BDGT_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_BDGT_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpBDGT As tBUDGET

-                 With tmpBDGT

-                    .entry_date = dbRecordset("entry_date")

-                    .id = dbRecordset("id")

-                    .lpu_id = dbRecordset("lpu_id")

-                    .bdgt_NFG = dbRecordset("bdgt_NFG")

-                    .bdgt_NMG = dbRecordset("bdgt_NMG")

-                    .sale_PLAN = dbRecordset("sale_PLAN")

-                 End With

-                 

-                 allBDGT(index) = tmpBDGT

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbInsert_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "lpu_budget", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    dbRecordset("entry_date") = objBDGT.entry_date

-    dbRecordset("lpu_id") = objBDGT.lpu_id

-    dbRecordset("bdgt_NMG") = objBDGT.bdgt_NMG

-    dbRecordset("bdgt_NFG") = objBDGT.bdgt_NFG

-    dbRecordset("sale_PLAN") = objBDGT.sale_PLAN

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objBDGT.id = dbRecordset("id")

-  

-End Sub

-

-Public Sub dbUpdate_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu_budget SET " & _

-    "entry_date='" & objBDGT.entry_date & "'," & _

-    "lpu_id=" & objBDGT.lpu_id & "," & _

-    "bdgt_NMG=" & objBDGT.bdgt_NMG & "," & _

-    "bdgt_NFG=" & objBDGT.bdgt_NFG & "," & _

-    "sale_PLAN=" & objBDGT.sale_PLAN & _

-    " WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-Public Sub dbDelete_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_BDGT_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbDatabase
->>>>>>
-Attribute VB_Name = "dbDatabase"

-Option Explicit

-

-

-Sub dbOpenConnection(dbConnection As Object)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-<<<<<<
-======================
-dbLPU
->>>>>>
-Attribute VB_Name = "dbLPU"

-Option Explicit

-

-Public Type tLPU

-    id As Long

-    rep_id As Long

-    rm_id As Long

-    Name As String

-    address As String

-    beds As Integer

-End Type

-

-Function Get_LPU_Record(ByVal lpu_id As Long, rm_id As Long) As tLPU

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_LPU_Record = dbGet_LPU_Record(dbConnection, lpu_id, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_LPU_byQTR(allLPU() As tLPU, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_LPU_byQTR = dbGetAll_LPU_byQTR(dbConnection, allLPU, ent_date, rep_id, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_Record(dbConnection As Object, ByVal lpu_id As Long, rm_id As Long) As tLPU

-    

-    Dim sql As String

-    Dim objLPU As tLPU

-    

-    objLPU.id = lpu_id

-    objLPU.Name = ""

-    objLPU.address = ""

-    

-    sql = "SELECT * FROM lpu WHERE id=" & lpu_id & " AND rm_id=" & rm_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objLPU.Name = dbRecordset("name")

-        objLPU.address = dbRecordset("address")

-        objLPU.rep_id = dbRecordset("rep_id")

-        objLPU.rm_id = dbRecordset("rm_id")

-        objLPU.beds = dbRecordset("beds")

-    End If

-    

-    dbGet_LPU_Record = objLPU

-

-End Function

-

-Function dbGetAll_LPU_byQTR(dbConnection As Object, allLPU() As tLPU, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    Dim Where As String

-    Where = "WHERE lpu_budget.entry_date like '" & ent_date & "'" & " AND lpu.id=lpu_budget.lpu_id " & _

-    "AND lpu.rep_id=" & rep_id & " AND lpu.rm_id=lpu_budget.rm_id AND lpu.rm_id=" & rm_id

-

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu_budget, lpu " & Where

-    

-    getAll_LPU_SQL = "SELECT lpu.id as id, lpu.rep_id as rep_id, lpu.name as name, lpu.address as address, lpu.beds AS beds, lpu.rm_id AS rm_id " & _

-    "FROM lpu, lpu_budget " & Where

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_LPU_byQTR = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .Name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-dbREP
->>>>>>
-Attribute VB_Name = "dbREP"

-'Option Explicit

-'

-'Public Type tREP

-'    FirstName As String

-'    LastName As String

-'    Region As Integer

-'    City As Integer

-'End Type

-'

-'Function GetREPRecord() As tREP

-'    Dim dbConnection As Object

-'

-'    dbOpenConnection dbConnection

-'    GetREPRecord = dbGetREPRecord(dbConnection)

-'    dbCloseConnection dbConnection

-'End Function

-'

-'Sub SetREPRecord(cUser As tREP)

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbSetREPRecord dbConnection, cUser

-'    dbCloseConnection dbConnection

-'End Sub

-'

-'Public Function dbGetREPRecord(dbConnection As Object) As tREP

-'

-'    Dim SQL As String

-'    Dim objREP As tREP

-'

-'    objREP.FirstName = ""

-'    objREP.LastName = ""

-'    objREP.Region = 0

-'    objREP.City = 0

-'    SQL = "SELECT firstname, lastname, region, city FROM " & _

-'          "rep"

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open SQL, dbConnection

-'    ', 3, 3

-'    If Not dbRecordset.BOF Then

-'

-'        objREP.FirstName = dbRecordset("firstname")

-'        objREP.LastName = dbRecordset("lastname")

-'        objREP.Region = dbRecordset("region")

-'        objREP.City = dbRecordset("city")

-'

-'    End If

-'

-'    dbGetREPRecord = objREP

-'

-'End Function

-'

-'Public Sub dbSetREPRecord(dbConnection As Object, ByRef objREP As tREP)

-'

-'    Dim DeleteSQL As String

-'    Dim InsertSQL As String

-'

-'    DeleteSQL = "DELETE FROM rep"

-'    InsertSQL = "INSERT INTO rep (firstname, lastname, region, city) VALUES (" & _

-'    "'" & objREP.FirstName & "', " & _

-'    "'" & objREP.LastName & "', " & _

-'    objREP.Region & ", " & _

-'    objREP.City & ")"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-'

-'End Sub

-'

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    CheckWorkBooksArround Wb

-End Sub

-

-

-Sub CheckWorkBooksArround(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If app.Workbooks.count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEL сейчас будут закрыты!", vbOKOnly, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub GetState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-        ActiveWorkbook.DisplayDrawingObjects = xlDisplayShapes

-        

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.Name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars(STDBAR_NAME).Visible = False

-End Sub

-

-

-Public Sub RestoreState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars(STDBAR_NAME).Visible = True

-End Sub

-

-

-

-<<<<<<
-======================
-cdbRM
->>>>>>
-Attribute VB_Name = "cdbRM"

-Option Explicit

-

-Public Type tRMID_COMMON

-    rm As tREGMAN

-    rgcd_count As Integer

-    rgcd() As tREGION

-End Type

-

-Function Get_RM_CommonList_by_QTR(ByRef rmcd() As tRMID_COMMON, ent_date As String) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_RM_CommonList_by_QTR = dbGet_RM_CommonList_by_QTR(dbConnection, rmcd(), ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_RM_CommonList_by_QTR(dbConnection As Object, ByRef rmcd() As tRMID_COMMON, ent_date As String) As Integer

-    ' Получить список RM-ов

-    Dim count As Integer

-    count = db_get_All_RM_by_QTR(dbConnection, rmcd(), ent_date)

-    

-    Dim i As Integer

-    For i = 1 To count

-        rmcd(i).rgcd_count = 1

-        ReDim rmcd(i).rgcd(1 To 1)

-        getREGION_by_QTR ent_date, rmcd(i).rgcd(1), rmcd(i).rm.rm_id

-    Next i

-    dbGet_RM_CommonList_by_QTR = count

-End Function

-

-Function db_get_All_RM_by_QTR(dbConnection As Object, rmcd() As tRMID_COMMON, ent_date As String) As Integer

-    

-    Dim count_sql As String

-    Dim get_sql As String

-    Dim rs As Object

-    Dim RM_Count As Integer

-        

-    count_sql = "SELECT COUNT(*) AS RM_TOTAL FROM reg_man"

-    get_sql = "SELECT * FROM reg_man"

-    Set rs = CreateObject("ADODB.Recordset")

-    rs.Open count_sql, dbConnection

-    

-    If Not rs.BOF Then

-        RM_Count = rs("RM_TOTAL")

-    End If

-    

-    rs.Close

-    

-     db_get_All_RM_by_QTR = RM_Count

-    

-    If RM_Count > 0 Then

-        'we have records

-        ReDim rmcd(1 To RM_Count)

-        Dim index As Long

-        index = 1

-        rs.Open get_sql, dbConnection

-        

-        If Not rs.BOF Then

-             Do While Not rs.EOF

-                 Dim tmp_rmcd As tRMID_COMMON

-                 With tmp_rmcd

-                    .rgcd_count = 0

-                    .rm.City = rs("city")

-                    .rm.FirstName = rs("firstname")

-                    .rm.LastName = rs("lastname")

-                    .rm.rm_id = rs("mgr_id")

-                    .rm.Region = rs("region")

-                 End With

-                 

-                 rmcd(index) = tmp_rmcd

-                 index = index + 1

-                 rs.MoveNext

-             Loop

-        End If

-    End If

-    

-End Function

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Public Const STDBAR_NAME = "Worksheet Menu Bar"

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Import data"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmDataImport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-             With .Add(msoControlPopup)

-                .Caption = "&Report"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&New Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 18

-                        .OnAction = "cmNewReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Open Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmOpenReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Close && Save"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseReport"

-                    End With

-                End With

-            End With

-           With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Exit && Restore Excel"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 548

-                        .OnAction = "cmExitRestore"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-        End With

-    End With

-End Sub

-

-Sub CreateExtCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom extendet commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Import data"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmDataImport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-             With .Add(msoControlPopup)

-                .Caption = "&Report"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&New Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 18

-                        .OnAction = "cmNewReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Open Report"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 23

-                        .OnAction = "cmOpenReport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Close && Save"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 3

-                        .OnAction = "cmCloseReport"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Add New Slide"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 280

-                .OnAction = "cmAddSlide"

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(flag As Boolean)

-    If flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars(STDBAR_NAME)

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmExport()

-    dbExport

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    Dim dlg As dlgAbout

-    Set dlg = New dlgAbout

-    

-    dlg.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlg.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlg.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlg.Show

-End Sub

-

-Sub cmMail2Support()

-    Dim err_description As String

-    Dim dlg_msg As dlg_Mail

-    Set dlg_msg = New dlg_Mail

-    With dlg_msg

-        .Show

-        If .Tag = vbOK Then

-            ThisWorkbook.Worksheets(VAR_SHEET).Range("ERR_MESSAGE") _

-                = .tbMessage.Text

-            ThisWorkbook.Save

-            ThisWorkbook.SendMail Recipients:="infra@i-rs.ru", Subject:=PROGRAM_NAME & " ver.:" & PROGRAM_VERSION

-            MsgBox "Сообщение об ошибке отправлено. Перезагрузите программу.", vbOKOnly, PROGRAM_NAME

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-    End With

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-'        helppath = "hh.exe " & .Path & "\Telfast.chm"

-'        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub set_work_mode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-End Sub

-

-Sub cmSetStandaloneMode()

-    set_work_mode

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    Dim dlg As dlgGetPwd

-    rp = common_pwd

-    

-    Set dlg = New dlgGetPwd

-    dlg.edPwd = ""

-    dlg.Show

-    

-    If dlg.edPwd = rp Then

-        Application.ScreenUpdating = False

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-        xlRestoreView

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-        Application.ScreenUpdating = True

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmNewReport()

-    ppReport.CreateReport

-    MsgBox "Новый отчет создан", vbInformation + vbOKOnly, PROGRAM_NAME

-    CreateExtCommandBar theApp:=ThisWorkbook.Application

-End Sub

-

-Sub cmOpenReport()

-    Dim fileToOpen

-    Dim s As String

-    fileToOpen = Application _

-        .GetOpenFileName("Report Files (*.ppt), *.ppt", title:="Report OPen", MultiSelect:=False)

-    If fileToOpen <> False Then

-        s = fileToOpen

-        ppReport.OpenReport s

-        CreateExtCommandBar theApp:=ThisWorkbook.Application

-    End If

-End Sub

-

-Sub cmCloseReport()

-    On Error Resume Next

-    ppReport.SaveReport

-    CreateCommandBar theApp:=ThisWorkbook.Application

-End Sub

-

-Sub cmAddSlide()

-    ThisWorkbook.ActiveSheet.PrintCopy

-    ppReport.InsertSlide

-End Sub

-

-Sub cmHomePage()

-    ThisWorkbook.Worksheets("PRJ_QTR").Select

-End Sub

-

-Sub cmExitRestore()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = True

-    Application.Quit

-End Sub

-

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    Dim dlg_prn As dlgPrint

-    

-    Set dlg_prn = New dlgPrint

-    

-    With dlg_prn

-        .cbMainReport = True

-        .cbMainBudget = False

-        .cbSrcData = False

-        .cbAllSheets = False

-    

-        .Show

-    

-        If .Tag = vbCancel Then

-            Exit Sub

-        End If

-    End With

-    

-    Dim PrnIdx As Integer

-    

-    With dlg_prn

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("REP_QTR", "budget", "Final")

-    Case 1111

-        plist = Array("REP_QTR", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("REP_QTR")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Clexane bar"

-Public Const common_pwd As String = "crdjhxtyjr"

-

-

-Sub SetEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    With Application

-        .Caption = PROGRAM_NAME

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .GetState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = False

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Unprotect

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    If cWindow.Type = xlWorkbook Then

-                        cWindow.DisplayHeadings = True

-                    End If

-                Next

-            End If

-        Next

-        If DesignMode Then

-            SetupDesignMenu True

-        End If

-        With mobjAppState

-            .RestoreState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Option Explicit

-

-Sub UpdateHWRecords(objHW() As Long)

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    dbUpdateHWRecords dbConnection, objHW

-    dbCloseConnection dbConnection

-End Sub

-

-Function GetHWRecords(objHW() As Long) As Integer

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    GetHWRecords = dbGetHWRecords(dbConnection, objHW)

-    dbCloseConnection dbConnection

-End Function

-

-Sub HWReset()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbInsertHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    

-    Dim dbRecordset As Object

-    Dim i As Long

-    

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "hw", dbConnection, 2, 2

-    

-    For i = 1 To UBound(objHW)

-        dbRecordset.addnew

-        dbRecordset("num") = objHW(i)

-        dbRecordset.Update

-    Next i

-    

-End Sub

-

-Sub dbUpdateHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    dbDeleteHWRecord dbConnection

-    dbInsertHWRecords dbConnection, objHW

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-dbHir
->>>>>>
-Attribute VB_Name = "dbHir"

-Option Explicit

-

-Public Type tHIRURGIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    operations_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_ambulator_clexan_40mg As Integer

-    patients_ambulator_clexan_20mg As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-    patients_stationar_clexan_40mg As Integer

-    patients_stationar_clexan_20mg As Integer

-End Type

-

-' if objHir.ID <> 0 then updatre else insert

-Sub Insert_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objHir.id <> 0 Then

-        dbUpdate_Hir_Record dbConnection, objHir

-    Else

-        dbInsert_Hir_Record dbConnection, objHir

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Hir_RecordsByLPU_ID(ByRef allHir() As tHIRURGIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Hir_RecordsByLPU_ID = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, allHir, lpu_id, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Hir_Record dbConnection, objHir

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objHir.ID <> 0 then updatre else insert

-

-Sub dbInsert_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_hir", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objHir

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("operations_per_quarter") = .operations_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_ambulator_clexan_20mg") = .patients_ambulator_clexan_20mg

-        dbRecordset("patients_ambulator_clexan_40mg") = .patients_ambulator_clexan_40mg

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-        dbRecordset("patients_stationar_clexan_20mg") = .patients_stationar_clexan_20mg

-        dbRecordset("patients_stationar_clexan_40mg") = .patients_stationar_clexan_40mg

-        

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objHir.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim UpdateSQL As String

-    

-    With objHir

-        UpdateSQL = "UPDATE lpu_hir SET " & _

-            "entry_date='" & objHir.entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "operations_per_quarter=" & .operations_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_ambulator_clexan_20mg=" & .patients_ambulator_clexan_20mg & "," & _

-            "patients_ambulator_clexan_40mg=" & .patients_ambulator_clexan_40mg & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & "," & _

-            "patients_stationar_clexan_20mg=" & .patients_stationar_clexan_20mg & "," & _

-            "patients_stationar_clexan_40mg=" & .patients_stationar_clexan_40mg & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_Hir_RecordsbyLPU_ID(dbConnection As Object, allHir() As tHIRURGIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_Hir_SQL As String

-    Dim getAll_Hir_SQL As String

-    Dim Hir_Count As Long

-    Hir_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    Else

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Hir_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Hir_Count = dbRecordset("HIR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Hir_RecordsbyLPU_ID = Hir_Count

-    

-    If Hir_Count > 0 Then

-        'we have records

-        ReDim allHir(1 To Hir_Count)

-        Dim index As Integer

-        index = 1

-        dbRecordset.Open getAll_Hir_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpHir As tHIRURGIA

-                 With tmpHir

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .operations_per_quarter = dbRecordset("operations_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_ambulator_clexan_20mg = dbRecordset("patients_ambulator_clexan_20mg")

-                    .patients_ambulator_clexan_40mg = dbRecordset("patients_ambulator_clexan_40mg")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                    .patients_stationar_clexan_20mg = dbRecordset("patients_stationar_clexan_20mg")

-                    .patients_stationar_clexan_40mg = dbRecordset("patients_stationar_clexan_40mg")

-                 End With

-                 

-                 allHir(index) = tmpHir

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE ID=" & objHir.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Hir_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbTer
->>>>>>
-Attribute VB_Name = "dbTer"

-Option Explicit

-

-Public Type tTERAPIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objTer.ID <> 0 then updatre else insert

-Sub Insert_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objTer.id <> 0 Then

-        dbUpdate_Ter_Record dbConnection, objTer

-    Else

-        dbInsert_Ter_Record dbConnection, objTer

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Ter_RecordsByLPU_ID(ByRef allTer() As tTERAPIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Ter_RecordsByLPU_ID = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, allTer, lpu_id, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Ter_Record dbConnection, objTer

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objTer.ID <> 0 then updatre else insert

-

-Sub dbInsert_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_ter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objTer

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objTer.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim Update_SQL As String

-    

-    With objTer

-        Update_SQL = "UPDATE lpu_ter SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_Ter_RecordsbyLPU_ID(dbConnection As Object, allTer() As tTERAPIA, lpu_id As Long, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_Ter_SQL As String

-    Dim getAll_Ter_SQL As String

-    Dim Ter_Count As Long

-    Ter_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    Else

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "' AND rm_id=" & rm_id

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Ter_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Ter_Count = dbRecordset("TER_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Ter_RecordsbyLPU_ID = Ter_Count

-    

-    If Ter_Count > 0 Then

-        'we have records

-        ReDim allTer(1 To Ter_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_Ter_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpTer As tTERAPIA

-                 With tmpTer

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 allTer(index) = tmpTer

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE ID=" & objTer.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Ter_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-mLPU_LIST
->>>>>>
-Attribute VB_Name = "mLPU_LIST"

-Option Explicit

-

-Public Const CINP_AREA As String = "B12"

-Public Const CLPU_NAME As Integer = 0

-Public Const CLPU_NAME1 As Integer = 1

-Public Const CLPU_NAME2 As Integer = 2

-Public Const CLPU_ID As Integer = 3

-Public Const CLPU_BEDS As Integer = 4

-Public Const CLPU_NFG As Integer = 5

-Public Const CLPU_NMG As Integer = 6

-Public Const CLPU_HIR As Integer = 7

-Public Const CLPU_TER As Integer = 8

-Public Const CLPU_CAR As Integer = 9

-Public Const CLPU_FACT As Integer = 10

-Public Const CLPU_PLAN As Integer = 11

-Public Const CLPU_PAT_LPU As Integer = 16

-Public Const CLPU_BDGT As Integer = 17

-Public Const CLPU_PAT_ALL As Integer = 16

-

-Sub EditLPU(cLPU As tLPU, ent_date As String)

-    NoFunc

-End Sub

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("LPU_LIST")

-        s = .Range("C4") & " " & .Range("C3") & ", " & .Range("G4") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_LPU_BBL").Range("title") = MakeChartTitle

-End Sub

-

-Sub Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PIE").Range("title") = MakeChartTitle

-End Sub

-

-Sub Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU_A").Range("title") = MakeChartTitle

-End Sub

-

-Sub btLPU_DEL_IT()

-'    Dim cLPU As tLPU

-'    Dim ent_date As String

-'    Dim delete_all As Integer

-'    Dim dlg_del As dlg_LPU_delete

-'

-'    With Worksheets("LPU_LIST")

-'        ent_date = .Range("ent_date")

-'        cLPU.id = .getCurrentLPU_ID()

-'    End With

-'

-'    If cLPU.id = 0 Then

-'        MsgBox "Укажите удаляемый объект", vbOKOnly, PROGRAM_NAME

-'        Exit Sub

-'    End If

-'    cLPU = Get_LPU_Record(cLPU.id)

-'

-'    Set dlg_del = New dlg_LPU_delete

-'    With dlg_del

-'        .chbDeleteQTR.Value = True

-'        .chbDeleteAll.Value = False

-'        .lComment = ent_date & ": Удаление ЛПУ '" _

-'        & cLPU.Name & "', расположенного по адресу:" _

-'        & cLPU.address & " не разрешено."

-'        .Show

-'    End With

-End Sub

-

-Sub btLPU_RET_IT()

-    With Worksheets("LPU_LIST")

-        .setEnt_date ("")

-        .Range("LAST_FOCUS") = ""

-        

-        Wks_select .Range("ret_addr")

-    End With

-

-End Sub

-

-

-Sub btLPU_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim lpu_id As Long

-

-    i = Worksheets(VAR_SHEET).Range("QTR_ACTION").Value

-    With Worksheets("LPU_LIST")

-        ent_date = .getEnt_date()

-

-

-        lpu_id = .getCurrentLPU_ID

-        If lpu_id = 0 And i <> 6 Then

-            i = 1

-        End If

-        Select Case i

-            Case 1

-                .SelectLPU_NAME lpu_id, ent_date

-                .Range("JUMP") = "LPU_BDGT"

-            Case 2

-                .SelectLPU_BDGT lpu_id, ent_date

-                .Range("JUMP") = "LPU_BDGT"

-            Case 3

-                .SelectLPU_HIR lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_HIR"

-

-            Case 4

-                .SelectLPU_TER lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_TER"

-

-            Case 5

-                .SelectLPU_C_ACS lpu_id, ent_date

-                .Range("JUMP") = "LPU_CLSN_C_ACS"

-

-        End Select

-    End With

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-dbQTR
->>>>>>
-Attribute VB_Name = "dbQTR"

-Option Explicit

-

-Public Type tQTR

-    id As Long

-    entry_date As String

-    rep_id As Long

-    rm_id As Long

-    sale_PLAN As Long

-    ClxnH20mg As Long

-    ClxnH40mg As Long

-    ClxnT40mg As Long

-    ClxnC_IM As Long

-    ClxnC_ACS As Long

-End Type

-

-Function Get_QTR_Record(ByVal QTR_ID As Long, rm_id As Long) As tQTR

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_QTR_Record = dbGet_QTR_Record(dbConnection, QTR_ID, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_Record(dbConnection As Object, ByVal QTR_ID As Long, rm_id As Long) As tQTR

-    

-    Dim sql As String

-    Dim objQTR As tQTR

-    

-    With objQTR

-        .ClxnC_ACS = 0

-        .ClxnC_IM = 0

-        .ClxnH20mg = 0

-        .ClxnH40mg = 0

-        .ClxnT40mg = 0

-        .entry_date = ""

-        .id = QTR_ID

-        .rm_id = rm_id

-    End With

-    

-    sql = "SELECT * FROM quarter WHERE id=" & QTR_ID & " AND rm_id=" & rm_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objQTR.entry_date = dbRecordset("entry_date")

-        objQTR.rep_id = dbRecordset("rep_id")

-        objQTR.rm_id = dbRecordset("rm_id")

-        objQTR.sale_PLAN = dbRecordset("sale_plan")

-        objQTR.ClxnH20mg = dbRecordset("ClxnH20mg")

-        objQTR.ClxnH40mg = dbRecordset("ClxnH40mg")

-        objQTR.ClxnT40mg = dbRecordset("ClxnT40mg")

-        objQTR.ClxnC_IM = dbRecordset("ClxnC_IM")

-        objQTR.ClxnC_ACS = dbRecordset("ClxnC_ACS")

-        objQTR.id = dbRecordset("id")

-    End If

-    

-    dbGet_QTR_Record = objQTR

-

-End Function

-

-

-Function Get_QTR_Record_by_REP(ent_date As String, rep_id As Long, rm_id As Long) As tQTR

-    Dim dbConnection As Object

-    Dim allQTR() As tQTR

-    Dim i As Long

-

-    dbOpenConnection dbConnection

-

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id, rm_id)

-    If i <> 0 Then

-        Get_QTR_Record_by_REP = allQTR(1)

-    End If

-

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTR_Records_by_REP(ByRef all_QTR() As tQTR, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-

-    GetAll_QTR_Records_by_REP = dbGetAll_QTR_Records_By_REP(dbConnection, all_QTR, ent_date, rep_id, rm_id)

-

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGetAll_QTR_Records_By_REP(dbConnection As Object, all_QTR() As tQTR, ent_date As String, rep_id As Long, rm_id As Long) As Integer

-

-    Dim getCount_QTR_SQL As String

-    Dim getAll_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    Dim rep_sql As String

-    Dim rm_sql As String

-    

-    rep_sql = ""

-    rm_sql = ""

-    

-    If rep_id <> 0 Then

-        rep_sql = " AND rep_id=" & rep_id

-    End If

-    

-    If rm_id <> 0 Then

-        rm_sql = " AND rm_id=" & rm_id

-    End If

-    

-    

-        getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter " & _

-        "WHERE entry_date like '" & ent_date & "' " & rep_sql & rm_sql

-        getAll_QTR_SQL = "SELECT * FROM quarter " & _

-        "WHERE entry_date like '" & ent_date & "' " & rep_sql & rm_sql & " ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-

-    dbRecordset.Close

-

-    dbGetAll_QTR_Records_By_REP = QTR_Count

-

-    If QTR_Count > 0 Then

-        'we have records

-        ReDim all_QTR(1 To QTR_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTR_SQL, dbConnection

-

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTR As tQTR

-                 With tmp_QTR

-                    .entry_date = dbRecordset("entry_date")

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .ClxnH20mg = dbRecordset("ClxnH20mg")

-                    .ClxnH40mg = dbRecordset("ClxnH40mg")

-                    .ClxnT40mg = dbRecordset("ClxnT40mg")

-                    .ClxnC_IM = dbRecordset("ClxnC_IM")

-                    .ClxnC_ACS = dbRecordset("ClxnC_ACS")

-                    .id = dbRecordset("id")

-                 End With

-

-                 all_QTR(index) = tmp_QTR

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-cdbQTR
->>>>>>
-Attribute VB_Name = "cdbQTR"

-Option Explicit

-

-Public Type tQTR_COMMON

-    qtr As tQTR

-    i_lcd As Long           ' число ЛПУ в СПИСКЕ

-    lcd() As tLPU_COMMON    ' список ЛПУ

-    c_beds As Long          ' сумма коек

-    c_bdgt_NFG As Long      ' общий бюджет на НФГ

-    c_bdgt_NMG As Long      ' общий бюджет на НМГ

-    c_bdgt_LPU As Long      ' общий бюджет на гепарины

-    c_sale_PLAN As Long     ' план продаж репа

-    c_sale_ALL As Long      ' продажи

-    c_sale_HIR As Long      ' в хирургии

-    c_sale_TER  As Long     ' в терапии

-    c_sale_CRD  As Long     ' в кардиологии

-    c_pat_HIR   As Long     ' пациенты

-    c_pat_TER   As Long     '

-    c_pat_CRD   As Long     '

-    c_pat_ALL   As Long     '

-    c_pat_LPU   As Long     ' Всего операций

-End Type

-

-Function Get_QTR_CommonList_by_REP(ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long, rm_id As Long) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_QTR_CommonList_by_REP = dbGet_QTR_CommonList_by_REP(dbConnection, qcd, ent_date, rep_id, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_CommonList_by_REP(dbConnection As Object, ByRef qcd() As tQTR_COMMON, ent_date As String, rep_id As Long, rm_id As Long) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim allQTR() As tQTR

-    i = dbGetAll_QTR_Records_By_REP(dbConnection, allQTR, ent_date, rep_id, rm_id)

-    dbGet_QTR_CommonList_by_REP = i

-    If i > 0 Then

-        ReDim qcd(i)

-        For i = 1 To UBound(allQTR)

-            With qcd(i)

-                .qtr = allQTR(i)

-                .c_beds = 0

-                .c_bdgt_NFG = 0

-                .c_bdgt_NMG = 0

-                .c_bdgt_LPU = 0

-                .c_sale_PLAN = 0

-                .c_pat_HIR = 0

-                .c_pat_TER = 0

-                .c_pat_CRD = 0

-                .c_pat_ALL = 0

-                .c_sale_HIR = 0

-                .c_sale_TER = 0

-                .c_sale_CRD = 0

-                .c_sale_ALL = 0

-                .c_pat_LPU = 0

-                

-                j = dbGet_LPU_CommonQTR(dbConnection, .lcd, .qtr)

-                .i_lcd = j

-                If j > 0 Then

-                    For j = 1 To UBound(.lcd)

-                        .c_beds = .c_beds + .lcd(j).lpu.beds

-                        .c_bdgt_NFG = .c_bdgt_NFG + .lcd(j).bdgt.bdgt_NFG

-                        .c_bdgt_NMG = .c_bdgt_NMG + .lcd(j).bdgt.bdgt_NMG

-                        .c_bdgt_LPU = .c_bdgt_LPU + .lcd(j).bdgt_LPU

-                        .c_sale_PLAN = .c_sale_PLAN + .lcd(j).bdgt.sale_PLAN

-                        .c_pat_HIR = .c_pat_HIR + .lcd(j).pat_HIR

-                        .c_pat_TER = .c_pat_TER + .lcd(j).pat_TER

-                        .c_pat_CRD = .c_pat_CRD + .lcd(j).pat_CRD

-                        .c_pat_ALL = .c_pat_ALL + .lcd(j).pat_ALL

-                        .c_sale_HIR = .c_sale_HIR + .lcd(j).sale_HIR

-                        .c_sale_TER = .c_sale_TER + .lcd(j).sale_TER

-                        .c_sale_CRD = .c_sale_CRD + .lcd(j).sale_CRD

-                        .c_sale_ALL = .c_sale_ALL + .lcd(j).sale_ALL

-                        .c_pat_LPU = .c_pat_LPU + .lcd(j).pat_LPU

-                    Next j

-                    

-                End If

-            End With

-        Next i

-    End If

-End Function

-

-Function GetLastQtr() As String

-    Dim s As String

-    Dim r As Range

-    Set r = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Do While r.Cells(1, 1) <> ""

-        s = r.Cells(1, 1)

-        Set r = r.Cells.Offset(1, 0)

-    Loop

-    GetLastQtr = s

-End Function

-

-Function GetNextQTR(ent_date As String) As String

-    Dim rd As Range

-    Dim idx As Integer

-    Dim b As Variant

-    Dim dlg As dlg_newQTR

-    Set dlg = New dlg_newQTR

-    

-    If ent_date = "" Then

-        Dim ir As Variant

-        idx = 0

-        dlg.Show

-        b = dlg.Tag

-            

-        If IsNumeric(b) Then

-            GetNextQTR = dlg.cbQTR

-        Else

-            GetNextQTR = ""

-        End If

-    Else

-        Set rd = Worksheets(VAR_SHEET).Range("Date_Lst")

-        idx = WorksheetFunction.Match(ent_date, rd, 0)

-        GetNextQTR = WorksheetFunction.index(rd, idx + 1, 1)

-    End If

-End Function

-<<<<<<
-======================
-mRestView
->>>>>>
-Attribute VB_Name = "mRestView"

-Option Explicit

-

-Sub xlRestoreView()

-Attribute xlRestoreView.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute xlRestoreView.VB_ProcData.VB_Invoke_Func = " \n14"

-    With Application

-        .CommandBars("Standard").Visible = True

-        .CommandBars("Formatting").Visible = True

-        .DisplayFormulaBar = True

-        .DisplayStatusBar = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = True

-    End With

-End Sub

-<<<<<<
-======================
-dlg_newQTR
->>>>>>
-Attribute VB_Name = "dlg_newQTR"

-Attribute VB_Base = "0{92648543-CB84-4B6B-BEB3-539AE7EF9D84}{7E20E3E3-027A-483B-A14D-AA9EA5398ACC}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mDec2TS
->>>>>>
-Attribute VB_Name = "mDec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-CHRT_LPU_BBL
->>>>>>
-Attribute VB_Name = "CHRT_LPU_BBL"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    Unprotect

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Потенциал рынка: " & Range("title")

-    Range("view_key") = False

-    ChangeLabels

-    Range("A1").Select

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Unprotect

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub BCLabelChng_Click()

-    Unprotect

-    If Range("view_key") Then

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать названия"

-    Else

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать объемы"

-    End If

-    Range("view_key") = Not Range("view_key")

-    ChangeLabels

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub ChangeLabels()

-    Dim i As Integer

-    Dim offset_text As Integer

-    Dim src As Range

-    Set src = Range("CHRT_BBL_DATA")

-    

-    offset_text = 3

-    If Range("view_key") Then

-        offset_text = 4

-    End If

-    

-    With ChartObjects(1).Chart

-        With .SeriesCollection(1)

-            For i = 1 To .Points.count

-                On Error GoTo ExitLabel

-                .Points(i).DataLabel.Characters.Text = Format(src.Cells(i, offset_text))

-            Next i

-        End With

-    End With

-ExitLabel:

-End Sub

-<<<<<<
-======================
-CHRT_PAT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PAT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Пациенты на Клексане(чел.): " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-<<<<<<
-======================
-CHRT_PAT_LPU
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Пациенты на Клексане(%): " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_nextQTR
->>>>>>
-Attribute VB_Name = "dlg_nextQTR"

-Attribute VB_Base = "0{067FED69-B41E-427D-AF59-5798B8E2E73A}{4C13CAB1-FDCC-4708-89EB-E92EDC125712}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-cdbLPU
->>>>>>
-Attribute VB_Name = "cdbLPU"

-Option Explicit

-

-Public Type tLPU_COMMON

-    lpu As tLPU

-    bdgt As tBUDGET

-    i_hir As Long

-    hir() As tHIRURGIA

-    i_ter As Long

-    ter() As tTERAPIA

-    i_ACS As Long

-    ACS() As tACS

-    bdgt_LPU As Long

-    sale_HIR As Long

-    sale_TER As Long

-    sale_CRD As Long

-    sale_ALL As Long

-    pat_HIR As Long

-    pat_TER As Long

-    pat_CRD As Long

-    pat_ALL As Long     ' Сумма всех пациентов на клексане

-    pat_LPU As Long     ' Число потенциальных пациентов для продаж клексана

-End Type

-

-Function Get_LPU_CommonQTR(ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    Get_LPU_CommonQTR = dbGet_LPU_CommonQTR(dbConnection, lcd, objQTR)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_CommonQTR(dbConnection As Object, ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    i = dbGetAll_LPU_byQTR(dbConnection, allLPU, objQTR.entry_date, objQTR.rep_id, objQTR.rm_id)

-    dbGet_LPU_CommonQTR = i

-    If i > 0 Then

-        ReDim lcd(i)

-        For i = 1 To UBound(allLPU)

-            dbGet_LPU_Common dbConnection, lcd(i), allLPU(i), objQTR

-        Next i

-    End If

-End Function

-

-Sub Get_LPU_Common(ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    dbGet_LPU_Common dbConnection, lcd, cLPU, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbGet_LPU_Common(dbConnection As Object, ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-

-    lcd.lpu = cLPU

-    lcd.bdgt = dbGet_BDGT_Record(dbConnection, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    lcd.i_hir = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, lcd.hir, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    lcd.i_ter = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, lcd.ter, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    lcd.i_ACS = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, lcd.ACS, cLPU.id, objQTR.entry_date, objQTR.rm_id)

-    With lcd

-        .bdgt_LPU = .bdgt.bdgt_NFG + .bdgt.bdgt_NMG

-        .pat_LPU = 0

-        If .i_hir > 0 Then

-            .pat_HIR = .hir(1).patients_ambulator_clexan + .hir(1).patients_stationar_clexan

-            .sale_HIR = objQTR.ClxnH20mg * (.hir(1).patients_ambulator_clexan_20mg + .hir(1).patients_stationar_clexan_20mg)

-            .sale_HIR = .sale_HIR + objQTR.ClxnH40mg * (.hir(1).patients_ambulator_clexan_40mg + .hir(1).patients_stationar_clexan_40mg)

-            .pat_LPU = .pat_LPU + .hir(1).operations_per_quarter

-        End If

-        If .i_ter > 0 Then

-            .pat_TER = .ter(1).patients_ambulator_clexan + .ter(1).patients_stationar_clexan

-            .sale_TER = .pat_TER * objQTR.ClxnT40mg

-            .pat_LPU = .pat_LPU + .ter(1).patients_per_quarter

-        End If

-        If .i_ACS > 0 Then

-            .pat_CRD = .ACS(1).patients_stationar_clexan

-            .sale_CRD = .pat_CRD * objQTR.ClxnC_ACS

-            .pat_LPU = .pat_LPU + .ACS(1).patients_per_quarter

-        End If

-        .pat_ALL = .pat_HIR + .pat_TER + .pat_CRD

-        .sale_ALL = .sale_HIR + .sale_TER + .sale_CRD

-    End With

-End Sub

-

-<<<<<<
-======================
-CHRT_PIE
->>>>>>
-Attribute VB_Name = "CHRT_PIE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-    Unprotect

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Доля продаж: " & Range("title")

-    

-    On Error Resume Next

-    Range("P5:Q24").Sort _

-        Key1:=Range("Q5"), _

-        Order1:=xlDescending, _

-        Header:=xlGuess, _

-        OrderCustom:=1, _

-        MatchCase:=False, _

-        Orientation:=xlTopToBottom

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PLN_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PLN_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Динамика продаж: " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_BDGT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_BDGT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Бюджеты ЛПУ: " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-<<<<<<
-======================
-dlg_LPU_delete
->>>>>>
-Attribute VB_Name = "dlg_LPU_delete"

-Attribute VB_Base = "0{9C81F4D2-4ECF-46F5-999B-9801D572A12F}{B382508B-7F3D-4747-8407-0F75F6F265F5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlg_Mail
->>>>>>
-Attribute VB_Name = "dlg_Mail"

-Attribute VB_Base = "0{EA8CE4CE-AC2E-45BC-BAF8-1429E6242097}{575F0762-04F4-4F86-B98A-8E87E3424B0D}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dbREP_id
->>>>>>
-Attribute VB_Name = "dbREP_id"

-Public Type tREPID

-    rep_id As Long

-    rm_id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function GetAll_REPID_Records_by_QTR(ByRef all_REPID() As tREPID, ent_date As String, rm_id As Long) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAll_REPID_Records_by_QTR = dbGetAll_REPID_Records_by_QTR(dbConnection, all_REPID, ent_date, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function Get_REPID_Record(rep_id As Long, rm_id As Long) As tREPID

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REPID_Record = dbGet_REPID_Record(dbConnection, rep_id, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_REPID_Records(ByRef all_REPID() As tREPID) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_REPID_Records = dbGetAll_REPID_Records(dbConnection, all_REPID)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function dbGet_REPID_Record(dbConnection As Object, rep_id As Long, rm_id As Long) As tREPID

-    

-    Dim sql As String

-    Dim objREPID As tREPID

-    

-    objREPID.FirstName = ""

-    objREPID.LastName = ""

-    objREPID.Region = 0

-    objREPID.City = 0

-    sql = "SELECT * FROM " & _

-          "rep WHERE rep_id=" & rep_id & " AND rm_id=" & rm_id

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREPID.rep_id = dbRecordset("rep_id")

-        objREPID.rm_id = dbRecordset("rm_id")

-        objREPID.FirstName = dbRecordset("firstname")

-        objREPID.LastName = dbRecordset("lastname")

-        objREPID.Region = dbRecordset("region")

-        objREPID.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REPID_Record = objREPID

-        

-End Function

-

-Function dbGetAll_REPID_Records_by_QTR(dbConnection As Object, ByRef all_REPID() As tREPID, ent_date As String, rm_id As Long) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    Dim Where As String

-    

-    REPID_Count = 0

-    

-    Where = " WHERE lpu_budget.entry_date like '" & ent_date & "' " & _

-        "AND rep.rep_id=lpu.rep_id AND lpu.id=lpu_budget.lpu_id"

-    If rm_id <> 0 Then

-        Where = Where & " AND rep.rm_id=" & rm_id

-    End If

-    

-    getAll_REPID_SQL = "SELECT distinct rep.* FROM rep, lpu, lpu_budget" & Where

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM (" & getAll_REPID_SQL & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records_by_QTR = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Function dbGetAll_REPID_Records(dbConnection As Object, ByRef all_REPID() As tREPID) As Integer

-    

-    Dim getCount_REPID_SQL As String

-    Dim getAll_REPID_SQL As String

-    Dim REPID_Count As Long

-    REPID_Count = 0

-    

-    getCount_REPID_SQL = "SELECT COUNT(*) AS REPID_TOTAL FROM rep"

-    getAll_REPID_SQL = "SELECT * FROM rep"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_REPID_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        REPID_Count = dbRecordset("REPID_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_REPID_Records = REPID_Count

-    

-    If REPID_Count > 0 Then

-        'we have records

-        ReDim all_REPID(1 To REPID_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_REPID_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_REPID As tREPID

-                 With tmp_REPID

-                    .rep_id = dbRecordset("rep_id")

-                    .rm_id = dbRecordset("rm_id")

-                    .FirstName = dbRecordset("firstname")

-                    .LastName = dbRecordset("lastname")

-                    .Region = dbRecordset("region")

-                    .City = dbRecordset("city")

-                 End With

-                 

-                 all_REPID(index) = tmp_REPID

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-<<<<<<
-======================
-cdbExport
->>>>>>
-Attribute VB_Name = "cdbExport"

-Option Explicit

-

-Function GetDBSN() As String

-    Dim n As Long

-    Randomize Timer

-    n = Int((100000000 - 1000000 + 1) * Rnd + 1000000)

-    GetDBSN = Dec2ThirtySix(n)

-End Function

-

-Sub dbExport()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim old_file As String

-    

-    On Error GoTo ErrHandler

-    

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    old_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & "*.*"

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & GetDBSN() & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.DeleteFile old_file, True

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Данные экспортированы в файл:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для передачи", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-Exit Sub

-

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-<<<<<<
-======================
-mRegs
->>>>>>
-Attribute VB_Name = "mRegs"

-Option Explicit

-

-Function GetRegionName(idx As Integer) As String

-    GetRegionName = Worksheets(REGS_SHEET).Range("LST_REGIONS").Cells(idx + 1, 1).Text

-End Function

-

-Function GetCityName(idx_reg As Integer, idx_city As Integer) As String

-    GetCityName = Worksheets(REGS_SHEET).Range("CITY_TABLES").Offset(idx_city + 1, idx_reg * 2).Text

-End Function

-

-Sub testReg()

-    Dim r As Integer

-    Dim c As Integer

-    Dim s As String

-    

-    r = 3

-    c = 3

-    s = GetRegionName(r)

-    s = s & ", " & GetCityName(r, c)

-    MsgBox s

-End Sub

-

-<<<<<<
-======================
-RM_QTR
->>>>>>
-Attribute VB_Name = "RM_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CRGN_QT As Integer = 0

-Const CRGN_PLN As Integer = 2

-Const CRGN_FCT As Integer = 3

-Const CRGN_BDG As Integer = 4

-Const CRGN_LPU As Integer = 5

-Const CRGN_REP As Integer = 6

-Const CRGN_HIR As Integer = 7

-Const CRGN_TER As Integer = 8

-Const CRGN_CRD As Integer = 9

-Const CRGN_CLXN_BDG As Integer = 10

-Const CRGN_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Const LOCAL_ENT_DATE As String = "B11"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("RM_QTR")

-        s = .Range("D5") & " " & .Range("D4") & ", " & .Range("H4") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub update_history()

-    Dim objRGN() As tREGION

-    Dim i As Long

-    Dim r As Range

-    Dim cRMan As tREGMAN

-

-    cRMan = Get_REGMAN_Record(Range("RM_ID"))

-    

-    Range("D4") = cRMan.LastName

-    Range("D5") = cRMan.FirstName

-

-    Range("H4") = GetRegionName(cRMan.Region)

-    

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetRGN_COMM_DATA(objRGN, Range("RM_ID"))

-    

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objRGN)

-            r.Offset(i - 1, CRGN_QT) = objRGN(i).ent_date

-            r.Offset(i - 1, CRGN_FCT) = objRGN(i).total_SALE

-            r.Offset(i - 1, CRGN_PLN) = objRGN(i).sale_PLAN

-            r.Offset(i - 1, CRGN_BDG) = objRGN(i).total_BDGT

-            r.Offset(i - 1, CRGN_LPU) = objRGN(i).total_LPU

-            r.Offset(i - 1, CRGN_REP) = objRGN(i).total_REP

-            r.Offset(i - 1, CRGN_HIR) = objRGN(i).total_HIR

-            r.Offset(i - 1, CRGN_TER) = objRGN(i).total_TER

-            r.Offset(i - 1, CRGN_CRD) = objRGN(i).total_ACS

-            If objRGN(i).total_BDGT <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_BDG) = objRGN(i).total_SALE / objRGN(i).total_BDGT

-            End If

-            If objRGN(i).total_BDGT_NMG <> 0 Then

-                r.Offset(i - 1, CRGN_CLXN_NMG) = objRGN(i).total_SALE / objRGN(i).total_BDGT_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRGN_CRD + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-

-Sub Draw_PLN_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_FCT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PLN_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Draw_BDGT_QTR_RM()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(RM_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRGN_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRGN_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRGN_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRGN_CLXN_NMG + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_BDGT_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Public Sub cbxRM_QtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR_RM

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR_RM

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR_RM

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = RM_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CRGN_QT + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    If r = "" Then

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-        Range("LAST_FOCUS") = currRange.address

-    End If

-    Cancel = True

-    btRM_QTR_Do_IT

-End Sub

-

-<<<<<<
-======================
-dbREG_MAN
->>>>>>
-Attribute VB_Name = "dbREG_MAN"

-Option Explicit

-

-Public Type tREGMAN

-    rm_id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function Get_REGMAN_Record(rm_id As Long) As tREGMAN

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_REGMAN_Record = dbGet_REGMAN_Record(dbConnection, rm_id)

-    dbCloseConnection dbConnection

-End Function

-

-Sub Set_REGMAN_Record(cREGMAN As tREGMAN)

-'    Dim dbConnection As Object

-'    dbOpenConnection dbConnection

-'    dbSet_REGMAN_Record dbConnection, cREGMAN

-'    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_REGMAN_Record(dbConnection As Object, rm_id As Long) As tREGMAN

-    

-    Dim sql As String

-    Dim objREGMAN As tREGMAN

-    

-    objREGMAN.FirstName = ""

-    objREGMAN.LastName = ""

-    objREGMAN.Region = 0

-    objREGMAN.City = 0

-    objREGMAN.rm_id = rm_id

-    sql = "SELECT * FROM " & _

-          "reg_man WHERE mgr_id=" & rm_id

-          

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open sql, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREGMAN.FirstName = dbRecordset("firstname")

-        objREGMAN.LastName = dbRecordset("lastname")

-        objREGMAN.Region = dbRecordset("region")

-        objREGMAN.City = dbRecordset("city")

-        

-    End If

-    

-    dbGet_REGMAN_Record = objREGMAN

-        

-End Function

-

-Public Sub dbSet_REGMAN_Record(dbConnection As Object, ByRef objREGMAN As tREGMAN)

-  

-'    Dim DeleteSQL As String

-'    Dim InsertSQL As String

-'

-'    DeleteSQL = "DELETE FROM reg_man"

-'    InsertSQL = "INSERT INTO reg_man (firstname, lastname, region, city) VALUES (" & _

-'    "'" & objREGMAN.FirstName & "', " & _

-'    "'" & objREGMAN.LastName & "', " & _

-'    objREGMAN.Region & ", " & _

-'    objREGMAN.City & ")"

-'

-'    Dim dbRecordset As Object

-'    Set dbRecordset = CreateObject("ADODB.Recordset")

-'    dbRecordset.Open DeleteSQL, dbConnection

-'    dbRecordset.Open InsertSQL, dbConnection

-       

-End Sub

-

-

-

-<<<<<<
-======================
-dbDatabaseMerge
->>>>>>
-Attribute VB_Name = "dbDatabaseMerge"

-Option Explicit

-

-Public Type tDBFIELD

-    Name As String

-End Type

-

-Public Type tDBTABLE

-    Name As String

-    field() As tDBFIELD

-End Type

-

-

-Function dbGetConnection(dbAccessFileFullPath As String) As Object

-    Dim dbConnection As Object

-    Dim dbAccessFilePasswd As String

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFileFullPath & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    Set dbGetConnection = dbConnection

-End Function

-

-Sub dbCloseOpenedConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteOpenedSQL(dbConnection As Object, sql As String)

-    dbConnection.Execute (sql)

-End Sub

-

-Function dbMergeREP(from_dbConnection As Object, to_dbConnection As Object) As Long

-

-    Dim getRecordset As Object

-    Dim getREPData_SQL As String

-    Dim REP_fn As String

-    Dim REP_ln As String

-    Dim REP_region As String

-    Dim REP_city As String

-

-

-    getREPData_SQL = "SELECT * FROM rep"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getREPData_SQL, from_dbConnection

-        

-        If Not getRecordset.BOF Then

-            REP_fn = getRecordset("firstname")

-            REP_ln = getRecordset("lastname")

-            REP_city = getRecordset("city")

-            REP_region = getRecordset("region")

-        Else

-            MsgBox "There is no information about rep! This database cannot be merged!!!"

-            dbMergeREP = -1

-            Exit Function

-        End If

-    

-    Dim insertRecordset As Object

-    Set insertRecordset = CreateObject("ADODB.Recordset")

-        

-    insertRecordset.Open "rep", to_dbConnection, 2, 2

-    insertRecordset.addnew

-        

-    insertRecordset("firstname") = REP_fn

-    insertRecordset("lastname") = REP_ln

-    insertRecordset("region") = REP_region

-    insertRecordset("city") = REP_city

-    insertRecordset.Update

-    insertRecordset.MoveLast

-    'new ID

-    

-    dbMergeREP = insertRecordset("rep_id")

-    

-End Function

-

-Sub dbMergeLPU(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getLPU_SQL As String

-    Dim getRecordset As Object

-    Dim idx As Long

-    idx = 1

-    

-    getLPU_SQL = "SELECT * FROM lpu"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getLPU_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            ReDim Preserve objLPU(1 To idx)

-            objLPU(idx).old_lpu_id = getRecordset("id")

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "lpu", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("name") = getRecordset("name")

-            insRS("address") = getRecordset("address")

-            insRS("beds") = getRecordset("beds")

-            insRS.Update

-            insRS.MoveLast

-            'new ID

-            

-            objLPU(idx).new_lpu_id = insRS("id")

-                        

-            idx = idx + 1

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about LPU! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-

-Sub dbMergeLPURelated(objLPU() As tLPUCONVERTION, from_db As Object, to_db As Object)

-

-    ' 6 tables to change

-    Dim tables(1 To 5) As tDBTABLE

-    

-    'lpu budget

-    tables(1).Name = "lpu_budget"

-    ReDim tables(1).field(1 To 4)

-    

-    tables(1).field(1).Name = "entry_date"

-    tables(1).field(2).Name = "bdgt_NMG"

-    tables(1).field(3).Name = "bdgt_NFG"

-    tables(1).field(4).Name = "sale_PLAN"

-    

-    'lpu hir

-    tables(2).Name = "lpu_hir"

-    ReDim tables(2).field(1 To 13)

-    

-    tables(2).field(1).Name = "entry_date"

-    tables(2).field(2).Name = "operations_per_quarter"

-    tables(2).field(3).Name = "risk_percent"

-    tables(2).field(4).Name = "patients_with_risk_ON"

-    tables(2).field(5).Name = "patients_ambulator"

-    tables(2).field(6).Name = "patients_ambulator_nmg"

-    tables(2).field(7).Name = "patients_ambulator_clexan"

-    tables(2).field(8).Name = "patients_ambulator_clexan_40mg"

-    tables(2).field(9).Name = "patients_ambulator_clexan_20mg"

-    tables(2).field(10).Name = "patients_stationar_nmg"

-    tables(2).field(11).Name = "patients_stationar_clexan"

-    tables(2).field(12).Name = "patients_stationar_clexan_40mg"

-    tables(2).field(13).Name = "patients_stationar_clexan_20mg"

-    

-    

-    'lpu acs

-    tables(3).Name = "lpu_acs"

-    ReDim tables(3).field(1 To 5)

-    

-    tables(3).field(1).Name = "entry_date"

-    tables(3).field(2).Name = "patients_with_geparins"

-    tables(3).field(3).Name = "patients_per_quarter"

-    tables(3).field(4).Name = "patients_stationar_nmg"

-    tables(3).field(5).Name = "patients_stationar_clexan"

-    

-    'lpu acs

-    tables(4).Name = "lpu_im"

-    ReDim tables(4).field(1 To 5)

-    

-    tables(4).field(1).Name = "entry_date"

-    tables(4).field(2).Name = "patients_with_geparins"

-    tables(4).field(3).Name = "patients_per_quarter"

-    tables(4).field(4).Name = "patients_stationar_nmg"

-    tables(4).field(5).Name = "patients_stationar_clexan"

-    

-    

-    'lpu acs

-    tables(5).Name = "lpu_ter"

-    ReDim tables(5).field(1 To 9)

-    

-    tables(5).field(1).Name = "entry_date"

-    tables(5).field(2).Name = "patients_per_quarter"

-    tables(5).field(3).Name = "risk_percent"

-    tables(5).field(4).Name = "patients_with_risk_ON"

-    tables(5).field(5).Name = "patients_ambulator"

-    tables(5).field(6).Name = "patients_ambulator_nmg"

-    tables(5).field(7).Name = "patients_ambulator_clexan"

-    tables(5).field(8).Name = "patients_stationar_nmg"

-    tables(5).field(9).Name = "patients_stationar_clexan"

-    

-    

-    

-    Dim tbl_idx As Integer

-    

-    For tbl_idx = 1 To UBound(tables)

-        

-        Dim getSQL As String

-        Dim getRS As Object

-        

-        

-        

-        Set getRS = CreateObject("ADODB.Recordset")

-        

-        getSQL = "SELECT * FROM " & tables(tbl_idx).Name

-        getRS.Open getSQL, from_db

-        

-        If Not getRS.BOF Then

-            Do While Not getRS.EOF

-                Dim insRS As Object

-                Set insRS = CreateObject("ADODB.Recordset")

-                

-                insRS.Open tables(tbl_idx).Name, to_db, 2, 2

-                insRS.addnew

-                Dim fld_idx As Integer

-    

-                    For fld_idx = 1 To UBound(tables(tbl_idx).field)

-                        insRS(tables(tbl_idx).field(fld_idx).Name) = getRS(tables(tbl_idx).field(fld_idx).Name)

-                        insRS("lpu_id") = findNewLPU_IDByOld(objLPU, getRS("lpu_id"))

-                    Next fld_idx

-                    

-                insRS.Update

-                insRS.MoveLast

-                getRS.MoveNext

-            Loop

-        End If

-        

-        

-    Next tbl_idx

-

-End Sub

-

-Function findNewLPU_IDByOld(objLPU() As tLPUCONVERTION, old_id As Long)

-

-Dim i As Integer

-For i = 1 To UBound(objLPU)

-    If objLPU(i).old_lpu_id = old_id Then

-        findNewLPU_IDByOld = objLPU(i).new_lpu_id

-        Exit Function

-    End If

-Next i

-

-findNewLPU_IDByOld = -1

-End Function

-

-

-

-

-

-Sub dbMergeQTR(from_db As Object, to_db As Object, current_rep_id As Long)

-

-    'get all lpu

-    Dim getQTR_SQL As String

-    Dim getRecordset As Object

-    

-    getQTR_SQL = "SELECT * FROM quarter"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getQTR_SQL, from_db

-    

-    If Not getRecordset.BOF Then

-        Do While Not getRecordset.EOF

-            

-            Dim insRS As Object

-            Set insRS = CreateObject("ADODB.Recordset")

-            

-            insRS.Open "quarter", to_db, 2, 2

-            insRS.addnew

-            insRS("rep_id") = current_rep_id

-            insRS("entry_date") = getRecordset("entry_date")

-            insRS("sale_plan") = getRecordset("sale_plan")

-            insRS("ClxnH20mg") = getRecordset("ClxnH20mg")

-            insRS("ClxnH40mg") = getRecordset("ClxnH40mg")

-            insRS("ClxnT40mg") = getRecordset("ClxnT40mg")

-            insRS("ClxnC_IM") = getRecordset("ClxnC_IM")

-            insRS("ClxnC_ACS") = getRecordset("ClxnC_ACS")

-            

-            

-            insRS.Update

-            

-            getRecordset.MoveNext

-        Loop

-    

-    Else

-        MsgBox "There is no information about quarter budget! This database cannot be merged!!!"

-        Exit Sub

-    End If

-End Sub

-

-<<<<<<
-======================
-dbMerge
->>>>>>
-Attribute VB_Name = "dbMerge"

-Option Explicit

-

-Public Type tLPUCONVERTION

-    old_lpu_id As Long

-    new_lpu_id As Long

-End Type

-

-Sub Merge_BackUp_All_Data()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim time_stump As String

-    

-    On Error GoTo ErrHandler

-    

-    time_stump = Format(Date, "yy-mm-dd_") & Format(Time, "hh-mm")

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_BACKUPNAME & time_stump & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Старые данные сохранены в файле:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для восстанеовления данных в случае утери", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-    Exit Sub

-    

-ErrHandler:

-    If err.Number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-

-Sub Merge_Clear_All_Data(access_file_full_path As String)

-    

-    Dim db As Object

-    Dim tables_to_clear() As String

-    On Error GoTo ErrHandler

-    

-    ReDim tables_to_clear(1 To 10)

-    tables_to_clear(1) = "rep"

-    tables_to_clear(2) = "lpu"

-    tables_to_clear(3) = "lpu_budget"

-    tables_to_clear(4) = "lpu_hir"

-    tables_to_clear(5) = "lpu_ter"

-    tables_to_clear(6) = "lpu_acs"

-    tables_to_clear(7) = "lpu_im"

-    tables_to_clear(8) = "quarter"

-    tables_to_clear(9) = "quarter_rm"

-    tables_to_clear(10) = "reg_man"

-    

-    Set db = dbGetConnection(access_file_full_path)

-

-    Dim i As Integer

-    

-    For i = 1 To UBound(tables_to_clear)

-        

-        If tables_to_clear(i) <> "" Then

-            Dim Clear_SQL As String

-            Clear_SQL = "DELETE FROM " & tables_to_clear(i)

-            dbExecuteOpenedSQL db, Clear_SQL

-        Else

-            'do nothing or show message

-        End If

-    Next i

-    

-    dbCloseOpenedConnection db

-    Set db = Nothing

-    

-Exit Sub

-

-ErrHandler:

-    MsgBox "something wrong: " & err.Description

-    Resume Next

-    

-End Sub

-

-Function MergeREP(from_file As String, to_file As String) As Long

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    Dim new_rep_id As Long

-

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    MergeREP = dbMergeREP(db1, db2)

-    'MsgBox "new rep ID is " & new_rep_id

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Function

-

-Sub MergeQTR(from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeQTR db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-

-Sub MergeLPU(objLPU() As tLPUCONVERTION, from_file As String, to_file As String, current_rep_id As Long)

-   

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    

-        dbMergeLPU objLPU, db1, db2, current_rep_id

-    

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-    

-End Sub

-

-Sub MergeLPURelated(objLPU() As tLPUCONVERTION, from_file As String, to_file As String)

-    Dim db1 As Object

-    Dim db2 As Object

-    

-    Set db1 = dbGetConnection(from_file)

-    Set db2 = dbGetConnection(to_file)

-    dbMergeLPURelated objLPU, db1, db2

-    dbCloseOpenedConnection db1

-    dbCloseOpenedConnection db2

-

-End Sub

-

-Sub MergeGlobal(rep_files() As String, rm_file As String)

-

-    Dim i As Integer

-    'clear output file content

-    Merge_Clear_All_Data rm_file

-    

-    For i = 1 To UBound(rep_files)

-        

-        Dim rep_file As String

-        'setup input and output files

-        rep_file = rep_files(i)

-        

-        Dim new_rep_id As Long

-        ' insert REP data and get new rep_id

-        new_rep_id = MergeREP(rep_file, rm_file)

-        

-        Dim objLPU() As tLPUCONVERTION

-        'insert all LPU using new generated rep_id

-        'and populate objLPU old->new relation object

-        

-        MergeLPU objLPU, rep_file, rm_file, new_rep_id

-        'insert quarter data using new rep_id

-        MergeQTR rep_file, rm_file, new_rep_id

-        

-        

-        ' and.... insert all another data (5 tables excl version and hw)

-        'using objLPU old->new relation object

-        MergeLPURelated objLPU, rep_file, rm_file

-    

-    

-    Next i

-    

-End Sub

-

-Function GetDBList(MyPath() As String, ByRef dblist() As String) As Integer

-    Dim i As Integer

-    Dim MyName, MyMask

-    MyMask = MyPath(0) & MyPath(1) & PROGRAM_DATAEXT

-    i = 0

-    MyName = Dir(MyMask)      ' Retrieve the first entry.

-    Do While MyName <> ""    ' Start the loop.

-        ' Ignore the current directory and the encompassing directory.

-        If MyName <> "." And MyName <> ".." Then

-            ' Use bitwise comparison to make sure MyName is a directory.

-            i = i + 1

-            ReDim Preserve dblist(i)

-            dblist(i) = MyPath(0) & MyName

-        End If

-        MyName = Dir    ' Get next entry.

-    Loop

-    GetDBList = i

-End Function

-

-<<<<<<
-======================
-cdbPRJ
->>>>>>
-Attribute VB_Name = "cdbPRJ"

-Option Explicit

-

-Type tPROJECT

-    total_SALE  As Long ' общий объем продаж

-    total_BDGT  As Long ' бюджет всех ЛПУ

-    total_BDGT_NMG As Long ' бюджет всех ЛПУ на НМГ

-    total_LPU   As Long ' число ЛПУ

-    total_REP   As Long ' число репов

-    total_RM    As Long ' число репов

-    total_BEDS  As Long ' общее число коек

-    total_HIR   As Long '  общее число пациентов на клексане в хирургии

-    total_TER   As Long '  общее число пациентов на клексане в терапии

-    total_ACS   As Long '  общее число пациентов на клексане в кардиологии

-    sale_PLAN   As Long '  план продаж Авентиса

-    objRGN() As tREGION

-End Type

-

-Function GetPRJ_COMM_DATA(ByRef prj_data As tPROJECT) As Integer

-    Dim i As Integer

-    i = GetRGN_COMM_DATA(prj_data.objRGN, 0)

-    GetPRJ_COMM_DATA = i

-    If i > 0 Then

-        With prj_data

-            .sale_PLAN = 0

-            .total_ACS = 0

-            .total_BDGT = 0

-            .total_BDGT_NMG = 0

-            .total_BEDS = 0

-            .total_HIR = 0

-            .total_LPU = 0

-            .total_REP = 0

-            .total_RM = 0

-            .total_SALE = 0

-            .total_TER = 0

-            For i = 1 To UBound(prj_data.objRGN)

-                

-            Next i

-        End With

-    End If

-

-End Function

-

-<<<<<<
-======================
-dbQTR_RM
->>>>>>
-Attribute VB_Name = "dbQTR_RM"

-Option Explicit

-

-Public Type tQTRRM

-    id As Long

-    entry_date As String

-    rm_id As Long

-    sale_PLAN As Long

-End Type

-

-

-Sub Insert_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objQTRRM.id <> 0 Then

-        dbUpdate_QTRRM_Record dbConnection, objQTRRM

-    Else

-        dbInsert_QTRRM_Record dbConnection, objQTRRM

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-Function Get_QTRRM_Record(ent_date As String) As tQTRRM

-    Dim dbConnection As Object

-    Dim allQTRRM() As tQTRRM

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    i = dbGetAll_QTRRM_Records(dbConnection, allQTRRM, ent_date)

-    If i <> 0 Then

-        Get_QTRRM_Record = allQTRRM(1)

-    End If

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTRRM_Records(ByRef all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_QTRRM_Records = dbGetAll_QTRRM_Records(dbConnection, all_QTRRM, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_QTRRM_Record(ByRef objQTRRM As tQTRRM)

-    Dim dbConnection As Object

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_QTRRM_Record dbConnection, objQTRRM

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objQTRRM.ID <> 0 then updatre else insert

-Sub dbInsert_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "quarter_rm", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objQTRRM

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("sale_plan") = .sale_PLAN

-        dbRecordset("rm_id") = .rm_id

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objQTRRM.id = dbRecordset("id")

-

-End Sub

-

-Sub dbUpdate_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    Dim Update_SQL As String

-    

-    With objQTRRM

-        Update_SQL = "UPDATE quarter_rm SET " & _

-            "entry_date='" & .entry_date & "'" & "," & _

-            "rm_id=" & .rm_id & "," & _

-            "sale_plan=" & .sale_PLAN & "," & _

-            " WHERE id=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if ent_date = % then all_records

-Function dbGetAll_QTRRM_Records(dbConnection As Object, all_QTRRM() As tQTRRM, ent_date As String) As Integer

-    

-    Dim getCount_QTRRM_SQL As String

-    Dim getAll_QTRRM_SQL As String

-    Dim QTRRM_Count As Long

-    QTRRM_Count = 0

-    

-    getCount_QTRRM_SQL = "SELECT COUNT(*) AS QTRRM_TOTAL FROM quarter_rm WHERE entry_date like '" & ent_date & "'"

-    getAll_QTRRM_SQL = "SELECT * FROM quarter_rm WHERE entry_date like '" & ent_date & "' ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTRRM_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTRRM_Count = dbRecordset("QTRRM_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_QTRRM_Records = QTRRM_Count

-    

-    If QTRRM_Count > 0 Then

-        'we have records

-        ReDim all_QTRRM(1 To QTRRM_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTRRM_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTRRM As tQTRRM

-                 With tmp_QTRRM

-                    .entry_date = dbRecordset("entry_date")

-                    .rm_id = dbRecordset("rep_id")

-                    .sale_PLAN = dbRecordset("sale_plan")

-                    .id = dbRecordset("id")

-                 End With

-                 

-                 all_QTRRM(index) = tmp_QTRRM

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_QTRRM_Record(dbConnection As Object, ByRef objQTRRM As tQTRRM)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM quarter_rm " & _

-    "WHERE id=" & objQTRRM.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-    

-    'delete related budget entries

-    MsgBox "remember delete related"

-'    dbDelete_BDGT_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Hir_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_Ter_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-'    dbDelete_ACS_RecordsByQTRRM dbConnection, objQTRRM.entry_date

-       

-End Sub

-

-

-<<<<<<
-======================
-REP_LIST
->>>>>>
-Attribute VB_Name = "REP_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Const LOCAL_ENT_DATE As String = "C10"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-

-Public Function getCurrentREP_ID() As Long

-    Dim r As Range

-

-    With Worksheets("REP_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CREP_ID)

-    End With

-

-    getCurrentREP_ID = r

-End Function

-

-Public Sub REP_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Rep_Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Rep_Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Rep_Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-        

-        Case 4

-            Rep_Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "REP_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectREP_LPU(rep_id As Long, ent_date As String)

-    Dim vo As Boolean

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    Range("JUMP") = "LPU_LIST"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-        .Range("RM_ID") = rm_id

-        .setEnt_date (getEnt_date())

-    End With

-End Sub

-

-Public Sub SelectREP_QTR(rep_id As Long)

-    Dim vo As Boolean

-    Dim rm_id As Long

-    

-    rm_id = Range("RM_ID")

-    

-    Range("JUMP") = "REP_QTR"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("REP_QTR")

-        .Range("VIEW_ONLY") = vo

-        .Range("RM_ID") = rm_id

-        .Range("ret_addr") = "REP_LIST"

-        .Range("REP_ID") = rep_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateREPList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim rep_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CREP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CREP_AREA).row, CREP_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    rep_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CREP_AREA).Column

-    

-    If i < 4 Then

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 1

-    Else

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 2

-    End If

-    

-    If rep_id = 0 Then

-        Range("LAST_FOCUS") = Range(CREP_AREA).address

-    End If

-

-    If rep_id = 0 Then

-        i = CREP_NAME

-        Range("JUMP") = ""

-    Else

-        btREP_LIST_DO_IT

-    End If

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateREPList()

-    Dim rcd() As tREPID_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-

-    ent_date = getEnt_date

-

-    Dim rm_struc As tREGMAN

-    

-    i = Range("RM_ID")

-    rm_struc = Get_REGMAN_Record(i)

-    

-    Range("C4") = rm_struc.LastName

-    Range("C5") = rm_struc.FirstName

-

-    Range("G5") = GetRegionName(rm_struc.Region)

-    

-    i = Get_REP_CommonList_by_QTR(rcd, ent_date, Range("RM_ID"))

-

-    

-    With ThisWorkbook.Worksheets("REP_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(rcd)

-            r.Offset(i - 1, CREP_NAME) = rcd(i).rep.FirstName & " " & rcd(i).rep.LastName

-            r.Offset(i - 1, CREP_ID) = rcd(i).rep.rep_id

-            r.Offset(i - 1, CREP_BEDS) = rcd(i).qtrs(1).c_beds

-

-            r.Offset(i - 1, CREP_NFG) = rcd(i).qtrs(1).c_bdgt_NFG

-            r.Offset(i - 1, CREP_NMG) = rcd(i).qtrs(1).c_bdgt_NMG

-

-            r.Offset(i - 1, CREP_PLAN) = rcd(i).qtrs(1).qtr.sale_PLAN

-

-            r.Offset(i - 1, CREP_HIR) = rcd(i).qtrs(1).c_pat_HIR

-            r.Offset(i - 1, CREP_TER) = rcd(i).qtrs(1).c_pat_TER

-            r.Offset(i - 1, CREP_CAR) = rcd(i).qtrs(1).c_pat_CRD

-            r.Offset(i - 1, CREP_FACT) = rcd(i).qtrs(1).c_sale_ALL

-            r.Offset(i - 1, CREP_PAT_LPU) = rcd(i).qtrs(1).c_pat_LPU

-            r.Offset(i - 1, CREP_BDGT) = rcd(i).qtrs(1).c_bdgt_LPU

-            If rcd(i).qtrs(1).c_bdgt_LPU > 0 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = rcd(i).qtrs(1).c_sale_ALL / rcd(i).qtrs(1).c_bdgt_LPU

-            End If

-            If r.Offset(i - 1, CREP_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CREP_BDGT + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-

-

-<<<<<<
-======================
-mREP_LIST
->>>>>>
-Attribute VB_Name = "mREP_LIST"

-Option Explicit

-

-Public Const CREP_AREA As String = "B12"

-Public Const CREP_NAME As Integer = 0

-Public Const CREP_NAME1 As Integer = 1

-Public Const CREP_NAME2 As Integer = 2

-Public Const CREP_ID As Integer = 3

-Public Const CREP_BEDS As Integer = 4

-Public Const CREP_NFG As Integer = 5

-Public Const CREP_NMG As Integer = 6

-Public Const CREP_HIR As Integer = 7

-Public Const CREP_TER As Integer = 8

-Public Const CREP_CAR As Integer = 9

-Public Const CREP_FACT As Integer = 10

-Public Const CREP_PLAN As Integer = 11

-Public Const CREP_PAT_LPU As Integer = 16

-Public Const CREP_BDGT As Integer = 17

-

-

-Const LOCAL_ENT_DATE As String = "C10"

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Sub EditREP(cRep As tREPID, ent_date As String)

-    NoFunc

-End Sub

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("REP_LIST")

-        s = .Range("C5") & " " & .Range("C4") & ", " & .Range("G5") & ", " & .getEnt_date()

-    End With

-    MakeChartTitle = s

-End Function

-

-Sub Rep_Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_LPU_BBL").Range("title") = MakeChartTitle

-End Sub

-

-Sub Rep_Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CREP_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CREP_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CREP_FACT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PIE").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rep_Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CREP_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CREP_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CREP_HIR + 1)

-            psum = psum + src.Cells(i, CREP_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CREP_TER + 1)

-            psum = psum + src.Cells(i, CREP_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CREP_CAR + 1)

-            psum = psum + src.Cells(i, CREP_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CREP_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rep_Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("REP_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CREP_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CREP_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CREP_HIR + 1)

-            psum = psum + src.Cells(i, CREP_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CREP_TER + 1)

-            psum = psum + src.Cells(i, CREP_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CREP_CAR + 1)

-            psum = psum + src.Cells(i, CREP_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CREP_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU_A").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub btREP_RET_IT()

-    With Worksheets("REP_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = "RM_QTR"

-    End With

-    Dim str As String

-    str = Range("ret_addr")

-    ThisWorkbook.Worksheets(str).Activate

-End Sub

-

-

-Sub btREP_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim rep_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("REP_LST_DETALS")

-    With Worksheets("REP_LIST")

-        rep_id = .getCurrentREP_ID

-        

-        Select Case i

-            Case 1:

-                .SelectREP_QTR rep_id

-            Case 2:

-                ent_date = .getEnt_date()

-                .SelectREP_LPU rep_id, ent_date

-        End Select

-    End With

-    

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-

-

-

-<<<<<<
-======================
-cdbREP
->>>>>>
-Attribute VB_Name = "cdbREP"

-Option Explicit

-

-Public Type tREPID_COMMON

-    rep As tREPID

-    i_qtrs As Integer

-    qtrs() As tQTR_COMMON

-End Type

-

-Function Get_REP_CommonList_by_QTR(ByRef rcd() As tREPID_COMMON, ent_date As String, rm_id As Long) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_REP_CommonList_by_QTR = dbGet_REP_CommonList_by_QTR(dbConnection, rcd, ent_date, rm_id)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_REP_CommonList_by_QTR(dbConnection As Object, ByRef rcd() As tREPID_COMMON, ent_date As String, rm_id As Long) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim k As Long

-    Dim allREPID() As tREPID

-    

-    i = dbGetAll_REPID_Records_by_QTR(dbConnection, allREPID, ent_date, rm_id)

-    dbGet_REP_CommonList_by_QTR = i

-    If i > 0 Then

-        ReDim rcd(i)

-        For i = 1 To UBound(allREPID)

-            rcd(i).rep = allREPID(i)

-            rcd(i).i_qtrs = Get_QTR_CommonList_by_REP(rcd(i).qtrs, ent_date, allREPID(i).rep_id, allREPID(i).rm_id)

-        Next i

-    End If

-End Function

-

-

-

-<<<<<<
-======================
-CHRT_PAT_LPU_A
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU_A"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Sub PrintCopy()

-    ChartObjects(1).CopyPicture xlScreen, xlBitmap

-End Sub

-

-Private Sub Worksheet_Activate()

-    On Error Resume Next

-    ChartObjects(1).Chart.ChartTitle.Characters.Text = "Пациенты на Клексане(чел.): " & Range("title")

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Range("title") = CHART_DEF_TITLE

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-cdbRegion
->>>>>>
-Attribute VB_Name = "cdbRegion"

-Option Explicit

-

-Type tREGION

-    ent_date As String

-    rm_id As Long

-    total_SALE As Long ' общий объем продаж

-    total_BDGT As Long ' бюджет всех ЛПУ

-    total_BDGT_NMG As Long ' бюджет всех ЛПУ на НМГ

-    total_LPU As Long ' число ЛПУ

-    total_REP   As Long ' число репов

-    total_BEDS As Long ' общее число коек

-    total_HIR As Long '  общее число пациентов на клексане в хирургии

-    total_TER As Long '  общее число пациентов на клексане в терапии

-    total_ACS As Long '  общее число пациентов на клексане в кардиологии

-    sale_PLAN As Long '  план продаж Авентиса

-End Type

-

-Function GetRGN_COMM_DATA(ByRef reg_data() As tREGION, rm_id As Long) As Integer

-    Dim q_date() As String

-    Dim q_count As Integer, i As Integer

-    

-    q_count = getAllQTRNames(q_date, rm_id)

-    If q_count > 0 Then

-        ReDim reg_data(q_count)

-        For i = 1 To q_count

-            Dim current_REP_count As Integer

-            reg_data(i).rm_id = rm_id

-            reg_data(i).ent_date = q_date(i)

-            current_REP_count = getREGION_by_QTR(q_date(i), reg_data(i), rm_id)

-        Next i

-    End If

-    

-    GetRGN_COMM_DATA = q_count

-End Function

-

-' if rm_id = 0 then gets all records

-Function getAllQTRNames(ByRef qtr_lst() As String, rm_id As Long) As Integer

-    

-    Dim sql As String

-    Dim i As Integer

-    Dim db As Object, rs As Object

-    

-    sql = "SELECT DISTINCT entry_date FROM lpu_budget"

-    

-    If rm_id <> 0 Then

-        sql = sql & " WHERE rm_id=" & rm_id

-    End If

-    

-    i = 0

-    

-    dbOpenConnection db

-    Set rs = CreateObject("ADODB.Recordset")

-    

-    rs.Open sql, db

-        

-        If Not rs.BOF Then

-            Do While Not rs.EOF

-                i = i + 1

-                ReDim Preserve qtr_lst(i)

-                qtr_lst(i) = rs("entry_date")

-                rs.MoveNext

-            Loop

-        Else

-            getAllQTRNames = 0

-            Exit Function

-        End If

-    getAllQTRNames = i

-    dbCloseConnection db

-End Function

-

-Function getREGION_by_QTR(ent_date As String, treg As tREGION, rm_id As Long) As Integer

-    Dim rep_count As Integer

-    rep_count = 0

-    

-    Dim reps() As tQTR_COMMON

-    rep_count = Get_QTR_CommonList_by_REP(reps, ent_date, 0, rm_id)

-    

-    treg.ent_date = ent_date

-    treg.total_BDGT = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.total_BDGT_NMG = 0 ' lpu_budget.bdgt_NMG+lpu_budget.bdgt_NFG

-    treg.sale_PLAN = 0 ' quarter.sale_plan

-    treg.total_SALE = 0 'summ of

-    ' hir = (amb40+st40)*pr40 + (amb20+st20)*pr20

-    'ter (amb_clx+stat_clx)*price

-    ' acs xxx

-    'price per rep

-    treg.total_HIR = 0 'patiens clxn

-    treg.total_TER = 0 'patiens clxn

-    treg.total_ACS = 0 'patiens clxn

-    treg.total_LPU = 0 'lpu

-    treg.total_BEDS = 0 'lpu.beds

-    treg.total_REP = 0 '

-    

-    If rep_count > 0 Then

-        Dim i As Integer

-        

-        For i = 1 To UBound(reps)

-            ' current rep is reps(i)

-            With reps(i)

-                treg.total_BDGT = treg.total_BDGT + .c_bdgt_NFG + .c_bdgt_NMG

-                treg.total_BDGT_NMG = treg.total_BDGT_NMG + .c_bdgt_NMG

-                treg.sale_PLAN = treg.sale_PLAN + .qtr.sale_PLAN

-                treg.total_SALE = treg.total_SALE + .c_sale_ALL

-                treg.total_HIR = treg.total_HIR + .c_pat_HIR

-                treg.total_TER = treg.total_TER + .c_pat_TER

-                treg.total_ACS = treg.total_ACS + .c_pat_CRD

-                treg.total_LPU = treg.total_LPU + .i_lcd

-                treg.total_BEDS = treg.total_BEDS + .c_beds

-                treg.total_REP = treg.total_REP + 1

-            End With

-            

-        Next i

-        

-    End If

-    

-    getREGION_by_QTR = treg.total_REP

-End Function

-

-<<<<<<
-======================
-mRM_QTR
->>>>>>
-Attribute VB_Name = "mRM_QTR"

-Option Explicit

-

-Sub btRM_QTR_Do_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    Dim i As Integer

-    Dim def_dir As String

-    Dim flist() As String

-    

-    idx = Worksheets(VAR_SHEET).Range("RM_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-'            def_dir = GetWBPath(ThisWorkbook.FullName)

-'            If GetImportDirectory(def_dir, flist) Then

-'                Dim db_list() As String

-'                i = GetDBList(flist, db_list)

-'                If i > 0 Then

-'                    ImportFromRegionalManagers db_list, GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-'                End If

-'            End If

-'            Worksheets(RM_QTR_SHEET).update_history

-        Case 2

-            Worksheets("REP_LIST").Range("ret_addr") = "RM_QTR"

-            Worksheets("REP_LIST").setEnt_date (Worksheets(RM_QTR_SHEET).getEnt_date())

-            Worksheets("REP_LIST").Range("RM_ID") = Worksheets(RM_QTR_SHEET).Range("RM_ID")

-            Worksheets("REP_LIST").Range("VIEW_ONLY") = True

-

-            Worksheets("REP_LIST").Select

-        Case 3

-            MsgBox "Функция не доступна", vbOKOnly, PROGRAM_NAME

-    End Select

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-End Sub

-

-Sub btRM_QTR_RET_IT()

-    Dim str As String

-    str = Range("ret_addr")

-    ThisWorkbook.Worksheets(str).Activate

-End Sub

-

-<<<<<<
-======================
-mImport
->>>>>>
-Attribute VB_Name = "mImport"

-    Option Explicit

-

-Const OFN_ALLOWMULTISELECT As Long = 512

-Const OFN_EXPLORER As Long = 524288

-Const OFN_HIDEREADONLY As Long = 4

-Const OFN_NONETWORKBUTTON As Long = 131072

-Const OFN_READONLY As Long = 1

-       

-Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _

-    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

-

-Private Type OPENFILENAME

-    lStructSize As Long

-    hWndOwner As Long

-    hInstance As Long

-    lpstrFilter As String

-    lpstrCustomFilter As String

-    nMaxCustFilter As Long

-    nFilterIndex As Long

-    lpstrFile As String

-    nMaxFile As Long

-    lpstrFileTitle As String

-    nMaxFileTitle As Long

-    lpstrInitialDir As String

-    lpstrTitle As String

-    flags As Long

-    nFileOffset As Integer

-    nFileExtension As Integer

-    lpstrDefExt As String

-    lCustData As Long

-    lpfnHook As Long

-    lpTemplateName As String

-End Type

-

-Function GetImportDirectory(DB_dir As String, flist() As String) As Boolean

-    Dim OpenFile As OPENFILENAME

-    Dim lReturn As Long

-    Dim sFilter As String

-    

-    OpenFile.lStructSize = Len(OpenFile)

-    '         OpenFile.hwndOwner = Form1.hWnd

-    '         OpenFile.hInstance = App.hInstance

-    sFilter = "Clexane Data Files" & Chr(0) & PROGRAM_IMPORTNAME & PROGRAM_DATAEXT & Chr(0)

-    OpenFile.lpstrFilter = sFilter

-    OpenFile.nFilterIndex = 1

-    OpenFile.lpstrFile = String(257, 0)

-    OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1

-    OpenFile.lpstrFileTitle = OpenFile.lpstrFile

-    OpenFile.nMaxFileTitle = OpenFile.nMaxFile

-    OpenFile.lpstrInitialDir = DB_dir

-    OpenFile.lpstrTitle = "Импорт данных"

-    OpenFile.flags = OFN_HIDEREADONLY + OFN_EXPLORER

-    lReturn = GetOpenFileName(OpenFile)

-    If lReturn = 0 Then

-        GetImportDirectory = False

-    Else

-        GetImportDirectory = True

- 

-        flist = Split(OpenFile.lpstrFile, Chr(0), Compare:=vbBinaryCompare)

-        Dim i As Integer

-        i = 0

-        Do While flist(i) <> ""

-            i = i + 1

-        Loop

-        If i = 1 Then

-            flist(1) = flist(0)

-            flist(0) = GetWBPath(flist(1))

-            flist(1) = GetWBName(flist(1))

-        Else

-            flist(0) = flist(0) & "\"

-        End If

-    End If

-End Function

-<<<<<<
-======================
-cPPReport
->>>>>>
-Attribute VB_Name = "cPPReport"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Const PPR_NON As Integer = 0

-Const PPR_NEW As Integer = 1

-Const PPR_OLD As Integer = 2

-

-Dim ReportApp As PowerPoint.Application

-Dim ReportDoc As PowerPoint.Presentation

-Dim ReportState As Integer

-Dim PowerPointPath As String

-

-Private Sub Class_Initialize()

-    Set ReportApp = CreateObject("PowerPoint.Application")

-    PowerPointPath = ReportApp.Path & "\PowerPNT.EXE"

-    ReportState = PPR_NON

-End Sub

-

-Sub OpenReport(FileName As String)

-    If ReportState <> PPR_NON Then

-        SaveReport

-    End If

-    Set ReportDoc = GetObject(FileName)

-    ReportState = PPR_OLD

-End Sub

-

-Sub CreateReport()

-    If ReportState <> PPR_NON Then

-        SaveReport

-    End If

-    Set ReportDoc = ReportApp.Presentations.Add

-    ReportState = PPR_NEW

-End Sub

-

-Sub SaveReport()

-    Select Case ReportState

-        Case PPR_NEW

-            ReportDoc.SaveAs GetWBPath(ThisWorkbook.FullName) + PROGRAM_FILENAME

-        Case PPR_OLD

-            ReportDoc.Save

-    End Select

-    ReportState = PPR_NON

-End Sub

-

-Sub ReportView()

-    Dim CmdName As String

-    CmdName = GetWBPath(ThisWorkbook.FullName) + PROGRAM_FILENAME + ".PPT"

-    CmdName = PowerPointPath & " " & CmdName

-    Shell CmdName, 1

-End Sub

-

-Sub InsertSlide()

-    Dim ReportPage As PowerPoint.Slide

-    Set ReportPage = ReportDoc.Slides.Add(ReportDoc.Slides.count + 1, ppLayoutBlank)

-    

-    ReportPage.Shapes.Paste

-    ReportPage.Shapes.AddLabel(msoTextOrientationHorizontal, 20, 20, 640, 40) _

-      .TextFrame.TextRange.Text = "Slide #" & Format(ReportDoc.Slides.count)

-End Sub

-

-

-Private Sub Class_Terminate()

-    SaveReport

-    ReportApp.Quit

-End Sub

-<<<<<<
-======================
-dlgImprtDB
->>>>>>
-Attribute VB_Name = "dlgImprtDB"

-Attribute VB_Base = "0{36355920-F7A4-44A8-96EF-5D79CF26137D}{F852BDF2-AB3E-468E-89DF-EC5DC0C7C88B}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-

-Private Sub btSelAll_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = True

-    Next i

-End Sub

-

-Private Sub btUnselect_Click()

-    For i = 0 To Me.lbListDB.ListCount - 1

-        Me.lbListDB.Selected(i) = False

-    Next i

-End Sub

-<<<<<<
-======================
-rmImport
->>>>>>
-Attribute VB_Name = "rmImport"

-Option Explicit

-

-Public Type dbDESCRIPTION

-    Name As String

-    Fields() As String

-End Type

-

-Sub ImportFromRegionalManagers(rm_files() As String, fm_file As String)

-    Dim db(9) As dbDESCRIPTION

-    

-    '''''data

-    db(1).Name = "rep"

-    

-    db(2).Name = "lpu"

-    db(3).Name = "lpu_acs"

-    db(4).Name = "lpu_budget"

-    db(5).Name = "lpu_hir"

-    db(6).Name = "lpu_im"

-    db(7).Name = "lpu_ter"

-    db(8).Name = "quarter"

-    db(9).Name = "quarter_rm"

-    

-    ReDim db(1).Fields(5)

-    With db(1)

-        .Fields(1) = "rep_id"

-        .Fields(2) = "firstname"

-        .Fields(3) = "lastname"

-        .Fields(4) = "region"

-        .Fields(5) = "city"

-    End With

-    

-    ReDim db(2).Fields(5)

-    With db(2)

-        .Fields(1) = "id"

-        .Fields(2) = "rep_id"

-        .Fields(3) = "name"

-        .Fields(4) = "address"

-        .Fields(5) = "beds"

-    End With

-    

-    ReDim db(3).Fields(7)

-    With db(3)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "patients_with_geparins"

-        .Fields(5) = "patients_per_quarter"

-        .Fields(6) = "patients_stationar_nmg"

-        .Fields(7) = "patients_stationar_clexan"

-    End With

-    

-    ReDim db(4).Fields(6)

-    With db(4)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "bdgt_NMG"

-        .Fields(5) = "bdgt_NFG"

-        .Fields(6) = "sale_PLAN"

-    End With

-    

-    ReDim db(5).Fields(15)

-    With db(5)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "operations_per_quarter"

-        .Fields(5) = "risk_percent"

-        .Fields(6) = "patients_with_risk_ON"

-        .Fields(7) = "patients_ambulator"

-        .Fields(8) = "patients_ambulator_nmg"

-        .Fields(9) = "patients_ambulator_clexan"

-        .Fields(10) = "patients_ambulator_clexan_40mg"

-        .Fields(11) = "patients_ambulator_clexan_20mg"

-        .Fields(12) = "patients_stationar_nmg"

-        .Fields(13) = "patients_stationar_clexan"

-        .Fields(14) = "patients_stationar_clexan_40mg"

-        .Fields(15) = "patients_stationar_clexan_20mg"

-    End With

-    

-    

-    ReDim db(6).Fields(7)

-    With db(6)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "patients_with_geparins"

-        .Fields(5) = "patients_per_quarter"

-        .Fields(6) = "patients_stationar_nmg"

-        .Fields(7) = "patients_stationar_clexan"

-    End With

-    

-    ReDim db(7).Fields(11)

-    With db(7)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "lpu_id"

-        .Fields(4) = "patients_per_quarter"

-        .Fields(5) = "risk_percent"

-        .Fields(6) = "patients_with_risk_ON"

-        .Fields(7) = "patients_ambulator"

-        .Fields(8) = "patients_ambulator_nmg"

-        .Fields(9) = "patients_ambulator_clexan"

-        .Fields(10) = "patients_stationar_nmg"

-        .Fields(11) = "patients_stationar_clexan"

-    End With

-    

-    ReDim db(8).Fields(9)

-    With db(8)

-        .Fields(1) = "ID"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "rep_id"

-        .Fields(4) = "sale_plan"

-        .Fields(5) = "ClxnH20mg"

-        .Fields(6) = "ClxnH40mg"

-        .Fields(7) = "ClxnT40mg"

-        .Fields(8) = "ClxnC_IM"

-        .Fields(9) = "ClxnC_ACS"

-    End With

-    

-    ReDim db(9).Fields(3)

-    With db(9)

-        .Fields(1) = "id"

-        .Fields(2) = "entry_date"

-        .Fields(3) = "sale_plan"

-    End With

-    

-    Dim rm_idx As Integer

-    Dim to_db As Object

-    'back uo

-    Merge_BackUp_All_Data

-    

-    'clean up

-    Merge_Clear_All_Data fm_file

-    

-    Set to_db = dbGetConnection(fm_file)

-    

-    For rm_idx = 1 To UBound(rm_files)

-        Dim from_db As Object

-        

-        Set from_db = dbGetConnection(rm_files(rm_idx))

-        

-        Dim new_rm_id As Long

-        new_rm_id = dbMergeRM(from_db, to_db)

-

-        Dim i As Integer

-

-        For i = 1 To UBound(db)

-            Dim get_sql As String

-            Dim getRS As Object

-            Dim insRS As Object

-            Dim field_idx As Integer

-                        

-            get_sql = "SELECT * FROM " & db(i).Name

-            Set getRS = CreateObject("ADODB.Recordset")

-            Set insRS = CreateObject("ADODB.Recordset")

-            insRS.Open db(i).Name, to_db, 2, 2

-

-            getRS.Open get_sql, from_db

-            

-            If Not getRS.BOF Then

-                Do While Not getRS.EOF

-                    insRS.addnew

-                    Dim fld_name As String

-                    

-                    For field_idx = 1 To UBound(db(i).Fields)

-                        fld_name = db(i).Fields(field_idx)

-                        insRS(fld_name) = getRS(fld_name)

-                    Next field_idx

-                    

-                    insRS("rm_id") = new_rm_id

-                    insRS.Update

-                    getRS.MoveNext

-                Loop

-            

-            Else

-                'empty table

-                ' do nothing

-            End If

-            

-            

-        Next i

-        

-        dbCloseOpenedConnection from_db

-    Next rm_idx

-    

-    dbCloseOpenedConnection to_db

-End Sub

-

-Function dbMergeRM(from_dbConnection As Object, to_dbConnection As Object) As Long

-

-    Dim getRecordset As Object

-    Dim getREPData_SQL As String

-    Dim REP_fn As String

-    Dim REP_ln As String

-    Dim REP_region As String

-    Dim REP_city As String

-

-

-    getREPData_SQL = "SELECT * FROM reg_man"

-    Set getRecordset = CreateObject("ADODB.Recordset")

-    

-    getRecordset.Open getREPData_SQL, from_dbConnection

-        

-        If Not getRecordset.BOF Then

-            REP_fn = getRecordset("firstname")

-            REP_ln = getRecordset("lastname")

-            REP_city = getRecordset("city")

-            REP_region = getRecordset("region")

-        Else

-            MsgBox "There is no information about Regional Manager! This database cannot be merged!!!"

-            dbMergeRM = -1

-            Exit Function

-        End If

-    

-    Dim insertRecordset As Object

-    Set insertRecordset = CreateObject("ADODB.Recordset")

-        

-    insertRecordset.Open "reg_man", to_dbConnection, 2, 2

-    insertRecordset.addnew

-        

-    insertRecordset("firstname") = REP_fn

-    insertRecordset("lastname") = REP_ln

-    insertRecordset("region") = REP_region

-    insertRecordset("city") = REP_city

-    insertRecordset.Update

-    insertRecordset.MoveLast

-    'new ID

-    dbMergeRM = insertRecordset("mgr_id")

-    

-End Function

-

-Sub cmDataImport()

-    Dim def_dir As String

-    Dim flist() As String

-    Dim i As Integer

-

-    def_dir = GetWBPath(ThisWorkbook.FullName)

-    If GetImportDirectory(def_dir, flist) Then

-        Dim ImpMask() As String

-        ImpMask = Split(flist(1), Chr(95), Compare:=vbBinaryCompare)

-        flist(1) = ImpMask(0) & "*"

-        Dim db_list() As String

-        i = GetDBList(flist(), db_list)

-        

-        If i > 0 Then

-            ImportFromRegionalManagers db_list, GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-        End If

-    End If

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    ThisWorkbook.Worksheets(PRJ_QTR_SHEET).Select

-End Sub

-

-

-<<<<<<
-======================
-PRJ_QTR
->>>>>>
-Attribute VB_Name = "PRJ_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CPRJ_QT As Integer = 0

-Const CPRJ_ID As Integer = 1

-Const CPRJ_PLN As Integer = 2

-Const CPRJ_FCT As Integer = 3

-Const CPRJ_BDG As Integer = 4

-Const CPRJ_CNT As Integer = 5

-Const CPRJ_BEDS As Integer = 6

-Const CPRJ_HIR As Integer = 7

-Const CPRJ_TER As Integer = 8

-Const CPRJ_CRD As Integer = 9

-Const CPRJ_CLXN_BDG As Integer = 10

-Const CPRJ_CLXN_NMG As Integer = 11

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Const LOCAL_ENT_DATE As String = "B11"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("PRJ_QTR")

-        s = "Все регионы, " & .getEnt_date()

-    End With

-    

-    MakeChartTitle = s

-End Function

-

-Sub update_history()

-    Dim objQTR() As tREGION

-    Dim i As Long

-    Dim r As Range

-

-

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    

-    i = GetRGN_COMM_DATA(objQTR(), 0)

-    

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CPRJ_QT) = objQTR(i).ent_date

-            r.Offset(i - 1, CPRJ_ID) = ""

-            r.Offset(i - 1, CPRJ_PLN) = objQTR(i).sale_PLAN

-            r.Offset(i - 1, CPRJ_FCT) = objQTR(i).total_SALE

-            r.Offset(i - 1, CPRJ_BDG) = objQTR(i).total_BDGT

-            r.Offset(i - 1, CPRJ_CNT) = objQTR(i).total_LPU

-            r.Offset(i - 1, CPRJ_BEDS) = objQTR(i).total_REP

-            r.Offset(i - 1, CPRJ_HIR) = objQTR(i).total_HIR

-            r.Offset(i - 1, CPRJ_TER) = objQTR(i).total_TER

-            r.Offset(i - 1, CPRJ_CRD) = objQTR(i).total_ACS

-            If objQTR(i).total_BDGT <> 0 Then

-                r.Offset(i - 1, CPRJ_CLXN_BDG) = objQTR(i).total_SALE / objQTR(i).total_BDGT

-            End If

-            If objQTR(i).total_BDGT_NMG <> 0 Then

-                r.Offset(i - 1, CPRJ_CLXN_NMG) = objQTR(i).total_SALE / objQTR(i).total_BDGT_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_PAT_QTR_PRJ()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(PRJ_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CPRJ_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CPRJ_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CPRJ_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CPRJ_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CPRJ_CRD + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-

-Sub Draw_PLN_QTR_PRJ()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(PRJ_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CPRJ_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CPRJ_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CPRJ_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CPRJ_FCT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PLN_QTR").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Draw_BDGT_QTR_PRJ()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets(PRJ_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CPRJ_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CPRJ_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CPRJ_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CPRJ_CLXN_NMG + 1)

-        End If

-    Next i

-    Worksheets("CHRT_BDGT_QTR").Range("title") = MakeChartTitle

-End Sub

-

-Public Sub cbxPRJ_QtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR_PRJ

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR_PRJ

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR_PRJ

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = PRJ_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-Private Sub Worksheet_Activate()

-

-    Protect UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("RM_ACTION") = 2

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CRow_Width Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CPRJ_QT + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    If r = "" Then

-        Worksheets(VAR_SHEET).Range("PRJ_ACTION") = 2

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        Worksheets(VAR_SHEET).Range("PRJ_ACTION") = 2

-        Range("LAST_FOCUS") = currRange.address

-        With Worksheets("REP_LIST")

-            .Range("ret_addr") = "PRJ_QTR"

-            .Range("ent_date") = r

-            .Range("VIEW_ONLY") = True

-        End With

-    End If

-    Cancel = True

-    btPRJ_QTR_Do_IT ' old btRM_OTR_DO_IT

-End Sub

-

-<<<<<<
-======================
-RM_LIST
->>>>>>
-Attribute VB_Name = "RM_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Const LOCAL_ENT_DATE As String = "C10"

-

-Sub PrintCopy()

-    Range("A1:N33").CopyPicture xlScreen, xlBitmap

-End Sub

-

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-

-Public Function getCurrentRM_ID() As Long

-    Dim r As Range

-

-    With Worksheets("RM_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CRM_ID)

-    End With

-

-    getCurrentRM_ID = r

-End Function

-

-Public Sub RM_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("PM_CHR_IDX")

-        Case 1

-            Rm_Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Rm_Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Rm_Draw_PAT_LPU_A

-            With Worksheets("CHRT_PAT_LPU_A")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU_A"

-

-        Case 4

-            Rm_Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "RM_LIST"

-            End With

-

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectRM_QTR(rm_id As Long)

-    Dim vo As Boolean

-

-    Range("JUMP") = "RM_QTR"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("RM_QTR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "RM_LIST"

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Public Sub SelectREP_LIST(rm_id As Long)

-    Dim vo As Boolean

-

-    Range("JUMP") = "REP_LIST"

-

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("REP_LIST")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "RM_LIST"

-        .setEnt_date (getEnt_date())

-        .Range("RM_ID") = rm_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateRMList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Sub UpdateRMList()

-    Dim rmcd() As tRMID_COMMON

-

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-

-    ent_date = getEnt_date

-

-    i = Get_RM_CommonList_by_QTR(rmcd(), ent_date)

-

-    With ThisWorkbook.Worksheets("RM_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-

-        For i = 1 To UBound(rmcd)

-            r.Offset(i - 1, CRM_NAME) = GetRegionName(rmcd(i).rm.Region)

-            r.Offset(i - 1, CRM_ID) = rmcd(i).rm.rm_id

-            r.Offset(i - 1, CRM_BEDS) = rmcd(i).rgcd(1).total_BEDS

-            r.Offset(i - 1, CRM_BDGT) = rmcd(i).rgcd(1).total_BDGT

-            r.Offset(i - 1, CRM_NMG) = rmcd(i).rgcd(1).total_BDGT_NMG

-            r.Offset(i - 1, CRM_HIR) = rmcd(i).rgcd(1).total_HIR

-            r.Offset(i - 1, CRM_TER) = rmcd(i).rgcd(1).total_TER

-            r.Offset(i - 1, CRM_CAR) = rmcd(i).rgcd(1).total_ACS

-            r.Offset(i - 1, CRM_FACT) = rmcd(i).rgcd(1).total_SALE

-            r.Offset(i - 1, CRM_PLAN) = rmcd(i).rgcd(1).sale_PLAN

-            

-            With rmcd(i).rgcd(1)

-                r.Offset(i - 1, CRM_PAT_LPU) = .total_HIR + .total_TER + .total_ACS

-            End With

-            

-            r.Offset(i - 1, CRM_BDGT_1) = rmcd(i).rgcd(1).total_BDGT

-            If rmcd(i).rgcd(1).total_BDGT > 0 Then

-                r.Offset(i - 1, CRM_BDGT_1 + 1) = rmcd(i).rgcd(1).total_SALE / rmcd(i).rgcd(1).total_BDGT

-            End If

-            If r.Offset(i - 1, CRM_BDGT_1 + 1) > 1 Then

-                r.Offset(i - 1, CRM_BDGT_1 + 1) = 1

-            End If

-

-        Next i

-    End If

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.count > 1 And r_sel.Columns.count < CINP_WIDTH Or r_sel.Rows.count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim rep_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    ent_date = getEnt_date

-

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    Set r = Range(CRM_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CRM_AREA).row, CRM_ID)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    rep_id = r

-

-    i = Range(Range("LAST_FOCUS")).Column - Range(CRM_AREA).Column

-

-    If i < 4 Then

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 1

-    Else

-        Worksheets(VAR_SHEET).Range("REP_LST_DETALS").Value = 2

-    End If

-

-    If rep_id = 0 Then

-        Range("LAST_FOCUS") = Range(CRM_AREA).address

-    End If

-

-    If rep_id = 0 Then

-        i = CRM_NAME

-        Range("JUMP") = ""

-    Else

-        btRM_LIST_DO_IT

-    End If

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-<<<<<<
-======================
-mPRJ_QTR
->>>>>>
-Attribute VB_Name = "mPRJ_QTR"

-Sub btPRJ_QTR_Do_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    

-    idx = Worksheets(VAR_SHEET).Range("PRJ_ACTION")

-    ent_date = Worksheets(PRJ_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            cmDataImport

-        Case 2

-            Worksheets("RM_LIST").setEnt_date (Worksheets("PRJ_QTR").getEnt_date())

-            Worksheets("RM_LIST").Range("ret_addr") = "PRJ_QTR"

-            Worksheets("RM_LIST").Select

-        Case 3

-            cmNewReport

-    End Select

-    Worksheets(VAR_SHEET).Range("PRJ_ACTION") = 2

-End Sub

-

-

-<<<<<<
-======================
-mRM_LIST
->>>>>>
-Attribute VB_Name = "mRM_LIST"

-Option Explicit

-

-Public Const CRM_AREA As String = "B12"

-Public Const CRM_NAME As Integer = 0

-Public Const CRM_NAME1 As Integer = 1

-Public Const CRM_NAME2 As Integer = 2

-Public Const CRM_ID As Integer = 3

-Public Const CRM_BEDS As Integer = 4

-Public Const CRM_BDGT As Integer = 5

-Public Const CRM_NMG As Integer = 6

-Public Const CRM_HIR As Integer = 7

-Public Const CRM_TER As Integer = 8

-Public Const CRM_CAR As Integer = 9

-Public Const CRM_FACT As Integer = 10

-Public Const CRM_PLAN As Integer = 11

-Public Const CRM_PAT_LPU As Integer = 16

-Public Const CRM_BDGT_1 As Integer = 17

-

-

-Const LOCAL_ENT_DATE As String = "C10"

-Public Function getEnt_date() As String

-    getEnt_date = Range(LOCAL_ENT_DATE)

-End Function

-

-Public Function setEnt_date(ent_date As String) As String

-    Range(LOCAL_ENT_DATE) = ent_date

-End Function

-

-Sub EditREP(CRM As tREPID, ent_date As String)

-    NoFunc

-End Sub

-

-Function MakeChartTitle() As String

-    Dim s As String

-    With Worksheets("RM_LIST")

-        s = "Регионы, " & .getEnt_date()

-    End With

-    

-    MakeChartTitle = s

-End Function

-

-Sub Rm_Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_LPU_BBL").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rm_Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        If src.Cells(i, CRM_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRM_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRM_FACT + 1)

-        End If

-    Next i

-    

-    Worksheets("CHRT_PIE").Range("title") = MakeChartTitle

-

-End Sub

-

-Sub Rm_Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CRM_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRM_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRM_HIR + 1)

-            psum = psum + src.Cells(i, CRM_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRM_TER + 1)

-            psum = psum + src.Cells(i, CRM_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRM_CAR + 1)

-            psum = psum + src.Cells(i, CRM_CAR + 1)

-            dst.Cells(i, 5) = psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU").Range("title") = MakeChartTitle

-    

-End Sub

-

-Sub Rm_Draw_PAT_LPU_A()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("RM_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU_A").Range("CHRT_PAT_LPU_DATA")

-

-    dst.ClearContents

-

-    For i = 1 To src.Rows.count

-        psum = 0

-        If src.Cells(i, CRM_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CRM_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CRM_HIR + 1)

-            psum = psum + src.Cells(i, CRM_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CRM_TER + 1)

-            psum = psum + src.Cells(i, CRM_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CRM_CAR + 1)

-            psum = psum + src.Cells(i, CRM_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CRM_PAT_LPU + 1) - psum

-        End If

-    Next i

-    

-    Worksheets("CHRT_PAT_LPU_A").Range("title") = MakeChartTitle

-    

-End Sub

-

-Sub btRM_LIST_RET_IT()

-    With Worksheets("RM_LIST")

-        .setEnt_date ("")

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = "PRJ_QTR"

-    End With

-    ThisWorkbook.Worksheets("PRJ_QTR").Activate

-End Sub

-

-

-Sub btRM_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim rm_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("RM_LIST_ACTION")

-    With Worksheets("RM_LIST")

-        rm_id = .getCurrentRM_ID()

-        

-        Select Case i

-            Case 1:

-                .SelectRM_QTR rm_id

-            Case 2:

-                .SelectREP_LIST rm_id

-            End Select

-    End With

-    

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-

-

-

-

-<<<<<<
-Project Name : 'ClexaneMR'
-Quirk - duff tag length======================
-Regs
->>>>>>
-Attribute VB_Name = "Regs"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-

-

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Dim AppRunEnable As New cEnableRun

-Dim MyAppEvents As New cAppEvents

-

-Private Sub Workbook_Open()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).ClearRepName

-    

-    Application.EnableEvents = True

-    Set MyAppEvents.app = Application

-    

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    Application.ScreenUpdating = False

-    

-    MyAppEvents.CheckWorkBooksArround ThisWorkbook

-    

-    cmSetStandaloneMode

-    

-    AppRunEnable.EnableRun ESTIMATION_DATE, Now

-    

-    Application.ScreenUpdating = True

-    

-    If CheckUser Then

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = False

-        ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-        ThisWorkbook.Worksheets(REP_QTR_SHEET).update_history

-        Application.Calculate

-    End If

-End Sub

-

-Private Sub Workbook_BeforeClose(Cancel As Boolean)

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE") = True

-    

-    ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    

-    Dim RestMode As Boolean

-    RestMode = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE")

-    

-    If ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE").Value = False Then

-        Application.DisplayAlerts = False

-        Application.ScreenUpdating = False

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=False

-'        If RestMode Then

-            ThisWorkbook.Saved = True

-'        Else

-'            ThisWorkbook.Save

-'        End If

-    End If

-    If RestMode Then

-        xlRestoreView

-        ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = False

-    End If

-    Application.Caption = Empty

-    Application.CommandBars(STDBAR_NAME).Reset

-    

-End Sub

-

-Private Sub Workbook_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

-    Cancel = Not ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE")

-End Sub

-

-Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

-    Dim MaxX, MaxY As Integer

-    With ThisWorkbook.Worksheets(REP_QTR_SHEET)

-        MaxX = .Range(BOTTOM_RIGH_WINDOW_CORNER).Left

-        MaxY = .Range(BOTTOM_RIGH_WINDOW_CORNER).Top

-    End With

-

-    With ThisWorkbook.Application

-        .ScreenUpdating = False

-        .WindowState = xlNormal

-        .Height = MaxY

-        .Width = MaxX

-    End With

-End Sub

-

-

-

-

-

-<<<<<<
-======================
-REP_QTR
->>>>>>
-Attribute VB_Name = "REP_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Const CINP_AREA As String = "B14"

-Const CQTR_QT As Integer = 0

-Const CQTR_ID As Integer = 1

-Const CQTR_PLN As Integer = 2

-Const CQTR_FCT As Integer = 3

-Const CQTR_BDG As Integer = 4

-Const CQTR_CNT As Integer = 5

-Const CQTR_BEDS As Integer = 6

-Const CQTR_HIR As Integer = 7

-Const CQTR_TER As Integer = 8

-Const CQTR_CRD As Integer = 9

-Const CQTR_CLXN_BDG As Integer = 10

-Const CQTR_CLXN_NMG As Integer = 11

-Const CQTR_PAT_ALL As Integer = 16

-Const CQTR_BDGT_ALL As Integer = 17

-

-

-Const CRow_Start As Integer = 2

-Const CRow_Finish As Integer = 13

-Const CRow_Width As Integer = CRow_Finish - CRow_Start + 1

-

-Dim currRange As Range

-

-Sub ClearRepName()

-    Unprotect

-    Range("D4") = ""

-    Range("D5") = ""

-    Range("H4") = ""

-    Range("H5") = ""

-End Sub

-

-Sub update_history()

-    Dim objQTR() As tQTR

-    Dim i As Long

-    Dim r As Range

-    Dim cRep As tREP

-    

-    cRep = GetREPRecord

-    Range("D4") = cRep.LastName

-    Range("D5") = cRep.FirstName

-    

-    Range("H4") = GetRegionName(cRep.Region)

-    Range("H5") = GetCityName(cRep.Region, cRep.City)

-    

-    Range("REP_QTR_INPUT_DATA").ClearContents

-    i = GetAll_QTR_Records(objQTR, "%")

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(objQTR)

-            r.Offset(i - 1, CQTR_QT) = objQTR(i).entry_date

-        Next i

-    End If

-    Dim qcd() As tQTR_COMMON

-    i = Get_QTR_CommonList(qcd)

-    If i > 0 Then

-        Set r = Range(CINP_AREA)

-        For i = 1 To UBound(qcd)

-            r.Offset(i - 1, CQTR_QT) = qcd(i).qtr.entry_date

-            r.Offset(i - 1, CQTR_ID) = qcd(i).qtr.id

-            r.Offset(i - 1, CQTR_PLN) = qcd(i).qtr.sale_plan

-            r.Offset(i - 1, CQTR_FCT) = qcd(i).c_sale_ALL

-            r.Offset(i - 1, CQTR_BDG) = qcd(i).c_bdgt_LPU

-            r.Offset(i - 1, CQTR_CNT) = qcd(i).i_lcd

-            r.Offset(i - 1, CQTR_BEDS) = qcd(i).c_beds

-            r.Offset(i - 1, CQTR_HIR) = qcd(i).c_pat_HIR

-            r.Offset(i - 1, CQTR_TER) = qcd(i).c_pat_TER

-            r.Offset(i - 1, CQTR_CRD) = qcd(i).c_pat_CRD

-            If qcd(i).c_bdgt_LPU <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_BDG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_LPU

-            End If

-            If qcd(i).c_bdgt_NMG <> 0 Then

-                r.Offset(i - 1, CQTR_CLXN_NMG) = qcd(i).c_sale_ALL / qcd(i).c_bdgt_NMG

-            End If

-        Next i

-    End If

-End Sub

-

-Sub Draw_BBL_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-

-End Sub

-

-Sub Draw_PAT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PAT_QTR").Range("CHRT_PAT_QTR_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CQTR_CRD + 1)

-        End If

-    Next i

-End Sub

-

-

-Sub Draw_PLN_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_PLN_QTR").Range("CHRT_PLN_QTR_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_PLN + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_FCT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_BDGT_QTR()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Set dst = Worksheets("CHRT_BDGT_QTR").Range("CHRT_BDGT_QTR_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CQTR_QT + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CQTR_QT + 1)

-            dst.Cells(i, 2) = src.Cells(i, CQTR_CLXN_BDG + 1)

-            dst.Cells(i, 3) = src.Cells(i, CQTR_CLXN_NMG + 1)

-        End If

-    Next i

-End Sub

-

-Public Sub cbxRepQtrChart_Change()

-    Dim idx As Integer

-    Dim jmp_addr As String

-    idx = ThisWorkbook.Worksheets(VAR_SHEET).Range("QTR_CHR_IDX")

-    Select Case idx

-        Case 1

-            Draw_PAT_QTR

-            jmp_addr = "CHRT_PAT_QTR"

-        Case 2

-            Draw_PLN_QTR

-            jmp_addr = "CHRT_PLN_QTR"

-        Case 3

-            Draw_BDGT_QTR

-            jmp_addr = "CHRT_BDGT_QTR"

-    End Select

-    With ThisWorkbook.Worksheets(jmp_addr)

-        .Range("ret_addr") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(jmp_addr).Activate

-End Sub

-

-

-Private Sub Worksheet_Activate()

-  

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Set currRange = Range(CINP_AREA)

-    Range("LAST_FOCUS") = CINP_AREA

-

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    update_history

-    Range("QTR_SEL") = Range("REP_QTR_INPUT_DATA").Cells(1, 1)

-    currRange.Select

-    

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.Count > 1 And r_sel.Columns.Count < CRow_Width Or r_sel.Rows.Count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.Count = 1 Then

-        Set currRange = r_sel.Cells(1, 1)

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("REP_QTR_INPUT_DATA")

-    chk_input_range = r.row <= (a.Rows.Count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.Count + a.Column) And r.Column >= a.Column

-End Function

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("REP_QTR_INPUT_DATA")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CRow_Start), Cells(rs.row, CRow_Finish))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CRow_Start), Cells(r.row, CRow_Finish)).Select

-    End If

-    Dim ent_date As String

-    ent_date = r.Cells(1, 1)

-    Range("QTR_SEL") = ent_date

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-

-    is_input_range = INPUT_NO

-

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim QTR_ID As Long

-    Dim ent_date As String

-    Dim i As Integer

-

-    Set r = Range(CINP_AREA).Cells(currRange.row - Range(CINP_AREA).row + 1, CQTR_ID + 1)

-

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-

-    i = currRange.Column - Range(CINP_AREA).Column

-    

-    QTR_ID = r

-

-    If QTR_ID = 0 Then

-        Worksheets(VAR_SHEET).Range("USER_ACTION") = 1

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    Else

-        If i > CQTR_FCT Then

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-            Range("LAST_FOCUS") = currRange.address

-        Else

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 3

-            Range("LAST_FOCUS") = currRange.address

-        End If

-    End If

-    Cancel = True

-    btHomeDo_IT

-End Sub

-

-<<<<<<
-======================
-mRep_QTR
->>>>>>
-Attribute VB_Name = "mRep_QTR"

-Option Explicit

-

-Sub DO_New_qtr()

-    Dim res As Variant

-    Dim objQTR As tQTR

-    Dim s As String

-    s = GetLastQtr

-    objQTR.entry_date = GetNextQTR(s)

-    

-    If objQTR.entry_date = "" Then

-        Exit Sub

-    End If

-    

-    DO_Price_qtr objQTR.entry_date

-

-End Sub

-

-Sub DO_Price_qtr(ent_date As String)

-    If ent_date = "" Then

-        DO_New_qtr

-    Else

-        Dim qtr As tQTR

-        Dim res As Integer

-        

-        qtr = Get_QTR_Record(ent_date)

-        

-        If qtr.id = 0 Then

-            qtr.entry_date = ent_date

-    

-            With Worksheets(VAR_SHEET)

-                qtr.ClxnH20mg = .Range("ClxnH20mg")

-                qtr.ClxnH40mg = .Range("ClxnH40mg")

-                qtr.ClxnT40mg = .Range("ClxnT40mg")

-                qtr.ClxnC_ACS = .Range("ClxnC_ACS")

-                qtr.ClxnC_IM = .Range("ClxnC_IM")

-            End With

-        End If

-        

-        Dim dlg_nq As dlg_nextQTR

-        Set dlg_nq = New dlg_nextQTR

-        

-        With dlg_nq

-            .tb_qtr_name = qtr.entry_date

-            .tb_bdgt_avts = qtr.sale_plan

-            .tb_qtr_name = qtr.entry_date

-            .tb_ClxnH20mg = qtr.ClxnH20mg

-            .tb_ClxnH40mg = qtr.ClxnH40mg

-            .tb_ClxnT40mg = qtr.ClxnT40mg

-            .tb_ClxnC_ACS = qtr.ClxnC_ACS

-            .tb_ClxnC_IM = qtr.ClxnC_IM

-        End With

-        

-        dlg_nq.Show

-        res = dlg_nq.Tag

-        

-        If res = vbOK Then

-            With dlg_nq

-                If Not IsNumeric(.tb_bdgt_avts) Then

-                    MsgBox "Введите план продаж", vbOK, PROGRAM_NAME

-                Else

-                    If .tb_bdgt_avts = 0 Then

-                        MsgBox "Введите план продаж", vbOK, PROGRAM_NAME

-                        Exit Sub

-                    End If

-                End If

-                Dim bool As Boolean

-                bool = IsNumeric(.tb_ClxnH20mg) _

-                    And IsNumeric(.tb_ClxnH40mg) _

-                    And IsNumeric(.tb_ClxnT40mg) _

-                    And IsNumeric(.tb_ClxnC_ACS) _

-                    And IsNumeric(.tb_ClxnC_IM)

-                If Not bool Then

-                    MsgBox "Вводите правильно цыфры", vbOK, PROGRAM_NAME

-                    Exit Sub

-                End If

-                qtr.sale_plan = .tb_bdgt_avts

-                qtr.entry_date = .tb_qtr_name

-                qtr.ClxnH20mg = .tb_ClxnH20mg

-                qtr.ClxnH40mg = .tb_ClxnH40mg

-                qtr.ClxnT40mg = .tb_ClxnT40mg

-                qtr.ClxnC_ACS = .tb_ClxnC_ACS

-                qtr.ClxnC_IM = .tb_ClxnC_IM

-            End With

-            Insert_QTR_Record qtr

-        End If

-    End If

-End Sub

-

-Sub DO_Edit_qtr(ent_date As String)

-    If ent_date = "" Then

-        DO_New_qtr

-    Else

-        With ThisWorkbook.Worksheets("LPU_LIST")

-            .Range("VIEW_ONLY") = False

-            .Range("ent_date") = ent_date

-            .Select

-        End With

-    End If

-End Sub

-

-Sub DO_Delete_qtr(ent_date As String)

-    If ent_date <> "" Then

-        Dim i As Integer

-        i = MsgBox("Удалить данные за период [" & ent_date & "]?", vbDefaultButton2 + vbOKCancel, PROGRAM_NAME)

-        If i = vbOK Then

-            Dim objQTR As tQTR

-            If ent_date <> "" Then

-                objQTR.entry_date = ent_date

-                objQTR = Get_QTR_Record(ent_date)

-                Delete_QTR_Record objQTR

-                Worksheets(TITLE_SHEET).Select

-                Worksheets(REP_QTR_SHEET).Select

-            End If

-        End If

-    End If

-    Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-End Sub

-

-

-Sub btHomeDo_IT()

-    Dim ent_date As String

-    Dim idx As Integer

-    idx = Worksheets(VAR_SHEET).Range("USER_ACTION")

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    Select Case idx

-        Case 1

-            DO_New_qtr

-            ' Обновляем экран

-        Case 2

-            DO_Edit_qtr ent_date

-        Case 3

-            DO_Price_qtr ent_date

-        Case 4

-            dbExport

-            Worksheets(VAR_SHEET).Range("USER_ACTION") = 2

-    End Select

-    If idx <> 2 Then

-        With ThisWorkbook

-            .Worksheets(TITLE_SHEET).Select

-            .Worksheets(REP_QTR_SHEET).Select

-        End With

-    End If

-End Sub

-

-Sub Delete_qtr()

-    Dim ent_date As String

-    ent_date = Worksheets(REP_QTR_SHEET).Range("QTR_SEL")

-    DO_Delete_qtr ent_date

-End Sub

-

-<<<<<<
-======================
-mConst
->>>>>>
-Attribute VB_Name = "mConst"

-Option Explicit

-

-Public Const PROGRAM_NAME As String = "Aventis Pharma Clexane[MR]"

-Public Const PROGRAM_VERSION As String = "version 1.6"

-Public Const PROGRAM_FILENAME As String = "clexane-mr"

-Public Const PROGRAM_EXPORTNAME As String = "mr-ex-"

-Public Const PROGRAM_DATAEXT As String = ".mdb"

-

-Public Const NO_ESTIMATION_DATE As Long = -1

-Public Const DEVELOP_MODE As Boolean = True

-

-'Public Const ESTIMATION_DATE As Long = 20030329

-Public Const ESTIMATION_DATE As Long = NO_ESTIMATION_DATE

-

-Public Const BOTTOM_RIGH_WINDOW_CORNER As String = "O40"

-'Public Const CITY_TABLES As String = "N30"

-

-Public Const VAR_SHEET As String = "Var"

-Public Const REGS_SHEET As String = "Regs"

-Public Const TITLE_SHEET As String = "title"

-Public Const REP_QTR_SHEET As String = "REP_QTR"

-

-' Костанты листа REP_QTR

-Public Const DEF_IDX_REGION As Integer = 1

-Public Const DEF_IDX_CITY As Integer = 2

-

-<<<<<<
-======================
-mTools
->>>>>>
-Attribute VB_Name = "mTools"

-Option Explicit

-

-Function MakeNewFileName(f_name As String, s_name As String, u_city As String) As String

-    MakeNewFileName = s_name & "." & f_name & "." & u_city & ".xls"

-End Function

-

-Sub dummy()

-End Sub

-

-Function Double2Str(ByVal d As Double, ByVal precision As Integer, Optional Delim As String = ".") As String

-    Dim s As String

-    If Not precision > 0 Then

-        s = Round(d)

-    Else

-        Dim i As Integer

-        i = Fix(d)

-        s = i & Delim

-        d = Abs(d - i)

-        Do

-            precision = precision - 1

-            d = d * 10

-            If precision > 0 Then

-                i = Fix(d)

-            Else

-                i = Round(d)

-            End If

-            If i < 1 Then

-                s = s & "0"

-            Else

-                s = s & i

-                d = d - i

-            End If

-        Loop While precision > 0

-    End If

-    Double2Str = s

-End Function

-

-Function GetWBPath(FullName As String) As String

-    Dim pos, s_len As Integer

-    pos = InStrRev(FullName, "\")

-    s_len = Len(FullName)

-    GetWBPath = Left(FullName, pos)

-End Function

-

-Function GetLinesCount(ByVal Location As Range) As Integer

-    Dim n As Integer

-    n = 0

-    Do While IsEmpty(Location.Offset(n, 0).Value) = False

-        n = n + 1

-    Loop

-    GetLinesCount = n

-End Function

-

-Function GetStrIndex(r As Range, s As String)

-    Dim n As Integer

-    GetStrIndex = -1

-    For n = 1 To r.Count

-        If r.Offset(0, n - 1).Value = s Then

-            GetStrIndex = n - 1

-            Exit Function

-        End If

-    Next n

-End Function

-

-Sub tool_RestoreCursor()

-    Application.Cursor = xlDefault

-End Sub

-

-Sub SetDesignFlagOn()

-    Dim sh As Worksheet

-    

-    Application.ScreenUpdating = False

-    For Each sh In Worksheets

-        sh.Unprotect

-        sh.Visible = xlSheetVisible

-    Next sh

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-    Application.ScreenUpdating = True

-End Sub

-

-Sub SetDesignFlagOff()

-    Application.ScreenUpdating = False

-    

-    Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = False

-    

-    Dim sh As Worksheet

-    For Each sh In Worksheets

-        If sh.name = VAR_SHEET Or sh.name = REGS_SHEET Then

-            sh.Visible = xlSheetVeryHidden

-            sh.Unprotect

-        Else

-            sh.Protect UserInterfaceOnly:=True

-        End If

-    Next sh

-    Application.ScreenUpdating = True

-End Sub

-

-

-<<<<<<
-======================
-Var
->>>>>>
-Attribute VB_Name = "Var"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-title
->>>>>>
-Attribute VB_Name = "title"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-LPU_LIST
->>>>>>
-Attribute VB_Name = "LPU_LIST"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-Const CINP_FIRST_R As Integer = 2

-Const CINP_LAST_R As Integer = 13

-Const CINP_WIDTH As Integer = CINP_LAST_R - CINP_FIRST_R + 1

-

-Public Function getEnt_date() As String

-    getEnt_date = Range("ent_date")

-End Function

-

-Public Function getCurrentLPU_ID() As Long

-    Dim r As Range

-    

-    With Worksheets("LPU_LIST")

-        Set r = .Range(CINP_AREA).Offset(.Range(.Range("LAST_FOCUS")).row - .Range(CINP_AREA).row, CLPU_ID)

-    End With

-    

-    getCurrentLPU_ID = r

-End Function

-

-Public Sub LPU_ViewChart()

-    Dim src As Range

-    Dim dst As Range

-    Select Case Worksheets(VAR_SHEET).Range("LPU_CHR_IDX")

-        Case 1

-            Draw_BBL_Chart

-            With Worksheets("CHRT_LPU_BBL")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_LPU_BBL"

-

-        Case 2

-            Draw_PAT_LPU

-            With Worksheets("CHRT_PAT_LPU")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            Range("JUMP") = "CHRT_PAT_LPU"

-

-        Case 3

-            Draw_PIE_Chart

-            With Worksheets("CHRT_PIE")

-                .Range("ret_addr") = "LPU_LIST"

-            End With

-            

-            Range("JUMP") = "CHRT_PIE"

-    End Select

-

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Activate

-    End If

-End Sub

-

-Public Sub SelectLPU_NAME(lpu_id As Long, ent_date As String)

-    If Range("VIEW_ONLY") = True Then

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    Dim cLPU As tLPU

-    If lpu_id = 0 Then

-        cLPU.id = 0

-        cLPU.rep_id = 0

-        cLPU.address = ""

-        cLPU.name = ""

-    Else

-        cLPU = Get_LPU_Record(lpu_id)

-    End If

-    EditLPU cLPU, getEnt_date

-    Worksheet_Activate

-End Sub

-        

-Sub SelectLPU_BDGT(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    If lpu_id = 0 Then

-        SelectLPU_NAME lpu_id, ent_date

-    Else

-        With ThisWorkbook.Worksheets("LPU_BDGT")

-            .Range("VIEW_ONLY") = vo

-            .Range("ret_addr") = "LPU_LIST"

-            .Range("ent_date") = ent_date

-            .Range("lpu_id") = lpu_id

-        End With

-    End If

-End Sub

-

-Sub SelectLPU_HIR(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_CLSN_HIR")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-                   

-Sub SelectLPU_TER(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_CLSN_TER")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-       

-Sub SelectLPU_C_ACS(lpu_id As Long, ent_date As String)

-    Dim vo As Boolean

-    vo = Range("VIEW_ONLY")

-    With ThisWorkbook.Worksheets("LPU_CLSN_C_ACS")

-        .Range("VIEW_ONLY") = vo

-        .Range("ret_addr") = "LPU_LIST"

-        .Range("ent_date") = ent_date

-        .Range("lpu_id") = lpu_id

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect UserInterfaceOnly:=True

-

-    If am_load_now Then

-        Exit Sub

-    End If

-

-    Range("LAST_FOCUS") = CINP_AREA

-

-    UpdateLPUList

-

-    InpRowSelect Range(Range("LAST_FOCUS"))

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim r_sel As Range

-    If Not chk_input_range(Target) Then

-        Set r_sel = Range(CINP_AREA)

-    Else

-        Set r_sel = Target

-    End If

-

-    If r_sel.Columns.Count > 1 And r_sel.Columns.Count < CINP_WIDTH Or r_sel.Rows.Count > 1 Then

-        Set r_sel = r_sel.Cells(1, 1)

-    End If

-

-    If r_sel.Count = 1 Then

-        Range("LAST_FOCUS") = r_sel.address

-        InpRowSelect r_sel

-    End If

-End Sub

-

-Function chk_input_range(r As Range) As Boolean

-    Dim a As Range

-    Set a = Range("LPU_LIST_INPUT")

-    chk_input_range = r.row <= (a.Rows.Count + a.row) And r.row >= a.row _

-    And r.Column <= (a.Columns.Count + a.Column) And r.Column >= a.Column

-End Function

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-    Dim r As Range

-    Dim lpu_id As Long

-    Dim ent_date As String

-    Dim i As Integer

-    

-    ent_date = getEnt_date

-    If ent_date = "" Then

-        Cancel = True

-        Exit Sub

-    End If

-    

-    Set r = Range(CINP_AREA).Offset(Range(Range("LAST_FOCUS")).row - Range(CINP_AREA).row, CLPU_ID)

-        

-    If Not chk_input_range(r) Then

-        Cancel = True

-        Exit Sub

-    End If

-    

-    lpu_id = r

-    

-    i = Range(Range("LAST_FOCUS")).Column - Range(CINP_AREA).Column

-    

-    If lpu_id = 0 Then

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-    End If

-    

-    If lpu_id = 0 Then

-        i = CLPU_NAME

-        Range("JUMP") = ""

-    End If

-    Select Case i

-        Case CLPU_NAME, CLPU_NAME1, CLPU_NAME2, CLPU_BEDS

-            SelectLPU_NAME lpu_id, ent_date

-            Range("JUMP") = ""

-

-        Case CLPU_NMG, CLPU_NFG, CLPU_PLAN, CLPU_FACT

-            SelectLPU_BDGT lpu_id, ent_date

-            Range("JUMP") = "LPU_BDGT"

-            

-        Case CLPU_HIR

-            SelectLPU_HIR lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_HIR"

-        

-        Case CLPU_TER

-            SelectLPU_TER lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_TER"

-        

-        Case CLPU_CAR

-            SelectLPU_C_ACS lpu_id, ent_date

-            Range("JUMP") = "LPU_CLSN_C_ACS"

-        

-        Case Else

-            Range("JUMP") = ""

-    End Select

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-    Cancel = True

-End Sub

-

-

-Sub InpRowSelect(rs As Range)

-    Dim r As Range

-    If is_input_range(rs, Range("LPU_LIST_INPUT")) > INPUT_NO Then

-        Set r = Range(Cells(rs.row, CINP_FIRST_R), Cells(rs.row, CINP_LAST_R))

-        r.Select

-    Else

-        Range("LAST_FOCUS") = Range(CINP_AREA).address

-        Set r = Range(CINP_AREA)

-        Range(Cells(r.row, CINP_FIRST_R), Cells(r.row, CINP_LAST_R)).Select

-    End If

-End Sub

-

-Function is_input_range(ByVal Target As Range, inputs As Range) As Integer

-    Dim r As Range

-    

-    is_input_range = INPUT_NO

-    

-    For Each r In inputs

-        If r.address = Target.address Then

-            is_input_range = INPUT_CHECK

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub UpdateLPUList()

-    Dim lcd() As tLPU_COMMON

-    

-    Dim ent_date As String

-    Dim i As Long

-    Dim r As Range

-    Dim t_sum As Long

-    Dim objQTR As tQTR

-    Dim cRep As tREP

-    

-    ' ent_date = "%" ' % - all records

-    ent_date = getEnt_date

-    

-    objQTR = Get_QTR_Record(ent_date)

-    i = Get_LPU_CommonQTR(lcd, objQTR)

-     

-    ' стираем ФИО

-    Range("C3:C4").ClearContents

-    cRep = GetREPRecord

-    

-    Range("C3") = cRep.LastName

-    Range("C4") = cRep.FirstName

-    Range("G3") = GetRegionName(cRep.Region)

-    Range("G4") = GetCityName(cRep.Region, cRep.City)

-    Range("G5") = objQTR.sale_plan

-    

-

-    

-    With ThisWorkbook.Worksheets("LPU_LIST")

-        .Range("LPU_LIST_INPUT").ClearContents

-        .Range("LPU_INPUT_EXT").ClearContents

-    End With

-

-    If i <> 0 Then

-        Set r = Range(CINP_AREA)

-        

-        For i = 1 To UBound(lcd)

-            r.Offset(i - 1, CLPU_NAME) = lcd(i).lpu.name

-            r.Offset(i - 1, CLPU_ID) = lcd(i).lpu.id

-            r.Offset(i - 1, CLPU_BEDS) = lcd(i).lpu.beds

-            

-         

-            r.Offset(i - 1, CLPU_NFG) = lcd(i).bdgt.bdgt_NFG

-            r.Offset(i - 1, CLPU_NMG) = lcd(i).bdgt.bdgt_NMG

-            r.Offset(i - 1, CLPU_PLAN) = lcd(i).bdgt.sale_plan

-            

-            r.Offset(i - 1, CLPU_HIR) = lcd(i).pat_HIR

-            r.Offset(i - 1, CLPU_TER) = lcd(i).pat_TER

-            r.Offset(i - 1, CLPU_CAR) = lcd(i).pat_CRD

-            r.Offset(i - 1, CLPU_FACT) = lcd(i).sale_ALL

-            r.Offset(i - 1, CLPU_PAT_LPU) = lcd(i).pat_LPU

-            r.Offset(i - 1, CLPU_BDGT) = lcd(i).bdgt_LPU

-            If lcd(i).bdgt_LPU > 0 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = lcd(i).sale_ALL / lcd(i).bdgt_LPU

-            End If

-            If r.Offset(i - 1, CLPU_BDGT + 1) > 1 Then

-                r.Offset(i - 1, CLPU_BDGT + 1) = 1

-            End If

-            

-        Next i

-    End If

-End Sub

-<<<<<<
-======================
-dlgPrint
->>>>>>
-Attribute VB_Name = "dlgPrint"

-Attribute VB_Base = "0{566B33D6-957A-43E4-8444-D8EA3889700C}{42EE65B8-F8C6-4F95-9F52-7738BF6FCEAD}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbAllSheets_Click()

-    If Me.cbAllSheets = True Then

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-        Me.cbSrcData = True

-    End If

-End Sub

-

-Private Sub cbMainBudget_Click()

-    If Me.cbMainBudget = False Then

-        Me.cbAllSheets = False

-        Me.cbSrcData = False

-    Else

-        Me.cbMainReport = True

-    End If

-End Sub

-

-Private Sub cbMainReport_Click()

-    If Me.cbMainReport = False Then

-        Me.cbAllSheets = False

-        Me.cbMainBudget = False

-        Me.cbSrcData = False

-    End If

-End Sub

-

-Private Sub cbSrcData_Click()

-    If Me.cbSrcData = False Then

-        Me.cbAllSheets = False

-    Else

-        Me.cbMainBudget = True

-        Me.cbMainReport = True

-    End If

-End Sub

-<<<<<<
-======================
-dbACS
->>>>>>
-Attribute VB_Name = "dbACS"

-Option Explicit

-

-Public Type tACS

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    patients_with_geparins As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objACS.ID <> 0 then updatre else insert

-Sub Insert_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objACS.id <> 0 Then

-        dbUpdate_ACS_Record dbConnection, objACS

-    Else

-        dbInsert_ACS_Record dbConnection, objACS

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_ACS_RecordsByLPU_ID(ByRef all_ACS_() As tACS, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_ACS_RecordsByLPU_ID = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, all_ACS_, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_ACS_Record(ByRef objACS As tACS)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_ACS_Record dbConnection, objACS

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub dbInsert_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_acs", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objACS

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("patients_with_geparins") = .patients_with_geparins

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objACS.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    Dim Update_SQL As String

-    

-    With objACS

-        Update_SQL = "UPDATE lpu_acs SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "patients_with_geparins=" & .patients_with_geparins & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_ACS_RecordsbyLPU_ID(dbConnection As Object, all_ACS() As tACS, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_ACS_SQL As String

-    Dim getAll_ACS_SQL As String

-    Dim ACS_Count As Long

-    ACS_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_ACS_SQL = "SELECT COUNT(*) AS ACS_TOTAL FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_ACS_SQL = "SELECT * FROM lpu_acs WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_ACS_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        ACS_Count = dbRecordset("ACS_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_ACS_RecordsbyLPU_ID = ACS_Count

-    

-    If ACS_Count > 0 Then

-        'we have records

-        ReDim all_ACS(1 To ACS_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_ACS_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_ACS As tACS

-                 With tmp_ACS

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .patients_with_geparins = dbRecordset("patients_with_geparins")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 all_ACS(index) = tmp_ACS

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_ACS_Record(dbConnection As Object, ByRef objACS As tACS)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE ID=" & objACS.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_acs " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_ACS_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_ACS_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_acs " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_HIR
->>>>>>
-Attribute VB_Name = "LPU_CLSN_HIR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-    

-        Dim objHir As tHIRURGIA

-        

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objHir

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .operations_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L9")

-                .patients_ambulator_clexan_20mg = Range("L10")

-                .patients_ambulator_clexan_40mg = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L19")

-                .patients_stationar_clexan_20mg = Range("L20")

-                .patients_stationar_clexan_40mg = Range("L21")

-            End With

-            Insert_Hir_Record objHir

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objHir.id = Range("rec_id")

-                    If objHir.id <> 0 Then

-                        Delete_Hir_Record objHir

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objHir As tHIRURGIA)

-    Dim qtr As tQTR

-    Dim formula As String

-

-    With objHir

-        Range("rec_id") = .id

-        Range("F6") = .operations_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L9") = .patients_ambulator_clexan

-        Range("L10") = .patients_ambulator_clexan_20mg

-        Range("I21") = .patients_stationar_nmg

-        Range("L19") = .patients_stationar_clexan

-        Range("L20") = .patients_stationar_clexan_20mg

-        

-        qtr = Get_QTR_Record(.entry_date)

-        formula = "=" & qtr.ClxnH20mg & "*($L$10+$L$20)+" & qtr.ClxnH40mg & "*($L$11+$L$21)"

-        Range("F11").formula = formula

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-    

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Range("h_DepFlag") = False

-    

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objHir() As tHIRURGIA

-        Dim i As Integer

-        i = GetAll_Hir_RecordsByLPU_ID(objHir, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.3

-        Else

-            SetupData objHir(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-

-    Dim s As String

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    Select Case iset.vType

-        Case INPUT_NO

-

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-

-            Application.ScreenUpdating = False

-

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-

-        Case INPUT_STRING

-

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-mSapes
->>>>>>
-Attribute VB_Name = "mSapes"

-Option Explicit

-

-Const SHAPE_COLOR As Integer = 1

-Const SHAPE_NAME As Integer = 2

-

-

-Sub ShapeView(r_sh_finite_state As Range)

-    Dim chk As Range

-    Dim s As String

-    Dim c, idx As Integer

-    For Each chk In r_sh_finite_state

-        idx = 0

-        If chk = "+" Then

-            c = chk.Offset(0, idx + SHAPE_COLOR)

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While c <> 0

-                ShapeFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s)), c

-                idx = idx + 2

-                c = chk.Offset(0, idx + SHAPE_COLOR)

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        Else

-            s = chk.Offset(0, idx + SHAPE_NAME)

-            Do While s <> ""

-                ShapeUnFill r_sh_finite_state.Worksheet.Shapes.Range(Array(s))

-                idx = idx + 2

-                s = chk.Offset(0, idx + SHAPE_NAME)

-            Loop

-        End If

-    Next chk

-End Sub

-

-Sub ShapeFill(sh As ShapeRange, ByVal color As Integer)

-    sh.Fill.Visible = msoTrue

-    sh.Fill.Solid

-    sh.Fill.ForeColor.SchemeColor = color

-    sh.Fill.Transparency = 0#

-End Sub

-

-Sub ShapeUnFill(sh As ShapeRange)

-    sh.Fill.Visible = msoFalse

-    sh.Fill.Transparency = 0#

-End Sub

-

-<<<<<<
-======================
-mCheck
->>>>>>
-Attribute VB_Name = "mCheck"

-Option Explicit

-

-Public Const INPUT_NO = 0

-Public Const INPUT_NUMBER = 1

-Public Const INPUT_PERCENT = 2

-Public Const INPUT_STRING = 3

-Public Const INPUT_CHECK = 4

-

-Public Const INP_IDX_TYPE = 1

-Public Const INP_IDX_NEXT = 2

-Public Const INP_IDX_MIN = 3

-Public Const INP_IDX_MAX = 4

-Public Const INP_IDX_DEP = 5

-Public Const INP_IDX_ALT = 7

-

-

-Public Type tInputSet

-    vType As Integer

-    vMin As Long

-    vMax As Long

-    rChk As String

-End Type

-

-Function is_input_cell(ByVal Target As Range, inputs As Range) As tInputSet

-    Dim t As Range

-    Dim iset As tInputSet

-    Dim test As Range

-    iset.vType = INPUT_NO

-    iset.vMin = 0

-    iset.vMax = 0

-    iset.rChk = ""

-    is_input_cell = iset

-

-' Закоментировать следующую сточку для работы

-'  Exit Function

-

-    Set test = Target.Cells(1, 1)

-    For Each t In inputs

-        If Range(t).Column = test.Column And Range(t).row = test.row Then

-            iset.vType = t.Offset(0, INP_IDX_TYPE).Value

-            Select Case iset.vType

-                Case INPUT_CHECK

-                    iset.rChk = t.Offset(0, INP_IDX_ALT)

-                Case INPUT_NUMBER, INPUT_PERCENT

-                    iset.vMin = t.Offset(0, INP_IDX_MIN).Value

-                    iset.vMax = t.Offset(0, INP_IDX_MAX).Value

-            End Select

-            is_input_cell = iset

-            Exit Function

-        End If

-    Next t

-End Function

-

-Function GetFocusAddress(ByVal r As Range, f_next As Range) As String

-    Dim chk, t As Range

-    

-    For Each chk In f_next

-        For Each t In r

-            If t.address = chk Then

-                GetFocusAddress = chk

-                Exit Function

-            End If

-            If Range(chk).Column = t.Column - 1 And Range(chk).row = t.row _

-            Or Range(chk).Column = t.Column And Range(chk).row = t.row - 1 _

-            Then

-                If Range(chk) <> "" Then

-                    If Range(chk) = 0 Then

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_ALT)).address

-                    Else

-                        GetFocusAddress = Range(chk.Offset(0, INP_IDX_NEXT)).address

-                    End If

-                Else

-                    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-                End If

-                Exit Function

-            End If

-        Next t

-    Next chk

-    GetFocusAddress = r.Worksheet.Range("DEF_FOCUS")

-End Function

-

-Sub SetDependet(r As Range, inputs As Range)

-    Dim chk As Range

-    Dim s, serr As String

-    Dim idx As Integer

-    Dim iset As tInputSet

-    Dim err_found As Boolean

-    

-    If r.Count > 1 Then

-        Exit Sub

-    End If

-    

-    err_found = False

-    For Each chk In inputs

-        idx = INP_IDX_DEP

-        

-        

-        iset.vType = chk.Offset(0, INP_IDX_TYPE).Value

-        Select Case iset.vType

-            Case INPUT_NUMBER, INPUT_PERCENT

-                iset.vMin = chk.Offset(0, INP_IDX_MIN).Value

-                iset.vMax = chk.Offset(0, INP_IDX_MAX).Value

-                

-                If Range(chk) > iset.vMax Then

-                    err_found = True

-                    Range(chk) = iset.vMax

-                    serr = "Выход за дозволенный диапазон [" & iset.vMin & ".." & iset.vMax & "]! Данные скорректированы."

-                End If

-                

-                If Range(chk) = "" Then

-                    s = chk.Offset(0, idx)

-                    Do While s <> ""

-                        Range(s) = ""

-                        idx = idx + 1

-                        s = chk.Offset(0, idx)

-                    Loop

-                End If

-        End Select

-    Next chk

-    If err_found Then

-        MsgBox serr, vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Function CheckInputData(inputs As Range) As Boolean

-    Dim r As Range

-    

-    CheckInputData = True

-    For Each r In inputs

-        If Range(r) = "" Then

-            CheckInputData = False

-            Exit Function

-        End If

-    Next r

-End Function

-

-Sub Check_Percent(Target As Range, Def_Val As Double)

-    Dim test, test2 As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    test2 = False

-    For Each r In Target

-        str = r

-        test = False

-        With WorksheetFunction

-            If Not .IsNumber(r) And r.Text <> "" Then

-                r = Def_Val

-                test = True

-            Else

-                test = (r > 1 Or r < 0)

-            End If

-        End With

-        test2 = test2 Or test

-    Next r

-    If test2 Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры от 0 до 100.", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-Sub Check_Int_Number(Target As Range, Def_Val As Long)

-    Dim err As Boolean

-    Dim str As String

-    Dim r As Range

-    

-    err = False

-    For Each r In Target

-        If r.Text <> "" Then

-            str = Target

-            If Not WorksheetFunction.IsNumber(Target) Then

-                Target = Def_Val

-                err = True

-            End If

-        End If

-    Next r

-    If err Then

-        MsgBox "Ошибка данных - '" & str & "'!  Используйте только цифры!", vbOKOnly, PROGRAM_NAME

-    End If

-End Sub

-

-

-<<<<<<
-======================
-LPU_CLSN_TER
->>>>>>
-Attribute VB_Name = "LPU_CLSN_TER"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub ClearData()

-    Dim r As Range

-    Set r = Range(Range("DEF_FOCUS"))

-    ClearSheetData r

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim objTer As tTERAPIA

-        

-        If Range(Range("DEF_FOCUS")) <> 0 Then

-            With objTer

-                .id = Range("rec_id")

-                .entry_date = Range("ent_date")

-                .lpu_id = Range("lpu_id")

-                .patients_per_quarter = Range("F6")

-                .risk_percent = Range("F8")

-                .patients_with_risk_ON = Range("C21")

-                .patients_ambulator = Range("F18")

-                .patients_ambulator_nmg = Range("I12")

-                .patients_ambulator_clexan = Range("L11")

-                .patients_stationar_nmg = Range("I21")

-                .patients_stationar_clexan = Range("L20")

-            End With

-            Insert_Ter_Record objTer

-            ClearData

-        Else

-            If Range("rec_id") <> 0 Then

-                If vbOK = MsgBox("Удалить данные из базы!", vbOKCancel, PROGRAM_NAME) Then

-                    objTer.id = Range("rec_id")

-                    If objTer.id <> 0 Then

-                        Delete_Ter_Record objTer

-                    End If

-                End If

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-        ClearData

-    End If

-

-    ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(objTer As tTERAPIA)

-    Dim qtr As tQTR

-    Dim formula As String

-    With objTer

-        Range("rec_id") = .id

-        Range("F6") = .patients_per_quarter

-        Range("F8") = .risk_percent

-        Range("C21") = .patients_with_risk_ON

-        Range("F18") = .patients_ambulator

-        Range("I12") = .patients_ambulator_nmg

-        Range("L11") = .patients_ambulator_clexan

-        Range("I21") = .patients_stationar_nmg

-        Range("L20") = .patients_stationar_clexan

-        

-        qtr = Get_QTR_Record(.entry_date)

-        formula = "=" & qtr.ClxnT40mg & "*($L$12+$L$20)"

-        Range("F11").formula = formula

-        

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Dim lpu As tLPU

-    Dim id As Long

-    

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    Range("h_DepFlag") = False

-    

-    id = Range("lpu_id").Value

-    lpu = Get_LPU_Record(id)

-    If lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = lpu.beds

-        Range("lpu_name") = lpu.name

-        Range("lpu_addr") = lpu.address

-

-        Dim objTer() As tTERAPIA

-        Dim i As Integer

-        i = GetAll_Ter_RecordsByLPU_ID(objTer, id, Range("ent_date"))

-        If i = 0 Then

-            Range("rec_id") = 0

-            Range("F8") = 0.25

-        Else

-            SetupData objTer(1)

-        End If

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    If Range("h_DepFlag") Then

-        Exit Sub

-    End If

-    

-    Dim s As String

-    Dim iset As tInputSet

-    

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    

-    Select Case iset.vType

-        Case INPUT_NO

-        

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-            

-            Application.ScreenUpdating = False

-            

-            Range("h_DepFlag") = True

-            SetDependet Target, Range("h_Inputs")

-            Range("h_DepFlag") = False

-            

-            ShapeView Range("h_check")

-            Application.ScreenUpdating = True

-

-        Case INPUT_PERCENT

-        

-        Case INPUT_STRING

-        

-        Case Else

-    End Select

-End Sub

-

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-    iset = is_input_cell(Target, Range("h_Inputs"))

-

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgAbout
->>>>>>
-Attribute VB_Name = "dlgAbout"

-Attribute VB_Base = "0{EBA94131-180E-4709-A2A3-B60D48987620}{47A860A1-BF92-4EBB-A333-AB7E83FAB868}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-

-Private Sub OK_Button_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-LPU_BDGT
->>>>>>
-Attribute VB_Name = "LPU_BDGT"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Public Sub SetDefFocus()

-    Range(Range("DEF_FOCUS")).Select

-End Sub

-

-Public Sub ClearData()

-    ClearSheetData

-End Sub

-

-Sub ClearSheetData()

-    If Range("F10") = 0 And Range("F13") = 0 Then

-        Range("F11:F18") = ""

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("F11:F13") = ""

-    End If

-End Sub

-

-Public Sub SaveData()

-    If Range("VIEW_ONLY") = False Then

-        Dim bdgt As tBUDGET

-        Dim sum As Long

-        Dim test As Boolean

-        With bdgt

-            .lpu_id = Range("lpu_id")

-            .id = Range("rec_id")

-            .entry_date = Range("ent_date")

-            .bdgt_NMG = Round(Range("F11").Value, 0)

-            .bdgt_NFG = Round(Range("F12").Value, 0)

-            .sale_plan = Round(Range("F13").Value, 0)

-            

-            sum = .bdgt_NFG + .bdgt_NMG - .sale_plan

-            test = .bdgt_NFG <> 0 Or .bdgt_NMG <> 0 Or .sale_plan <> 0

-        End With

-        If test Then

-            If sum < 0 Then

-                MsgBox _

-                    "Ваш план превышает выделенный на гепарины бюджет. Сохранить данные?", _

-                    vbOKOnly, PROGRAM_NAME

-            End If

-            If test Then

-                Insert_BDGT_Record bdgt

-            End If

-        Else

-            If bdgt.id <> 0 Then

-                If vbYes = MsgBox("Сохранить нулевые значения?", vbYesNo, PROGRAM_NAME) Then

-                    Insert_BDGT_Record bdgt

-                End If

-                ret_back Range("DEF_FOCUS").Worksheet

-                Exit Sub

-            End If

-        End If

-    Else

-        MsgBox "Режим только просмотра данных.", vbOKOnly, PROGRAM_NAME

-    End If

-    

-   ClearData

-   ret_back Range("DEF_FOCUS").Worksheet

-End Sub

-

-Sub SetupData(cLPU As tLPU_COMMON)

-    Dim t_sum As Long

-    t_sum = 0

-' Setup budget data

-    Range("F11") = cLPU.bdgt.bdgt_NMG

-    Range("F12") = cLPU.bdgt.bdgt_NFG

-    Range("F13") = cLPU.bdgt.sale_plan

-    

-    With cLPU

-        Range("F14") = .pat_ALL

-        Range("F15") = .pat_HIR

-        Range("F16") = .pat_TER

-        Range("F17") = .pat_CRD

-        Range("F18") = .sale_ALL

-    End With

-End Sub

-

-Private Sub Worksheet_Activate()

-    Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    ws_activate

-End Sub

-

-

-Sub ws_activate()

-    Dim cLPU As tLPU_COMMON

-    Dim objQTR As tQTR

-    Dim objLPU As tLPU

-    Dim ent_date As String

-    Dim id As Long

-    

-    If am_load_now Then

-        Exit Sub

-    End If

-    

-    id = Range("lpu_id").Value

-    ent_date = Range("ent_date")

-    objQTR = Get_QTR_Record(ent_date)

-    objLPU = Get_LPU_Record(id)

-    Get_LPU_Common cLPU, objLPU, objQTR

-    

-    If cLPU.lpu.id <> id And Range("ret_addr") <> "" Then

-        MsgBox "Нарушена база данных", vbOKOnly, PROGRAM_NAME

-        ret_back Range("DEF_FOCUS").Worksheet

-    Else

-        Range("A1").Select

-

-        Range("lpu_beds") = cLPU.lpu.beds

-        Range("lpu_name") = cLPU.lpu.name

-        Range("lpu_addr") = cLPU.lpu.address

-        Range("rec_id") = cLPU.bdgt.id

-        

-        SetupData cLPU

-        

-        Range(Range("DEF_FOCUS")).Select

-    End If

-

-End Sub

-

-Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

-'    MsgBox Target.address

-    Cancel = True

-End Sub

-

-Private Sub Worksheet_Change(ByVal Target As Range)

-    Dim s As String

-    Dim iset As tInputSet

-    

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    

-    Select Case iset.vType

-        Case INPUT_NO

-        

-        Case INPUT_NUMBER

-            Check_Int_Number Target, iset.vMax

-            

-        Case INPUT_PERCENT

-        

-        Case INPUT_STRING

-        

-        Case INPUT_CHECK

-            

-        Case Else

-    End Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Dim iset As tInputSet

-

-    iset = is_input_cell(Target, Range("h_Inputs"))

-    wks_sel_chng iset, Target, Range("DEF_FOCUS").Worksheet

-End Sub

-<<<<<<
-======================
-dlgGetPwd
->>>>>>
-Attribute VB_Name = "dlgGetPwd"

-Attribute VB_Base = "0{E3F10C5A-A4B4-42FF-A2C9-6F8198210A07}{563D0F3D-F79D-48F1-AFE4-A2136809B982}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btnSubmit_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mSheets
->>>>>>
-Attribute VB_Name = "mSheets"

-Option Explicit

-

-Function am_load_now() As Boolean

-    am_load_now = ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_LOAD_MODE")

-End Function

-

-Sub Wks_select(RetSheet As String)

-    Dim sheet As Worksheet

-    For Each sheet In ThisWorkbook.Worksheets

-        If sheet.name = RetSheet Then

-            ThisWorkbook.Worksheets(RetSheet).Select

-            Exit Sub

-        End If

-    Next sheet

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub ret_back(sh As Worksheet)

-    Dim RetSheet As String

-    RetSheet = sh.Range("ret_addr")

-    sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    sh.Range("ret_addr") = ""

-    sh.Range("rec_id") = ""

-    sh.Range("lpu_id") = ""

-    sh.Range("ent_date") = ""

-    sh.Range("lpu_name") = ""

-    sh.Range("lpu_addr") = ""

-    sh.Range("lpu_beds") = ""

-    Wks_select RetSheet

-End Sub

-

-Sub ClearSheetData(r_start As Range)

-    If r_start <> "" Then

-        r_start.Worksheet.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-        r_start = ""

-    Else

-        ret_back r_start.Worksheet

-    End If

-End Sub

-

-Sub wks_sel_chng(iset As tInputSet, ByVal Target As Range, sh As Worksheet)

-    Dim DebugMode As Boolean

-    Dim in_range As Range

-    

-    DebugMode = Worksheets(VAR_SHEET).Range("BOOL_DESIGN_MODE") = True

-

-    If DebugMode Then

-        sh.Unprotect

-    Else

-        sh.Protect DrawingObjects:=True, UserInterfaceOnly:=True

-    End If

-

-    If iset.vType = INPUT_CHECK Then

-        Set in_range = Target.Worksheet.Range(iset.rChk)

-    Else

-        Set in_range = Target

-    End If

-    

-    Dim str As String

-    str = GetFocusAddress(in_range, sh.Range("h_inputs"))

-

-'    MsgBox Target.Address & "; " & str

-    If str <> Target.address Then

-        sh.Range(str).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-Dlg_lpu_card
->>>>>>
-Attribute VB_Name = "Dlg_lpu_card"

-Attribute VB_Base = "0{137EDDE5-3DB4-4BAD-A245-324DC31ABB36}{3BD7159A-BF6C-403F-B3DF-4834FA9E4D92}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub bt_Cancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub bt_Ok_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-Private Sub cbLPU_List_Change()

-    Dim src As Range

-    Dim idx_src As Integer

-    

-    Set src = Worksheets(VAR_SHEET).Range(Me.cbLPU_List.RowSource)

-    idx_src = Me.cbLPU_List.ListIndex + 1

-    Me.tb_lpu_name.Text = src.Cells(idx_src, 1)

-    Me.tb_lpu_address.Text = src.Cells(idx_src, 2)

-    Me.tbBedsCount.Text = src.Cells(idx_src, 3)

-End Sub

-

-

-Private Sub cbxLPU_List_Enable_Click()

-    

-    If Me.cbxLPU_List_Enable Then

-        

-        Me.tb_lpu_name.Text = ""

-        Me.tb_lpu_name.Enabled = False

-        

-        Me.tb_lpu_address.Text = ""

-        Me.tb_lpu_address.Enabled = False

-        

-        Me.tbBedsCount.Text = ""

-        Me.tbBedsCount.Enabled = False

-        

-        Me.cbLPU_List.Enabled = True

-        cbLPU_List_Change

-    Else

-        Me.tb_lpu_name.Enabled = True

-        Me.tb_lpu_name.Text = ""

-        

-        Me.tb_lpu_address.Enabled = True

-        Me.tb_lpu_address.Text = ""

-        

-        Me.tbBedsCount.Enabled = True

-        Me.tbBedsCount.Text = ""

-        

-        Me.cbLPU_List.Enabled = False

-    End If

-End Sub

-

-<<<<<<
-======================
-UserInfo
->>>>>>
-Attribute VB_Name = "UserInfo"

-Attribute VB_Base = "0{8EB80D4C-3476-421A-A370-6332A07DE509}{A7542905-C9F8-4F39-AD67-B62A88F8F4E6}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Tag = vbOK

-End Sub

-

-Private Sub cbCity_Change()

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_CITY") = Me.cbCity.ListIndex

-        .Calculate

-    End With

-End Sub

-

-Private Sub cbRegion_Change()

-    Dim LinesCount, NewRangeOffsetCol As Integer

-    Dim NewCbxRange, NewSumRange As String

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        NewRangeOffsetCol = cbRegion.Value * 2

-        LinesCount = GetLinesCount(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol))

-        NewCbxRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol)).address

-        NewSumRange = .name & "!" & _

-                        .Range(.Range("CITY_TABLES").Offset(1, NewRangeOffsetCol + 1), _

-                        .Range("CITY_TABLES").Offset(LinesCount, NewRangeOffsetCol + 1)).address

-        .Calculate

-        .Range("IDX_CITY") = 0

-        cbCity.RowSource = NewCbxRange

-

-    End With

-    cbCity.ListIndex = 0

-End Sub

-

-<<<<<<
-======================
-mREP
->>>>>>
-Attribute VB_Name = "mREP"

-Option Explicit

-

-Sub hwnew()

-    Dim rs As Range

-    Dim re As Object

-    

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    HWReset

-    ReSetREPRecord

-    With Worksheets("REP_QTR")

-        .ClearRepName

-        .Range("REP_QTR_INPUT_DATA").ClearContents

-        .Range("QTR_SEL") = ""

-    End With

-    Worksheets(TITLE_SHEET).Select

-    With Application

-        .DisplayAlerts = False

-        .ThisWorkbook.Save

-        .Quit

-    End With

-End Sub

-

-Function CheckUser() As Boolean

-    Dim objHW() As Long

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    

-    GetHWInfo objHW()

-    i = GetHWRecords(objHW_DB)

-    

-    If i = 0 Then ' First time

-        StoreHWInfo objHW()

-        Worksheets("REP_QTR").Range("QTR_SEL") = ""

-    End If

-    If CheckHWInfo(objHW()) <> True Then

-        CheckUser = False

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    Else

-        CheckUser = SetupUser

-    End If

-End Function

-

-Function SetupUser() As Boolean

-    Dim cUser As tREP

-    Dim idx As Integer

-    Dim dlg_ui As UserInfo

-    

-    Set dlg_ui = New UserInfo

-    

-    cUser = GetREPRecord()

-    

-    With ThisWorkbook.Worksheets(REGS_SHEET)

-        .Range("IDX_REGION") = cUser.Region

-        .Range("IDX_CITY") = cUser.City

-    End With

-        

-    With dlg_ui

-        .cbRegion = cUser.Region

-        .cbCity = cUser.City

-        .tbFName = cUser.FirstName

-        .tbLName = cUser.LastName

-    End With

-    

-    Worksheets(REGS_SHEET).Calculate

-    

-    Dim test_Ok As Boolean

-    test_Ok = False

-    

-    On Error GoTo l1

-

-    Do

-        dlg_ui.Show

-        If dlg_ui.Tag = vbOK Then

-            test_Ok = dlg_ui.tbFName.Value <> "" And dlg_ui.tbLName <> ""

-            If test_Ok Then

-                Exit Do

-            Else

-                MsgBox "Введите имя и фамилию", vbOKOnly, PROGRAM_NAME

-            End If

-        Else

-            Exit Do

-        End If

-    Loop Until False

-l1:

-    If test_Ok Then

-        With cUser

-            .Region = dlg_ui.cbRegion.Value

-            .City = dlg_ui.cbCity.Value

-            .FirstName = dlg_ui.tbFName.Value

-            .LastName = dlg_ui.tbLName.Value

-        End With

-        SetREPRecord cUser

-    Else

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .ThisWorkbook.Saved = True

-            .Quit

-        End With

-    End If

-    SetupUser = test_Ok

-End Function

-

-Sub GetHWInfo(objHW() As Long)

-    Dim fs, d, dc, s, n

-    Dim r As Range

-    Dim i As Integer

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    Set dc = fs.Drives

-    i = 1

-    For Each d In dc

-        If d.drivetype = 2 Then ' 2 - HardDisk

-            ReDim Preserve objHW(i)

-            objHW(i) = d.SerialNumber

-            i = i + 1

-        End If

-    Next

-    SortHW objHW

-End Sub

-

-Sub StoreHWInfo(objHW() As Long)

-    UpdateHWRecords objHW

-End Sub

-

-Sub SortHW(objHW() As Long)

-    Dim r As Range

-    Dim rs As Range

-    Dim re As Object

-    Dim i As Integer

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).ClearContents

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    For i = 1 To UBound(objHW)

-        r = objHW(i)

-        Set r = r.Offset(1, 0)

-    Next i

-    With Worksheets(VAR_SHEET)

-        Set rs = .Range("HW_Number")

-        Set re = .Range(rs, rs.End(xlDown))

-        .Range(rs, re).Sort _

-            Key1:=.Range("HW_Number"), _

-            Order1:=xlDescending, _

-            Header:=xlGuess, _

-            OrderCustom:=1, _

-            MatchCase:=False, _

-            Orientation:=xlTopToBottom

-    End With

-    Set r = Worksheets(VAR_SHEET).Range("HW_Number")

-    i = 1

-    Do While r <> ""

-        objHW(i) = r

-        Set r = r.Offset(1, 0)

-        i = i + 1

-    Loop

-End Sub

-

-Function CheckHWInfo(objHW() As Long)

-    Dim objHW_DB() As Long

-    Dim i As Integer

-    CheckHWInfo = False

-        

-    i = GetHWRecords(objHW_DB)

-    If i > 0 Then

-        SortHW objHW_DB

-    End If

-    If UBound(objHW) = UBound(objHW_DB) Then

-        For i = 1 To UBound(objHW)

-            If objHW(i) <> objHW_DB(i) Then

-                Exit Function

-            End If

-        Next i

-        CheckHWInfo = True

-    End If

-End Function

-<<<<<<
-======================
-dbBudget
->>>>>>
-Attribute VB_Name = "dbBudget"

-Option Explicit

-

-Public Type tBUDGET

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    bdgt_NMG As Long

-    bdgt_NFG As Long

-    sale_plan As Long

-End Type

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function GetAll_BDGT_RecordsByLPU_ID(ByRef allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_BDGT_RecordsByLPU_ID = dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection, allBDGT, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Function Get_BDGT_Record(ByVal lpu_id As Long, ByVal ent_date As String) As tBUDGET

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    Get_BDGT_Record = dbGet_BDGT_Record(dbConnection, lpu_id, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objBDGT.ID <> 0 then updatre else insert

-Public Sub Insert_BDGT_Record(objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    If objBDGT.id <> 0 Then

-        dbUpdate_BDGT_Record dbConnection, objBDGT

-    Else

-        dbInsert_BDGT_Record dbConnection, objBDGT

-    End If

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Public Sub Delete_BDGT_Record(ByRef objBDGT As tBUDGET)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    dbDelete_BDGT_Record dbConnection, objBDGT

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGet_BDGT_Record(dbConnection As Object, ByVal lpu_id As Long, ent_date As String) As tBUDGET

-    

-    Dim SQL As String

-    Dim objBDGT As tBUDGET

-    

-    With objBDGT

-        .id = 0

-        .lpu_id = lpu_id

-        .entry_date = ent_date

-        .bdgt_NMG = 0

-        .bdgt_NFG = 0

-        .sale_plan = 0

-    End With

-        

-    

-    SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        With objBDGT

-            .entry_date = dbRecordset("entry_date")

-            .id = dbRecordset("id")

-            .lpu_id = dbRecordset("lpu_id")

-            .bdgt_NFG = dbRecordset("bdgt_NFG")

-            .bdgt_NMG = dbRecordset("bdgt_NMG")

-            .sale_plan = dbRecordset("sale_PLAN")

-        End With

-    End If

-    

-    dbGet_BDGT_Record = objBDGT

-End Function

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_BDGT_RecordsbyLPU_ID(dbConnection As Object, allBDGT() As tBUDGET, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_BDGT_SQL As String

-    Dim getAll_BDGT_SQL As String

-    Dim BDGT_Count As Long

-    BDGT_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_BDGT_SQL = "SELECT COUNT(*) AS BDGT_TOTAL FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_BDGT_SQL = "SELECT * FROM lpu_budget WHERE lpu_id=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_BDGT_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        BDGT_Count = dbRecordset("BDGT_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_BDGT_RecordsbyLPU_ID = BDGT_Count

-    

-    If BDGT_Count > 0 Then

-        'we have records

-        ReDim allBDGT(1 To BDGT_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_BDGT_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpBDGT As tBUDGET

-                 With tmpBDGT

-                    .entry_date = dbRecordset("entry_date")

-                    .id = dbRecordset("id")

-                    .lpu_id = dbRecordset("lpu_id")

-                    .bdgt_NFG = dbRecordset("bdgt_NFG")

-                    .bdgt_NMG = dbRecordset("bdgt_NMG")

-                    .sale_plan = dbRecordset("sale_PLAN")

-                 End With

-                 

-                 allBDGT(index) = tmpBDGT

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbInsert_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "lpu_budget", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    dbRecordset("entry_date") = objBDGT.entry_date

-    dbRecordset("lpu_id") = objBDGT.lpu_id

-    dbRecordset("bdgt_NMG") = objBDGT.bdgt_NMG

-    dbRecordset("bdgt_NFG") = objBDGT.bdgt_NFG

-    dbRecordset("sale_PLAN") = objBDGT.sale_plan

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objBDGT.id = dbRecordset("id")

-  

-End Sub

-

-Public Sub dbUpdate_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu_budget SET " & _

-    "entry_date='" & objBDGT.entry_date & "'," & _

-    "lpu_id=" & objBDGT.lpu_id & "," & _

-    "bdgt_NMG=" & objBDGT.bdgt_NMG & "," & _

-    "bdgt_NFG=" & objBDGT.bdgt_NFG & "," & _

-    "sale_PLAN=" & objBDGT.sale_plan & _

-    " WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-Public Sub dbDelete_BDGT_Record(dbConnection As Object, ByRef objBDGT As tBUDGET)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE id=" & objBDGT.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_BDGT_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_BDGT_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_budget " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbDatabase
->>>>>>
-Attribute VB_Name = "dbDatabase"

-Option Explicit

-

-

-Sub dbOpenConnection(dbConnection As Object)

-    Dim dbAccessFile As String

-    Dim dbAccessFilePasswd As String

-    

-    dbAccessFile = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dbAccessFilePasswd = "password"

-    

-    Set dbConnection = CreateObject("ADODB.Connection")

-    Dim dbConnectionString As String

-    dbConnectionString = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & _

-    dbAccessFile & ";Password=" & dbAccessFilePasswd

-    

-    dbConnection.Open dbConnectionString

-    

-End Sub

-

-Sub dbCloseConnection(dbConnection As Object)

-    dbConnection.Close

-End Sub

-

-

-Sub dbExecuteSQL(dbConnection As Object, SQL As String)

-    dbConnection.Execute (SQL)

-End Sub

-

-<<<<<<
-======================
-dbLPU
->>>>>>
-Attribute VB_Name = "dbLPU"

-Option Explicit

-

-Public Type tLPU

-    id As Long

-    rep_id As Long

-    name As String

-    address As String

-    beds As Integer

-End Type

-

-Function Get_LPU_Record(ByVal lpu_id As Long) As tLPU

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    Get_LPU_Record = dbGet_LPU_Record(dbConnection, lpu_id)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAllLPU(allLPU() As tLPU) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAllLPU = dbGetAllLPU(dbConnection, allLPU)

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAllLPUbyQTR(allLPU() As tLPU, ent_date As String) As Integer

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetAllLPUbyQTR = dbGetAllLPUbyQTR(dbConnection, allLPU, ent_date)

-    dbCloseConnection dbConnection

-End Function

-

-' if objLPU.id = 0 then insert else update

-Sub Insert_LPU_Record(ByRef objLPU As tLPU)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    If objLPU.id = 0 Then

-        dbInsert_LPU_Record dbConnection, objLPU

-    Else

-        dbUpdate_LPU_Record dbConnection, objLPU

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-

-Sub Delete_LPU_Record(ByRef objLPU As tLPU)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDelete_LPU_Record dbConnection, objLPU

-    dbCloseConnection dbConnection

-End Sub

-

-Sub Delete_LPU_RecordQTR(ByRef objLPU As tLPU, ent_date As String)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Hir_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Ter_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_ACS_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    

-    dbCloseConnection dbConnection

-    

-End Sub

-

-Function dbGet_LPU_Record(dbConnection As Object, ByVal lpu_id As Long) As tLPU

-    

-    Dim SQL As String

-    Dim objLPU As tLPU

-    

-    objLPU.id = lpu_id

-    objLPU.name = ""

-    objLPU.address = ""

-    

-    SQL = "SELECT * FROM lpu WHERE id=" & lpu_id

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        objLPU.name = dbRecordset("name")

-        objLPU.address = dbRecordset("address")

-        objLPU.rep_id = dbRecordset("rep_id")

-        objLPU.beds = dbRecordset("beds")

-    End If

-    

-    dbGet_LPU_Record = objLPU

-

-End Function

-

-Sub dbInsert_LPU_Record(dbConnection As Object, ByRef objLPU As tLPU)

-  

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu", dbConnection, 2, 2

-    dbRecordset.addnew

-    dbRecordset("name") = objLPU.name

-    dbRecordset("address") = objLPU.address

-    dbRecordset("rep_id") = objLPU.rep_id

-    dbRecordset("beds") = objLPU.beds

-    

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objLPU.id = dbRecordset("id")

-  

-End Sub

-

-Sub dbUpdate_LPU_Record(dbConnection As Object, ByRef objLPU As tLPU)

-    

-    Dim UpdateSQL As String

-    

-    UpdateSQL = "UPDATE lpu SET " & _

-    "name='" & objLPU.name & "'," & _

-    "address='" & objLPU.address & "'," & _

-    "beds=" & objLPU.beds & "," & _

-    "rep_id=" & objLPU.rep_id& & _

-    " WHERE id=" & objLPU.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-       

-End Sub

-

-

-Function dbGetAllLPU(dbConnection As Object, allLPU() As tLPU) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu"

-    getAll_LPU_SQL = "SELECT * FROM lpu"

-

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAllLPU = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-Function dbGetAllLPUbyQTR(dbConnection As Object, allLPU() As tLPU, ent_date As String) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_LPU_SQL As String

-    Dim lpu_count As Long

-    lpu_count = 0

-    

-    Dim where As String

-    where = "WHERE lpu_budget.entry_date like '" & ent_date & "'"

-    

-    getCount_SQL = "SELECT COUNT(*) AS LPU_TOTAL FROM lpu_budget " & where

-    

-    getAll_LPU_SQL = "SELECT lpu.id as id, lpu.rep_id as rep_id, lpu.name as name, lpu.address as address, lpu.beds AS beds " & _

-    "FROM lpu, lpu_budget " & where & " AND lpu.id=lpu_budget.lpu_id"

-    

-

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        lpu_count = dbRecordset("LPU_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAllLPUbyQTR = lpu_count

-    

-    If lpu_count > 0 Then

-        'we have records

-        ReDim allLPU(1 To lpu_count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_LPU_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                 Dim tmpLPU As tLPU

-                 

-                 With tmpLPU

-                    .id = dbRecordset("id")

-                    .name = dbRecordset("name")

-                    .address = dbRecordset("address")

-                    .rep_id = dbRecordset("rep_id")

-                    .beds = dbRecordset("beds")

-                 End With

-                 

-                 allLPU(index) = tmpLPU

-                 index = index + 1

-                 dbRecordset.MoveNext

-                 

-             Loop

-        End If

-    End If

-End Function

-

-Sub dbDelete_LPU_Record(dbConnection As Object, ByRef objLPU As tLPU)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu " & _

-    "WHERE id=" & objLPU.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByLPU_ID dbConnection, objLPU.id

-    dbDelete_Hir_RecordsByLPU_ID dbConnection, objLPU.id

-    dbDelete_Ter_RecordsByLPU_ID dbConnection, objLPU.id

-    dbDelete_ACS_RecordsByLPU_ID dbConnection, objLPU.id

-    

-End Sub

-

-Sub dbDelete_LPU_RecordQTR(dbConnection As Object, ByRef objLPU As tLPU, ent_date As String)

-    

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Hir_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_Ter_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    dbDelete_ACS_RecordsByQTR_LPU dbConnection, objLPU.id, ent_date

-    

-End Sub

-

-<<<<<<
-======================
-dbREP
->>>>>>
-Attribute VB_Name = "dbREP"

-Option Explicit

-

-Public Type tREP

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Function GetREPRecord() As tREP

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    GetREPRecord = dbGetREPRecord(dbConnection)

-    dbCloseConnection dbConnection

-End Function

-

-Sub SetREPRecord(cUser As tREP)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbSetREPRecord dbConnection, cUser

-    dbCloseConnection dbConnection

-End Sub

-

-Sub ReSetREPRecord()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbReSetREPRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Public Function dbGetREPRecord(dbConnection As Object) As tREP

-    

-    Dim SQL As String

-    Dim objREP As tREP

-    

-    objREP.FirstName = ""

-    objREP.LastName = ""

-    objREP.Region = 0

-    objREP.City = 0

-    SQL = "SELECT firstname, lastname, region, city FROM " & _

-          "rep"

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open SQL, dbConnection

-    ', 3, 3

-    If Not dbRecordset.BOF Then

-        

-        objREP.FirstName = dbRecordset("firstname")

-        objREP.LastName = dbRecordset("lastname")

-        objREP.Region = dbRecordset("region")

-        objREP.City = dbRecordset("city")

-        

-    End If

-    

-    dbGetREPRecord = objREP

-        

-End Function

-

-Public Sub dbSetREPRecord(dbConnection As Object, ByRef objREP As tREP)

-  

-    Dim DeleteSQL As String

-    Dim InsertSQL As String

-    

-    DeleteSQL = "DELETE FROM rep"

-    InsertSQL = "INSERT INTO rep (firstname, lastname, region, city) VALUES (" & _

-    "'" & objREP.FirstName & "', " & _

-    "'" & objREP.LastName & "', " & _

-    objREP.Region & ", " & _

-    objREP.City & ")"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-    dbRecordset.Open InsertSQL, dbConnection

-End Sub

-

-Public Sub dbReSetREPRecord(dbConnection As Object)

-  

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM rep"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-

-<<<<<<
-======================
-cAppEvents
->>>>>>
-Attribute VB_Name = "cAppEvents"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Public WithEvents app As Application

-Attribute app.VB_VarHelpID = -1

-

-Private Sub App_WorkbookOpen(ByVal Wb As Workbook)

-    CheckWorkBooksArround Wb

-End Sub

-

-

-Sub CheckWorkBooksArround(ByVal Wb As Workbook)

-    Dim wbname As String

-    Dim rslt As Integer

-    Dim wbk As Workbook

-    If app.Workbooks.Count > 1 Then

-        wbname = ThisWorkbook.FullName

-        rslt = MsgBox("Все открытые книги EXCEl сейчас будут закрыты!", vbOKOnly, "&" + PROGRAM_NAME)

-        If rslt = vbOK Then

-            For Each wbk In Workbooks

-                If wbk.FullName <> wbname Then

-                    wbk.Close

-                End If

-            Next wbk

-        Else

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-        Exit Sub

-    End If

-

-End Sub

-<<<<<<
-======================
-cApplicationState
->>>>>>
-Attribute VB_Name = "cApplicationState"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-'----------------------------------------

-' This class stores and restores the state

-' of the Excel application

-'----------------------------------------

-

-Private Type COMMANDBAR_STATE

-    sName As String

-    bVisible As Boolean

-End Type

-

-Dim m_atCommandBars() As COMMANDBAR_STATE

-Dim m_nCalculation As Integer

-Dim m_bCellDragAndDrop As Boolean

-Dim m_bDisplayFormulaBar As Boolean

-Dim m_bDisplayNoteIndicator As Boolean

-Dim m_bDisplayStatusBar As Boolean

-Dim m_bEditDirectlyInCell As Boolean

-Dim m_bTransitionNavigationKeys As Boolean

-Dim m_bPlayASound As Boolean

-

-

-Public Sub SaveExcelState()

-'----------------------------------------

-' save the current state in member variables

-'----------------------------------------

-

-    Dim objCommandBar As CommandBar

-    Dim nCtr As Integer

-    

-    With Application

-    

-        ' save calculation mode - note: a workbook must be

-        ' open or the Calculation property fails so we

-        ' open a new workbook here just to be safe

-        .ScreenUpdating = False

-        .Workbooks.Add

-        m_nCalculation = .Calculation

-        .Calculation = xlCalculationAutomatic

-        ActiveWorkbook.Close False

-        ActiveWorkbook.DisplayDrawingObjects = xlDisplayShapes

-        

-        m_bCellDragAndDrop = .CellDragAndDrop

-        m_bDisplayFormulaBar = .DisplayFormulaBar

-        m_bDisplayNoteIndicator = .DisplayNoteIndicator

-        m_bDisplayStatusBar = .DisplayStatusBar

-        m_bEditDirectlyInCell = .EditDirectlyInCell

-        m_bTransitionNavigationKeys = .TransitionNavigKeys

-        m_bPlayASound = .EnableSound

-        

-

-        ' save visibility of each commandbar

-        ReDim m_atCommandBars(.CommandBars.Count - 1)

-        nCtr = 0

-        For Each objCommandBar In .CommandBars

-            With m_atCommandBars(nCtr)

-                .sName = objCommandBar.name

-                .bVisible = objCommandBar.Visible

-            End With

-            nCtr = nCtr + 1

-        Next objCommandBar

-        

-    End With

-

-End Sub

-

-Public Sub HideAllCommandBars()

-'----------------------------------------

-' hides all command bars

-'----------------------------------------

-    Dim objCommandBar As CommandBar

-    On Error Resume Next

-    For Each objCommandBar In Application.CommandBars

-        objCommandBar.Visible = False

-        objCommandBar.Protection = msoBarNoChangeVisible

-    Next objCommandBar

-    Application.CommandBars(STDBAR_NAME).Visible = False

-End Sub

-

-

-Public Sub RestoreExcelState()

-'----------------------------------------

-' restores the state as saved by GetState

-'----------------------------------------

-    Dim nCtr As Integer

-    

-    On Error Resume Next

-    

-    With Application

-        .ScreenUpdating = False

-        .CellDragAndDrop = m_bCellDragAndDrop

-        .DisplayFormulaBar = m_bDisplayFormulaBar

-        .DisplayNoteIndicator = m_bDisplayNoteIndicator

-        .DisplayStatusBar = m_bDisplayStatusBar

-        .EditDirectlyInCell = m_bEditDirectlyInCell

-        .TransitionNavigKeys = m_bTransitionNavigationKeys

-        .EnableSound = m_bPlayASound

-        

-        

-        .Workbooks.Add

-        .Calculation = m_nCalculation

-        ActiveWorkbook.Close False

-

-    End With

-

-    For nCtr = 0 To UBound(m_atCommandBars)

-        With m_atCommandBars(nCtr)

-            Application.CommandBars(.sName).Protection = msoBarNoProtection

-            Application.CommandBars(.sName).Visible = .bVisible

-        End With

-    Next nCtr

-    Application.CommandBars(STDBAR_NAME).Visible = True

-End Sub

-

-<<<<<<
-======================
-cEnableRun
->>>>>>
-Attribute VB_Name = "cEnableRun"

-Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = False

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-' use notation YYYYMMDD for definition estimation date like as 19980827

-' if end_date = -1 then not estimation checked

-

-Public Sub EnableRun(end_date As Long, ByVal theDate As Date)

-    

-    If end_date = NO_ESTIMATION_DATE Then

-        Exit Sub

-    End If

-    Dim day, month, year As Long

-    Dim CurDate As Long

-    day = DatePart("d", theDate)

-    month = DatePart("m", theDate)

-    year = DatePart("yyyy", theDate)

-    CurDate = year * 10000

-    CurDate = CurDate + month * 100

-    CurDate = CurDate + day

-    If CurDate > end_date Then

-        cmAbout

-        With Application

-            .DisplayAlerts = False

-            .Quit

-        End With

-    End If

-End Sub

-

-<<<<<<
-======================
-mMenu
->>>>>>
-Attribute VB_Name = "mMenu"

-Option Explicit

-

-Public Const STDBAR_NAME = "Worksheet Menu Bar"

-

-Sub CreateCommandBar(theApp As Application)

-'----------------------------------------

-' creates this application's custom commandbar

-'----------------------------------------

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar theApp

-    With theApp.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlPopup)

-                .Caption = "&File"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Export"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 620

-                        .OnAction = "cmExport"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "E&xit"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 330

-                        .OnAction = "cmCloseProgram"

-                    End With

-                End With

-            End With

-            With .Add(msoControlPopup)

-                .Caption = "&Help"

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Mail to Support"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 328

-                        .OnAction = "cmMail2Support"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&Exit && Restore Excel"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 548

-                        .OnAction = "cmExitRestore"

-                    End With

-                End With

-                With .Controls

-                    With .Add(msoControlButton)

-                        .Caption = "&About"

-                        .Style = msoButtonIconAndCaption

-                        .FaceId = 51

-                        .OnAction = "cmAbout"

-                    End With

-                End With

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Start Page"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 1016

-                .OnAction = "cmHomePage"

-            End With

-        End With

-    End With

-End Sub

-

-Sub DeleteCommandBar(theApp As Application)

-'----------------------------------------

-' deletes this application's custom commandbar

-'----------------------------------------

-    On Error Resume Next

-    With theApp.CommandBars(COMMANDBAR_NAME)

-        .Protection = msoBarNoProtection

-        .Delete

-    End With

-End Sub

-

-Sub SetNewMode()

-Attribute SetNewMode.VB_ProcData.VB_Invoke_Func = "I\n14"

-    Dim MenuBarBool As Boolean

-    

-    MenuBarBool = True

-

-    DeleteCommandBar Application

-    With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

-        .Visible = True

-        .Visible = True

-        .Position = msoBarTop

-        .Protection = msoBarNoChangeVisible _

-                    + msoBarNoCustomize _

-                    + msoBarNoMove _

-                    + msoBarNoChangeDock

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "E&xit"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 3

-                .OnAction = "cmCloseProgram"

-            End With

-            With .Add(msoControlButton)

-                .Caption = "&Edit Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 44

-                .OnAction = "cmSetDesignerMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub SetupDesignMenu(flag As Boolean)

-    If flag = False Then

-        Exit Sub

-    End If

-    

-    With Application.CommandBars(STDBAR_NAME)

-        .Reset

-        With .Controls

-            With .Add(msoControlButton)

-                .Caption = "&Run Application"

-                .Style = msoButtonIconAndCaption

-                .FaceId = 51

-                .OnAction = "cmSetStandaloneMode"

-            End With

-        End With

-    End With

-End Sub

-

-Sub cmExport()

-    dbExport

-End Sub

-

-Sub cmCloseProgram()

-    Application.Quit

-End Sub

-

-Sub cmAbout()

-    Dim dlg As dlgAbout

-    Set dlg = New dlgAbout

-    

-    dlg.ProgName = PROGRAM_NAME

-    If ESTIMATION_DATE <> NO_ESTIMATION_DATE Then

-        dlg.ProgVersion = "TRIAL " & PROGRAM_VERSION

-    Else

-        dlg.ProgVersion = PROGRAM_VERSION & " RELEASE"

-    End If

-    dlg.Show

-End Sub

-

-Sub cmMail2Support()

-    Dim err_description As String

-    Dim dlg_msg As dlg_Mail

-    Set dlg_msg = New dlg_Mail

-    With dlg_msg

-        .Show

-        If .Tag = vbOK Then

-            ThisWorkbook.Worksheets(VAR_SHEET).Range("ERR_MESSAGE") _

-                = .tbMessage.Text

-            ThisWorkbook.Save

-            ThisWorkbook.SendMail Recipients:="infra@i-rs.ru", Subject:=PROGRAM_NAME & " ver.:" & PROGRAM_VERSION

-            MsgBox "Сообщение об ошибке отправлено. Перезагрузите программу.", vbOKOnly, PROGRAM_NAME

-            ThisWorkbook.Close SaveChanges:=False

-        End If

-    End With

-End Sub

-

-Sub cmHelpContents()

-    Dim helppath As String

-    With ThisWorkbook

-'        helppath = "hh.exe " & .Path & "\Telfast.chm"

-'        Shell helppath, vbNormalFocus

-    End With

-End Sub

-

-Sub set_work_mode()

-    Application.ScreenUpdating = False

-    ProtectionDisable Wb:=ThisWorkbook

-    SetupEnvironment Wb:=ThisWorkbook

-    SetDesignFlagOff

-    ProtectionEnable Wb:=ThisWorkbook

-End Sub

-

-Sub cmSetStandaloneMode()

-    set_work_mode

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Select

-End Sub

-

-Sub cmSetDesignerMode()

-    Dim rp As String

-    Dim dlg As dlgGetPwd

-    rp = common_pwd

-    

-    Set dlg = New dlgGetPwd

-    dlg.edPwd = ""

-    dlg.Show

-    

-    If dlg.edPwd = rp Then

-        ProtectionDisable Wb:=ThisWorkbook

-        RestoreEnvironment Wb:=ThisWorkbook, DesignMode:=True

-        SetDesignFlagOn

-        ThisWorkbook.Worksheets(TITLE_SHEET).Select

-    Else

-        cmSetStandaloneMode

-    End If

-End Sub

-

-Sub cmHomePage()

-    ThisWorkbook.Worksheets("REP_QTR").Select

-End Sub

-

-Sub cmExitRestore()

-    ThisWorkbook.Worksheets(VAR_SHEET).Range("BOOL_EXIT_RESTORE") = True

-    Application.Quit

-End Sub

-<<<<<<
-======================
-mPrint
->>>>>>
-Attribute VB_Name = "mPrint"

-Option Explicit

-

-Type Print_Options

-    MainReport As Boolean

-    MainBudget As Boolean

-    SrcData As Boolean

-    AllSheets As Boolean

-End Type

-

-Sub cmPrint()

-    Dim plist As Variant

-    Dim dlg_prn As dlgPrint

-    

-    Set dlg_prn = New dlgPrint

-    

-    With dlg_prn

-        .cbMainReport = True

-        .cbMainBudget = False

-        .cbSrcData = False

-        .cbAllSheets = False

-    

-        .Show

-    

-        If .Tag = vbCancel Then

-            Exit Sub

-        End If

-    End With

-    

-    Dim PrnIdx As Integer

-    

-    With dlg_prn

-        PrnIdx = Abs(.cbMainReport _

-                + .cbMainBudget * 10 _

-                + .cbSrcData * 100 _

-                + .cbAllSheets * 1000)

-    End With

-    

-    Select Case PrnIdx

-    Case 1

-        plist = Array("Final")

-    Case 11

-        plist = Array("budget", "Final")

-    Case 111

-        plist = Array("REP_QTR", "budget", "Final")

-    Case 1111

-        plist = Array("REP_QTR", "budget", "Final", _

-                        "Doc", "Doc.Visit", "Doc.Conf", _

-                        "Apt", "Apt.Visit", "Apt.Conf", _

-                        "Adv", "Act", "Cost")

-    End Select

-    

-    Application.ScreenUpdating = False

-    Dim ws As Worksheet

-    Dim lh As String

-    With Sheets("REP_QTR")

-        lh = .Range("USER_NAME_S") & " " & .Range("USER_NAME_F")

-    End With

-    With Sheets("data")

-        lh = lh & ", " & .Range("LST_PERSONE").Cells(.Range("IDX_PERSONE"))

-        lh = lh & ", " & .Range("LST_REGIONS").Cells(.Range("IDX_REGION"))

-        lh = lh & ", " & .Range("CITY_TABLES").Offset(.Range("IDX_CITY"), (.Range("IDX_REGION") - 1) * 2)

-End With

-        

-    For Each ws In Worksheets(plist)

-        With ws.PageSetup

-            .LeftHeader = lh

-            .CenterHeader = ""

-            .RightHeader = "&D"

-'            .LeftFooter =

-            .CenterFooter = PROGRAM_NAME

-            .RightFooter = "Page &P of &N"

-        End With

-    Next ws

-    Worksheets(plist).PrintOut Copies:=1, Collate:=True

-    Application.ScreenUpdating = False

-    

-End Sub

-

-

-<<<<<<
-======================
-mStartup
->>>>>>
-Attribute VB_Name = "mStartup"

-Option Explicit

-

-'----------------------------------------

-' define instance of object which will

-' store the initial state of excel

-'----------------------------------------

-Dim mobjAppState As New cApplicationState

-

-

-'----------------------------------------

-' constant definitions

-'----------------------------------------

-Public Const COMMANDBAR_NAME = "Clexane bar"

-Public Const common_pwd As String = "crdjhxtyjr"

-

-

-Sub SetupEnvironment(Wb As Workbook)

-'----------------------------------------

-' Saves the current state of Excel then

-' prepares the environment for this application

-'----------------------------------------

-    

-    Wb.Worksheets(TITLE_SHEET).Select

-    With Application

-        .Caption = PROGRAM_NAME & " " & PROGRAM_VERSION

-        .ScreenUpdating = False

-    End With

-    With mobjAppState

-        .SaveExcelState

-        .HideAllCommandBars

-    End With

-    With Application

-        .DisplayFormulaBar = False

-        .DisplayStatusBar = True

-        .EnableSound = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = False

-    End With

-    With Wb

-        With .Windows(1)

-            .Caption = ""

-            .DisplayHorizontalScrollBar = False

-            .DisplayVerticalScrollBar = False

-            .DisplayWorkbookTabs = False

-            .WindowState = xlMaximized

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    With cWindow

-                        .DisplayHeadings = False

-                        .ScrollRow = 1

-                        .ScrollColumn = 1

-                    End With

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-    End With

-    CreateCommandBar theApp:=Wb.Application

-End Sub

-

-Sub RestoreEnvironment(Wb As Workbook, Optional DesignMode As Boolean)

-'----------------------------------------

-' Restores Excel to its intial state when

-' this application started

-'----------------------------------------

-    Wb.Worksheets(TITLE_SHEET).Select

-    Application.ScreenUpdating = False

-    With Wb

-        With .Windows(1)

-            .DisplayHorizontalScrollBar = True

-            .DisplayVerticalScrollBar = True

-            .DisplayWorkbookTabs = True

-        End With

-        Dim cWorkSheet As Worksheet

-        For Each cWorkSheet In .Worksheets

-            If cWorkSheet.Visible = xlSheetVisible Then

-'                cWorkSheet.Select

-                Dim cWindow As Window

-                For Each cWindow In Application.Windows

-                    If cWindow.Type = xlWorkbook Then

-                        cWindow.DisplayHeadings = True

-                    End If

-                Next

-            End If

-        Next

-        .Worksheets(TITLE_SHEET).Select

-        If DesignMode Then

-            SetupDesignMenu True

-        End If

-        With mobjAppState

-            .RestoreExcelState

-        End With

-    End With

-    DeleteCommandBar theApp:=Application

-End Sub

-

-Sub ProtectionEnable(Wb As Workbook)

-    With Wb

-        .Application.ScreenUpdating = False

-        .Protect Windows:=True

-        .Worksheets(TITLE_SHEET).Select

-'        .Activate

-    End With

-End Sub

-

-Sub ProtectionDisable(Wb As Workbook)

-    With Wb

-        .Unprotect

-    End With

-End Sub

-

-

-

-<<<<<<
-======================
-dbHW
->>>>>>
-Attribute VB_Name = "dbHW"

-Option Explicit

-

-Sub UpdateHWRecords(objHW() As Long)

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    dbUpdateHWRecords dbConnection, objHW

-    dbCloseConnection dbConnection

-End Sub

-

-Function GetHWRecords(objHW() As Long) As Integer

-    Dim dbConnection  As Object

-    

-    dbOpenConnection dbConnection

-    GetHWRecords = dbGetHWRecords(dbConnection, objHW)

-    dbCloseConnection dbConnection

-End Function

-

-Sub HWReset()

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    dbDeleteHWRecord dbConnection

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbInsertHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    

-    Dim dbRecordset As Object

-    Dim i As Long

-    

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-

-    dbRecordset.Open "hw", dbConnection, 2, 2

-    

-    For i = 1 To UBound(objHW)

-        dbRecordset.addnew

-        dbRecordset("num") = objHW(i)

-        dbRecordset.Update

-    Next i

-    

-End Sub

-

-Sub dbUpdateHWRecords(dbConnection As Object, ByRef objHW() As Long)

-    dbDeleteHWRecord dbConnection

-    dbInsertHWRecords dbConnection, objHW

-End Sub

-

-Sub dbDeleteHWRecord(dbConnection As Object)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM hw "

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-End Sub

-

-Function dbGetHWRecords(dbConnection As Object, ByRef objHW() As Long) As Integer

-    

-    Dim getCount_SQL As String

-    Dim getAll_HW_SQL As String

-    Dim HW_Count As Long

-    

-    getCount_SQL = "SELECT COUNT(*) AS HW_TOTAL FROM hw"

-    getAll_HW_SQL = "SELECT * FROM hw"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        HW_Count = dbRecordset("HW_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetHWRecords = HW_Count

-    

-    If HW_Count > 0 Then

-        'we have records

-        ReDim objHW(HW_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_HW_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             

-             Do While Not dbRecordset.EOF

-                 

-                Dim tmp As Long

-                 

-                tmp = dbRecordset("num")

-                 

-                 objHW(index) = tmp

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-<<<<<<
-======================
-dbHir
->>>>>>
-Attribute VB_Name = "dbHir"

-Option Explicit

-

-Public Type tHIRURGIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    operations_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_ambulator_clexan_40mg As Integer

-    patients_ambulator_clexan_20mg As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-    patients_stationar_clexan_40mg As Integer

-    patients_stationar_clexan_20mg As Integer

-End Type

-

-' if objHir.ID <> 0 then updatre else insert

-Sub Insert_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objHir.id <> 0 Then

-        dbUpdate_Hir_Record dbConnection, objHir

-    Else

-        dbInsert_Hir_Record dbConnection, objHir

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Hir_RecordsByLPU_ID(ByRef allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Hir_RecordsByLPU_ID = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, allHir, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Hir_Record(ByRef objHir As tHIRURGIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Hir_Record dbConnection, objHir

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objHir.ID <> 0 then updatre else insert

-

-Sub dbInsert_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_hir", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objHir

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("operations_per_quarter") = .operations_per_quarter

-        dbRecordset("risk_percent") = .risk_percent

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_ambulator_clexan_20mg") = .patients_ambulator_clexan_20mg

-        dbRecordset("patients_ambulator_clexan_40mg") = .patients_ambulator_clexan_40mg

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-        dbRecordset("patients_stationar_clexan_20mg") = .patients_stationar_clexan_20mg

-        dbRecordset("patients_stationar_clexan_40mg") = .patients_stationar_clexan_40mg

-        

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objHir.id = dbRecordset("ID")

-

-End Sub

-

-Sub dbUpdate_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    Dim UpdateSQL As String

-    

-    With objHir

-        UpdateSQL = "UPDATE lpu_hir SET " & _

-            "entry_date='" & objHir.entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "operations_per_quarter=" & .operations_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_ambulator_clexan_20mg=" & .patients_ambulator_clexan_20mg & "," & _

-            "patients_ambulator_clexan_40mg=" & .patients_ambulator_clexan_40mg & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & "," & _

-            "patients_stationar_clexan_20mg=" & .patients_stationar_clexan_20mg & "," & _

-            "patients_stationar_clexan_40mg=" & .patients_stationar_clexan_40mg & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open UpdateSQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function dbGetAll_Hir_RecordsbyLPU_ID(dbConnection As Object, allHir() As tHIRURGIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Hir_SQL As String

-    Dim getAll_Hir_SQL As String

-    Dim Hir_Count As Long

-    Hir_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Hir_SQL = "SELECT COUNT(*) AS HIR_TOTAL FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Hir_SQL = "SELECT * FROM lpu_hir WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Hir_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Hir_Count = dbRecordset("HIR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Hir_RecordsbyLPU_ID = Hir_Count

-    

-    If Hir_Count > 0 Then

-        'we have records

-        ReDim allHir(1 To Hir_Count)

-        Dim index As Integer

-        index = 1

-        dbRecordset.Open getAll_Hir_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpHir As tHIRURGIA

-                 With tmpHir

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .operations_per_quarter = dbRecordset("operations_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_ambulator_clexan_20mg = dbRecordset("patients_ambulator_clexan_20mg")

-                    .patients_ambulator_clexan_40mg = dbRecordset("patients_ambulator_clexan_40mg")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                    .patients_stationar_clexan_20mg = dbRecordset("patients_stationar_clexan_20mg")

-                    .patients_stationar_clexan_40mg = dbRecordset("patients_stationar_clexan_40mg")

-                 End With

-                 

-                 allHir(index) = tmpHir

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Hir_Record(dbConnection As Object, ByRef objHir As tHIRURGIA)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE ID=" & objHir.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Hir_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Hir_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_hir " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-dbTer
->>>>>>
-Attribute VB_Name = "dbTer"

-Option Explicit

-

-Public Type tTERAPIA

-    id As Long

-    entry_date As String

-    lpu_id As Long

-    patients_per_quarter As Integer

-    risk_percent As Single

-    patients_with_risk_ON As Integer

-    patients_ambulator As Integer

-    patients_ambulator_nmg As Integer

-    patients_ambulator_clexan As Integer

-    patients_stationar_nmg As Integer

-    patients_stationar_clexan As Integer

-End Type

-

-' if objTer.ID <> 0 then updatre else insert

-Sub Insert_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objTer.id <> 0 Then

-        dbUpdate_Ter_Record dbConnection, objTer

-    Else

-        dbInsert_Ter_Record dbConnection, objTer

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-Function GetAll_Ter_RecordsByLPU_ID(ByRef allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_Ter_RecordsByLPU_ID = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, allTer, lpu_id, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_Ter_Record(ByRef objTer As tTERAPIA)

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_Ter_Record dbConnection, objTer

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objTer.ID <> 0 then updatre else insert

-

-Sub dbInsert_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "lpu_ter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objTer

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("LPU_ID") = .lpu_id

-        dbRecordset("patients_per_quarter") = .patients_per_quarter

-        dbRecordset("risk_percent") = Double2Str(.risk_percent, 3)

-        dbRecordset("patients_with_risk_ON") = .patients_with_risk_ON

-        dbRecordset("patients_ambulator") = .patients_ambulator

-        dbRecordset("patients_ambulator_nmg") = .patients_ambulator_nmg

-        dbRecordset("patients_ambulator_clexan") = .patients_ambulator_clexan

-        dbRecordset("patients_stationar_nmg") = .patients_stationar_nmg

-        dbRecordset("patients_stationar_clexan") = .patients_stationar_clexan

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objTer.id = dbRecordset("ID")

-

-End Sub

-

-Sub test()

-    Dim s As String

-    Dim d As Single

-    d = 1235.6789

-    s = Format(d, "####0,00")

-    MsgBox s

-End Sub

-

-Sub dbUpdate_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    Dim Update_SQL As String

-    

-    With objTer

-        Update_SQL = "UPDATE lpu_ter SET " & _

-            "entry_date='" & .entry_date & "'," & _

-            "LPU_ID=" & .lpu_id & "," & _

-            "patients_per_quarter=" & .patients_per_quarter & "," & _

-            "risk_percent=" & Double2Str(.risk_percent, 3) & "," & _

-            "patients_with_risk_ON=" & .patients_with_risk_ON & "," & _

-            "patients_ambulator=" & .patients_ambulator & "," & _

-            "patients_ambulator_nmg=" & .patients_ambulator_nmg & "," & _

-            "patients_ambulator_clexan=" & .patients_ambulator_clexan & "," & _

-            "patients_stationar_nmg=" & .patients_stationar_nmg & "," & _

-            "patients_stationar_clexan=" & .patients_stationar_clexan & _

-            " WHERE ID=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if LPU_ID = -1 then return all records for any LPU

-' if ent_date = "%" then return all records for any ent_date

-

-Function dbGetAll_Ter_RecordsbyLPU_ID(dbConnection As Object, allTer() As tTERAPIA, lpu_id As Long, ent_date As String) As Integer

-    

-    Dim getCount_Ter_SQL As String

-    Dim getAll_Ter_SQL As String

-    Dim Ter_Count As Long

-    Ter_Count = 0

-    

-    If lpu_id = -1 Then

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE entry_date like '" & ent_date & "'"

-    Else

-        getCount_Ter_SQL = "SELECT COUNT(*) AS TER_TOTAL FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-        getAll_Ter_SQL = "SELECT * FROM lpu_ter WHERE LPU_ID=" & lpu_id & " AND entry_date like '" & ent_date & "'"

-    End If

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_Ter_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        Ter_Count = dbRecordset("TER_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_Ter_RecordsbyLPU_ID = Ter_Count

-    

-    If Ter_Count > 0 Then

-        'we have records

-        ReDim allTer(1 To Ter_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_Ter_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmpTer As tTERAPIA

-                 With tmpTer

-                    .entry_date = dbRecordset("entry_date")

-                    .lpu_id = dbRecordset("LPU_ID")

-                    .id = dbRecordset("ID")

-                    .patients_per_quarter = dbRecordset("patients_per_quarter")

-                    .risk_percent = dbRecordset("risk_percent")

-                    .patients_with_risk_ON = dbRecordset("patients_with_risk_ON")

-                    .patients_ambulator = dbRecordset("patients_ambulator")

-                    .patients_ambulator_nmg = dbRecordset("patients_ambulator_nmg")

-                    .patients_ambulator_clexan = dbRecordset("patients_ambulator_clexan")

-                    .patients_stationar_nmg = dbRecordset("patients_stationar_nmg")

-                    .patients_stationar_clexan = dbRecordset("patients_stationar_clexan")

-                 End With

-                 

-                 allTer(index) = tmpTer

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_Ter_Record(dbConnection As Object, ByRef objTer As tTERAPIA)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE ID=" & objTer.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByLPU_ID(dbConnection As Object, ByVal lpu_id As Long)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM lpu_ter " & _

-    "WHERE LPU_ID=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-End Sub

-

-' Called from dbLPU

-Public Sub dbDelete_Ter_RecordsByQTR_LPU(dbConnection As Object, lpu_id As Long, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "' AND lpu_id=" & lpu_id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-' Called from dbQTR

-Public Sub dbDelete_Ter_RecordsByQTR(dbConnection As Object, ByVal ent_date As String)

-    

-    Dim DeleteSQL As String

-    

-    DeleteSQL = "DELETE FROM lpu_ter " & _

-    "WHERE entry_date='" & ent_date & "'"

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open DeleteSQL, dbConnection

-       

-End Sub

-

-

-<<<<<<
-======================
-mLPU_LIST
->>>>>>
-Attribute VB_Name = "mLPU_LIST"

-Option Explicit

-

-Public Const CINP_AREA As String = "B12"

-Public Const CLPU_NAME As Integer = 0

-Public Const CLPU_NAME1 As Integer = 1

-Public Const CLPU_NAME2 As Integer = 2

-Public Const CLPU_ID As Integer = 3

-Public Const CLPU_BEDS As Integer = 4

-Public Const CLPU_NFG As Integer = 5

-Public Const CLPU_NMG As Integer = 6

-Public Const CLPU_HIR As Integer = 7

-Public Const CLPU_TER As Integer = 8

-Public Const CLPU_CAR As Integer = 9

-Public Const CLPU_FACT As Integer = 10

-Public Const CLPU_PLAN As Integer = 11

-Public Const CLPU_PAT_LPU As Integer = 16

-Public Const CLPU_BDGT As Integer = 17

-Public Const CLPU_PAT_ALL As Integer = 16

-

-

-

-Sub EditLPU(cLPU As tLPU, ent_date As String)

-    Dim del_request As Integer

-    Dim allLPU() As tLPU

-    Dim lpu_count As Integer

-    Dim i As Integer

-    Dim tmp_LPU_List As Range

-    Dim tmp_LPU_List_Addr As String

-    Dim r_end As Range

-    Dim dlg As Dlg_lpu_card

-    

-    Set dlg = New Dlg_lpu_card

-    

-    lpu_count = GetAllLPU(allLPU)

-    With Worksheets(VAR_SHEET)

-        Set tmp_LPU_List = .Range("tmp_LPU_List")

-        Set r_end = .Range(tmp_LPU_List, tmp_LPU_List.End(xlDown))

-        Set r_end = .Range(r_end, r_end.End(xlToRight))

-        .Range(tmp_LPU_List, r_end).ClearContents

-    End With

-        

-    If lpu_count <> 0 Then

-        dlg.cbxLPU_List_Enable.Enabled = True

-        For i = 1 To UBound(allLPU)

-            tmp_LPU_List.Cells(i, 1) = allLPU(i).name

-            tmp_LPU_List.Cells(i, 2) = allLPU(i).address

-            tmp_LPU_List.Cells(i, 3) = allLPU(i).beds

-            tmp_LPU_List.Cells(i, 4) = allLPU(i).id

-        Next i

-    Else

-        dlg.cbxLPU_List_Enable.Enabled = False

-    End If

-    

-    tmp_LPU_List_Addr = Worksheets(VAR_SHEET).name & "!" & _

-            Worksheets(VAR_SHEET).Range(tmp_LPU_List, tmp_LPU_List.End(xlDown)).address

-

-    With dlg

-        .cbLPU_List.RowSource = tmp_LPU_List_Addr

-        .cbLPU_List.ListIndex = 0

-        .cbxLPU_List_Enable = False

-        .cbLPU_List.Enabled = False

-        If cLPU.id <> 0 Then

-            .cbxLPU_List_Enable.Enabled = False

-        Else

-            If lpu_count <> 0 Then

-                .cbxLPU_List_Enable.Enabled = True

-            Else

-                .cbxLPU_List_Enable.Enabled = False

-            End If

-        End If

-        .tb_lpu_name.Text = cLPU.name

-        .tb_lpu_address.Text = cLPU.address

-        .tbBedsCount = cLPU.beds

-

-        .Tag = vbCancel

-    End With

-    

-    dlg.Show

-    

-    If Not IsNumeric(dlg.Tag) Then

-        Exit Sub

-    End If

-    

-    If dlg.Tag = vbOK Then

-        Dim n As Variant

-        Dim test As Integer

-        test = 0

-        n = dlg.tbBedsCount.Value

-        If Not IsNumeric(n) Then

-            test = 1

-        Else

-            If n = 0 Then

-                test = 1

-            End If

-        End If

-        If test = 0 Then

-            

-            cLPU.name = dlg.tb_lpu_name.Text

-            cLPU.address = dlg.tb_lpu_address.Text

-            cLPU.beds = dlg.tbBedsCount.Value

-                                    

-            If cLPU.name = "" Or cLPU.address = "" Then

-                test = 2

-            End If

-        End If

-        Select Case test

-            Case 0

-                If dlg.cbxLPU_List_Enable.Value = True Then

-                    cLPU.id = tmp_LPU_List.Cells(dlg.cbLPU_List.ListIndex + 1, 4)

-                End If

-                Insert_LPU_Record cLPU

-                ' Проверить наличие данных для ЛПУ в квартале

-                Dim bdgt As tBUDGET

-                bdgt = Get_BDGT_Record(cLPU.id, ent_date)

-                ' Записи нет: создать пустую запись в lpu_budget

-                If bdgt.id = 0 Then

-                    bdgt.lpu_id = cLPU.id

-                    bdgt.entry_date = ent_date

-                    Insert_BDGT_Record bdgt

-                End If

-            Case 1

-                MsgBox "Коечная мощьность измеряется числом более чем 1!", vbOKOnly, PROGRAM_NAME

-            Case 2

-                MsgBox "Наименование и адрес ЛПУ не должны быть пустыми!", vbOKOnly, PROGRAM_NAME

-        End Select

-    End If

-End Sub

-

-Sub Draw_BBL_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_LPU_BBL").Range("CHRT_BBL_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, 19) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, 19)

-            dst.Cells(i, 2) = src.Cells(i, 17)

-            dst.Cells(i, 3) = src.Cells(i, 18)

-            dst.Cells(i, 4) = src.Cells(i, 1)

-        End If

-    Next i

-

-End Sub

-

-Sub Draw_PIE_Chart()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PIE").Range("CHRT_PIE_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_FACT + 1)

-        End If

-    Next i

-End Sub

-

-Sub Draw_PAT_LPU()

-    Dim src As Range

-    Dim dst As Range

-    Dim i As Integer

-    Dim psum As Integer

-    Set src = Worksheets("LPU_LIST").Range("LPU_LIST_INPUT")

-    Set dst = Worksheets("CHRT_PAT_LPU").Range("CHRT_PAT_LPU_DATA")

-    

-    dst.ClearContents

-    

-    For i = 1 To src.Rows.Count

-        psum = 0

-        If src.Cells(i, CLPU_NAME + 1) <> 0 Then

-            dst.Cells(i, 1) = src.Cells(i, CLPU_NAME + 1)

-            dst.Cells(i, 2) = src.Cells(i, CLPU_HIR + 1)

-            psum = psum + src.Cells(i, CLPU_HIR + 1)

-            dst.Cells(i, 3) = src.Cells(i, CLPU_TER + 1)

-            psum = psum + src.Cells(i, CLPU_TER + 1)

-            dst.Cells(i, 4) = src.Cells(i, CLPU_CAR + 1)

-            psum = psum + src.Cells(i, CLPU_CAR + 1)

-            dst.Cells(i, 5) = src.Cells(i, CLPU_PAT_LPU + 1) - psum

-        End If

-    Next i

-End Sub

-

-Sub btLPU_DEL_IT()

-    Dim cLPU As tLPU

-    Dim ent_date As String

-    Dim delete_all As Integer

-    Dim dlg_del As dlg_LPU_delete

-    

-    With Worksheets("LPU_LIST")

-        ent_date = .Range("ent_date")

-        cLPU.id = .getCurrentLPU_ID()

-    End With

-    

-    If cLPU.id = 0 Then

-        MsgBox "Укажите удаляемый объект", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    cLPU = Get_LPU_Record(cLPU.id)

-    

-    Set dlg_del = New dlg_LPU_delete

-    With dlg_del

-        .chbDeleteQTR.Value = True

-        .chbDeleteAll.Value = False

-        .lComment = ent_date & ": Удаление ЛПУ '" _

-        & cLPU.name & "', расположенного по адресу:" _

-        & cLPU.address & "."

-        .Show

-        

-        If .Tag = vbOK Then

-            If .chbDeleteAll.Value Then

-                delete_all = _

-                    MsgBox("Все записи об ЛПУ с именем '" & cLPU.name & _

-                    "' будут удалены навсегда.", vbOK, PROGRAM_NAME)

-                If delete_all = vbOK Then

-                    Delete_LPU_Record cLPU

-                End If

-            Else

-                Delete_LPU_RecordQTR cLPU, ent_date

-            End If

-        End If

-    End With

-    

-    With ThisWorkbook

-        .Worksheets(TITLE_SHEET).Select

-        .Worksheets("LPU_LIST").Select

-    End With

-End Sub

-

-Sub btLPU_RET_IT()

-    With Worksheets("LPU_LIST")

-        .Range("ent_date") = ""

-        .Range("LAST_FOCUS") = ""

-        .Range("JUMP") = REP_QTR_SHEET

-    End With

-    ThisWorkbook.Worksheets(REP_QTR_SHEET).Activate

-End Sub

-

-

-Sub btLPU_LIST_DO_IT()

-    Dim i As Integer

-    Dim ent_date As String

-    Dim lpu_id As Long

-    

-    i = Worksheets(VAR_SHEET).Range("QTR_ACTION").Value

-    With Worksheets("LPU_LIST")

-        ent_date = .getEnt_date()

-        

-    

-        lpu_id = .getCurrentLPU_ID

-        If lpu_id <> 0 And i = 1 Then

-            lpu_id = 0

-        End If

-        If lpu_id = 0 Then

-            i = 1

-        End If

-        Select Case i

-            Case 1, 6

-                .SelectLPU_NAME lpu_id, ent_date

-                .Range("JUMP") = ""

-            Case 2

-                If lpu_id <> 0 Then

-                    .SelectLPU_BDGT lpu_id, ent_date

-                    .Range("JUMP") = "LPU_BDGT"

-                End If

-            Case 3

-                If lpu_id <> 0 Then

-                    .SelectLPU_HIR lpu_id, ent_date

-                    .Range("JUMP") = "LPU_CLSN_HIR"

-                End If

-            Case 4

-                If lpu_id <> 0 Then

-                    .SelectLPU_TER lpu_id, ent_date

-                    .Range("JUMP") = "LPU_CLSN_TER"

-                End If

-            Case 5

-                If lpu_id <> 0 Then

-                    .SelectLPU_C_ACS lpu_id, ent_date

-                    .Range("JUMP") = "LPU_CLSN_C_ACS"

-                End If

-        End Select

-    End With

-    

-    If Range("JUMP") <> "" Then

-        Dim s As String

-        s = Range("JUMP")

-        ThisWorkbook.Worksheets(s).Select

-    End If

-

-End Sub

-

-<<<<<<
-======================
-dbQTR
->>>>>>
-Attribute VB_Name = "dbQTR"

-Option Explicit

-

-Public Type tQTR

-    id As Long

-    entry_date As String

-    rep_id As Long

-    sale_plan As Long

-    ClxnH20mg As Long

-    ClxnH40mg As Long

-    ClxnT40mg As Long

-    ClxnC_IM As Long

-    ClxnC_ACS As Long

-End Type

-

-

-Function GetLastQTR_fromDB() As String

-    Dim dbConnection As Object

-    Dim getCount_QTR_SQL As String

-    Dim getLast_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter"

-    getLast_QTR_SQL = "SELECT MAX(entry_date) as ent_date FROM quarter"

-    

-    dbOpenConnection dbConnection

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    If QTR_Count > 0 Then

-        'we have records

-        dbRecordset.Open getLast_QTR_SQL, dbConnection

-        getLast_QTR_SQL = dbRecordset("ent_date")

-    Else

-        getLast_QTR_SQL = ""

-    End If

-    

-    GetLastQTR_fromDB = getLast_QTR_SQL

-    dbCloseConnection dbConnection

-End Function

-

-Sub Insert_QTR_Record(ByRef objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    If objQTR.id <> 0 Then

-        dbUpdate_QTR_Record dbConnection, objQTR

-    Else

-        dbInsert_QTR_Record dbConnection, objQTR

-    End If

-    dbCloseConnection dbConnection

-End Sub

-

-Function Get_QTR_Record(ent_date As String) As tQTR

-    Dim dbConnection As Object

-    Dim allQTR() As tQTR

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    i = dbGetAll_QTR_Records(dbConnection, allQTR, ent_date)

-    If i <> 0 Then

-        Get_QTR_Record = allQTR(1)

-    End If

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function GetAll_QTR_Records(ByRef All_QTR() As tQTR, ent_date As String) As Integer

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    GetAll_QTR_Records = dbGetAll_QTR_Records(dbConnection, All_QTR, ent_date)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Public Sub Delete_QTR_Record(ByRef objQTR As tQTR)

-    Dim dbConnection As Object

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    dbOpenConnection dbConnection

-    

-    dbDelete_QTR_Record dbConnection, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-

-' if objQTR.ID <> 0 then updatre else insert

-Sub dbInsert_QTR_Record(dbConnection As Object, ByRef objQTR As tQTR)

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    

-    dbRecordset.Open "quarter", dbConnection, 2, 2

-    dbRecordset.addnew

-    

-    With objQTR

-        dbRecordset("entry_date") = .entry_date

-        dbRecordset("sale_plan") = .sale_plan

-        dbRecordset("rep_id") = .rep_id

-        dbRecordset("ClxnH20mg") = .ClxnH20mg

-        dbRecordset("ClxnH40mg") = .ClxnH40mg

-        dbRecordset("ClxnT40mg") = .ClxnT40mg

-        dbRecordset("ClxnC_IM") = .ClxnC_IM

-        dbRecordset("ClxnC_ACS") = .ClxnC_ACS

-    End With

-    dbRecordset.Update

-    dbRecordset.MoveLast

-

-    'new ID

-    objQTR.id = dbRecordset("id")

-

-End Sub

-

-Sub dbUpdate_QTR_Record(dbConnection As Object, ByRef objQTR As tQTR)

-    Dim Update_SQL As String

-    

-    With objQTR

-        Update_SQL = "UPDATE quarter SET " & _

-            "entry_date='" & .entry_date & "'" & "," & _

-            "rep_id=" & .rep_id & "," & _

-            "sale_plan=" & .sale_plan & "," & _

-            "ClxnH20mg=" & .ClxnH20mg & "," & _

-            "ClxnH40mg=" & .ClxnH40mg & "," & _

-            "ClxnT40mg=" & .ClxnT40mg & "," & _

-            "ClxnC_IM=" & .ClxnC_IM & "," & _

-            "ClxnC_ACS=" & .ClxnC_ACS & _

-            " WHERE id=" & .id

-    End With

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Update_SQL, dbConnection

-End Sub

-

-' if ent_date = % then all_records

-Function dbGetAll_QTR_Records(dbConnection As Object, All_QTR() As tQTR, ent_date As String) As Integer

-    

-    Dim getCount_QTR_SQL As String

-    Dim getAll_QTR_SQL As String

-    Dim QTR_Count As Long

-    QTR_Count = 0

-    

-    getCount_QTR_SQL = "SELECT COUNT(*) AS QTR_TOTAL FROM quarter WHERE entry_date like '" & ent_date & "'"

-    getAll_QTR_SQL = "SELECT * FROM quarter WHERE entry_date like '" & ent_date & "' ORDER BY entry_date"

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open getCount_QTR_SQL, dbConnection

-    

-    If Not dbRecordset.BOF Then

-        QTR_Count = dbRecordset("QTR_TOTAL")

-    End If

-    

-    dbRecordset.Close

-    

-    dbGetAll_QTR_Records = QTR_Count

-    

-    If QTR_Count > 0 Then

-        'we have records

-        ReDim All_QTR(1 To QTR_Count)

-        Dim index As Long

-        index = 1

-        dbRecordset.Open getAll_QTR_SQL, dbConnection

-        

-        If Not dbRecordset.BOF Then

-             Do While Not dbRecordset.EOF

-                 Dim tmp_QTR As tQTR

-                 With tmp_QTR

-                    .entry_date = dbRecordset("entry_date")

-                    .rep_id = dbRecordset("rep_id")

-                    .sale_plan = dbRecordset("sale_plan")

-                    .ClxnH20mg = dbRecordset("ClxnH20mg")

-                    .ClxnH40mg = dbRecordset("ClxnH40mg")

-                    .ClxnT40mg = dbRecordset("ClxnT40mg")

-                    .ClxnC_IM = dbRecordset("ClxnC_IM")

-                    .ClxnC_ACS = dbRecordset("ClxnC_ACS")

-                    .id = dbRecordset("id")

-                 End With

-                 

-                 All_QTR(index) = tmp_QTR

-                 index = index + 1

-                 dbRecordset.MoveNext

-             Loop

-        End If

-    End If

-End Function

-

-Public Sub dbDelete_QTR_Record(dbConnection As Object, ByRef objQTR As tQTR)

-    

-    Dim Delete_SQL As String

-    

-    Delete_SQL = "DELETE FROM quarter " & _

-    "WHERE id=" & objQTR.id

-    

-    

-    Dim dbRecordset As Object

-    Set dbRecordset = CreateObject("ADODB.Recordset")

-    dbRecordset.Open Delete_SQL, dbConnection

-       

-    

-    'delete related budget entries

-    dbDelete_BDGT_RecordsByQTR dbConnection, objQTR.entry_date

-    dbDelete_Hir_RecordsByQTR dbConnection, objQTR.entry_date

-    dbDelete_Ter_RecordsByQTR dbConnection, objQTR.entry_date

-    dbDelete_ACS_RecordsByQTR dbConnection, objQTR.entry_date

-       

-End Sub

-<<<<<<
-======================
-cdbQTR
->>>>>>
-Attribute VB_Name = "cdbQTR"

-Option Explicit

-

-Public Type tQTR_COMMON

-    qtr As tQTR

-    i_lcd As Long           ' число ЛПУ в СПИСКЕ

-    lcd() As tLPU_COMMON    ' список ЛПУ

-    c_beds As Long          ' сумма коек

-    c_bdgt_NFG As Long      ' общий бюджет на НФГ

-    c_bdgt_NMG As Long      ' общий бюджет на НМГ

-    c_bdgt_LPU As Long      ' общий бюджет на гепарины

-    c_sale_PLAN As Long     ' план продаж репа

-    c_sale_ALL As Long      ' продажи

-    c_sale_HIR As Long      ' в хирургии

-    c_sale_TER  As Long     ' в терапии

-    c_sale_CRD  As Long     ' в кардиологии

-    c_pat_HIR   As Long     ' пациенты

-    c_pat_TER   As Long     '

-    c_pat_CRD   As Long     '

-    c_pat_ALL   As Long     '

-    c_pat_LPU   As Long     ' Всего операций

-End Type

-

-Function Get_QTR_CommonList(ByRef qcd() As tQTR_COMMON) As Long

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    Get_QTR_CommonList = dbGet_QTR_CommonList(dbConnection, qcd)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_QTR_CommonList(dbConnection As Object, ByRef qcd() As tQTR_COMMON) As Long

-    Dim i As Long

-    Dim j As Long

-    Dim allQTR() As tQTR

-    i = dbGetAll_QTR_Records(dbConnection, allQTR, "%")

-    dbGet_QTR_CommonList = i

-    If i > 0 Then

-        ReDim qcd(i)

-        For i = 1 To UBound(allQTR)

-            With qcd(i)

-                .qtr = allQTR(i)

-                .c_beds = 0

-                .c_bdgt_NFG = 0

-                .c_bdgt_NMG = 0

-                .c_bdgt_LPU = 0

-                .c_sale_PLAN = 0

-                .c_pat_HIR = 0

-                .c_pat_TER = 0

-                .c_pat_CRD = 0

-                .c_pat_ALL = 0

-                .c_sale_HIR = 0

-                .c_sale_TER = 0

-                .c_sale_CRD = 0

-                .c_sale_ALL = 0

-                .c_pat_LPU = 0

-                

-                j = dbGet_LPU_CommonQTR(dbConnection, .lcd, .qtr)

-                .i_lcd = j

-                If j > 0 Then

-                    For j = 1 To UBound(.lcd)

-                        .c_beds = .c_beds + .lcd(j).lpu.beds

-                        .c_bdgt_NFG = .c_bdgt_NFG + .lcd(j).bdgt.bdgt_NFG

-                        .c_bdgt_NMG = .c_bdgt_NMG + .lcd(j).bdgt.bdgt_NMG

-                        .c_bdgt_LPU = .c_bdgt_LPU + .lcd(j).bdgt_LPU

-                        .c_sale_PLAN = .c_sale_PLAN + .lcd(j).bdgt.sale_plan

-                        .c_pat_HIR = .c_pat_HIR + .lcd(j).pat_HIR

-                        .c_pat_TER = .c_pat_TER + .lcd(j).pat_TER

-                        .c_pat_CRD = .c_pat_CRD + .lcd(j).pat_CRD

-                        .c_pat_ALL = .c_pat_ALL + .lcd(j).pat_ALL

-                        .c_sale_HIR = .c_sale_HIR + .lcd(j).sale_HIR

-                        .c_sale_TER = .c_sale_TER + .lcd(j).sale_TER

-                        .c_sale_CRD = .c_sale_CRD + .lcd(j).sale_CRD

-                        .c_sale_ALL = .c_sale_ALL + .lcd(j).sale_ALL

-                        .c_pat_LPU = .c_pat_LPU + .lcd(j).pat_LPU

-                    Next j

-                    

-                End If

-            End With

-        Next i

-    End If

-End Function

-

-Function GetLastQtr() As String

-    Dim s As String

-    Dim r As Range

-    Set r = Worksheets(REP_QTR_SHEET).Range("REP_QTR_INPUT_DATA")

-    Do While r.Cells(1, 1) <> ""

-        s = r.Cells(1, 1)

-        Set r = r.Cells.Offset(1, 0)

-    Loop

-    GetLastQtr = s

-End Function

-

-Function GetNextQTR(ent_date As String) As String

-    Dim rd As Range

-    Dim idx As Integer

-    Dim b As Variant

-    Dim dlg As dlg_newQTR

-    Set dlg = New dlg_newQTR

-    

-    On Error GoTo l_exit

-    If ent_date = "" Then

-        Dim ir As Variant

-        idx = 0

-        dlg.Show

-        b = dlg.Tag

-            

-        If IsNumeric(b) Then

-            GetNextQTR = dlg.cbQTR

-        Else

-            GetNextQTR = ""

-        End If

-    Else

-        Set rd = Worksheets(VAR_SHEET).Range("Date_Lst")

-        idx = WorksheetFunction.Match(ent_date, rd, 0)

-        GetNextQTR = WorksheetFunction.index(rd, idx + 1, 1)

-    End If

-l_exit:

-End Function

-<<<<<<
-======================
-mRestView
->>>>>>
-Attribute VB_Name = "mRestView"

-Option Explicit

-

-Sub xlRestoreView()

-Attribute xlRestoreView.VB_Description = "Macro recorded 25.09.2003 by nick"

-Attribute xlRestoreView.VB_ProcData.VB_Invoke_Func = " \n14"

-    With Application

-        .CommandBars("Standard").Visible = True

-        .CommandBars("Formatting").Visible = True

-        .DisplayFormulaBar = True

-        .DisplayStatusBar = True

-        .DisplayCommentIndicator = xlCommentIndicatorOnly

-        .CellDragAndDrop = True

-        .EditDirectlyInCell = True

-    End With

-End Sub

-<<<<<<
-======================
-dlg_newQTR
->>>>>>
-Attribute VB_Name = "dlg_newQTR"

-Attribute VB_Base = "0{2FC04B4C-EB99-433E-ACDB-A920D02B9B5B}{777B85CC-ADE3-4188-94C8-9E07DA8B5076}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-<<<<<<
-======================
-mDec2TS
->>>>>>
-Attribute VB_Name = "mDec2TS"

-Option Explicit

-

-

-Function Dec2ThirtySix(Dec As Long) As String

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim idx As Integer

-    

-    ThirtySixStr = ""

-    

-    If Dec = 0 Then

-        ThirtySixStr = Mid(ThirtySixNumbers, 1, 1)

-    Else

-        While Dec <> 0

-            idx = Dec Mod ThirtySixBase

-            ThirtySixStr = Mid(ThirtySixNumbers, idx + 1, 1) + ThirtySixStr

-            Dec = Dec \ ThirtySixBase

-        Wend

-    End If

-    Dec2ThirtySix = ThirtySixStr

-End Function

-

-Function ThirtySix2Dec(TS As String) As Long

-

-Const ThirtySixNumbers As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-Const ThirtySixBase As Integer = 36

-    

-    Dim ThirtySixStr As String

-    Dim lastdigit As String

-    Dim idx As Long

-    Dim idx_2 As Integer

-    Dim Dec As Long

-    

-    Dec = 0

-    idx_2 = 0

-    

-    If TS = "" Then

-        Dec = 0

-    Else

-        While TS <> ""

-            lastdigit = Right(TS, 1)

-            idx = InStr(1, ThirtySixNumbers, lastdigit)

-            Dec = Dec + (idx - 1) * ThirtySixBase ^ idx_2

-            idx_2 = idx_2 + 1

-            TS = Mid(TS, 1, Len(TS) - 1)

-        Wend

-    End If

-    ThirtySix2Dec = Dec

-End Function

-<<<<<<
-======================
-CHRT_LPU_BBL
->>>>>>
-Attribute VB_Name = "CHRT_LPU_BBL"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Unprotect

-    Range("view_key") = True

-    On Error Resume Next

-    ChangeLabels

-    Range("A1").Select

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Unprotect

-    Dim s As String

-    s = Range("ret_addr")

-    Protect UserInterfaceOnly:=True

-    Wks_select (s)

-End Sub

-

-Sub BCLabelChng_Click()

-    Unprotect

-    If Range("view_key") Then

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать названия"

-    Else

-        Shapes("BCLabelChng").DrawingObject.Caption = "Показать объемы"

-    End If

-    Range("view_key") = Not Range("view_key")

-    ChangeLabels

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Sub ChangeLabels()

-    Dim i As Integer

-    Dim offset_text As Integer

-    Dim src As Range

-    Set src = Range("CHRT_BBL_DATA")

-    

-    offset_text = 3

-    If Range("view_key") Then

-        offset_text = 4

-    End If

-    

-    On Error GoTo ExitLabel

-    

-    With ChartObjects(1).Chart

-        With .SeriesCollection(1)

-            For i = 1 To .Points.Count

-                On Error Resume Next

-                .Points(i).DataLabel.Characters.Text = Format(src.Cells(i, offset_text))

-            Next i

-        End With

-    End With

-ExitLabel:

-End Sub

-

-<<<<<<
-======================
-CHRT_PAT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PAT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-<<<<<<
-======================
-CHRT_PAT_LPU
->>>>>>
-Attribute VB_Name = "CHRT_PAT_LPU"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_nextQTR
->>>>>>
-Attribute VB_Name = "dlg_nextQTR"

-Attribute VB_Base = "0{3F7D7D75-90F6-4829-9E24-CA5391BB2A03}{A1A0F296-0D28-4123-8E38-82FA6EE6F2EF}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Option Explicit

-

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-

-

-<<<<<<
-======================
-cdbLPU
->>>>>>
-Attribute VB_Name = "cdbLPU"

-Option Explicit

-

-Public Type tLPU_COMMON

-    lpu As tLPU

-    bdgt As tBUDGET

-    i_hir As Long

-    hir() As tHIRURGIA

-    i_ter As Long

-    ter() As tTERAPIA

-    i_ACS As Long

-    ACS() As tACS

-    bdgt_LPU As Long

-    sale_HIR As Long

-    sale_TER As Long

-    sale_CRD As Long

-    sale_ALL As Long

-    pat_HIR As Long

-    pat_TER As Long

-    pat_CRD As Long

-    pat_ALL As Long     ' Сумма всех пациентов на клексане

-    pat_LPU As Long     ' Число потенциальных пациентов для продаж клексана

-End Type

-

-Function Get_LPU_CommonQTR(ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim dbConnection As Object

-    

-    dbOpenConnection dbConnection

-    

-    Get_LPU_CommonQTR = dbGet_LPU_CommonQTR(dbConnection, lcd, objQTR)

-    

-    dbCloseConnection dbConnection

-End Function

-

-Function dbGet_LPU_CommonQTR(dbConnection As Object, ByRef lcd() As tLPU_COMMON, ByRef objQTR As tQTR) As Long

-    Dim allLPU() As tLPU

-    Dim i As Long

-    

-    i = dbGetAllLPUbyQTR(dbConnection, allLPU, objQTR.entry_date)

-    dbGet_LPU_CommonQTR = i

-    If i > 0 Then

-        ReDim lcd(i)

-        For i = 1 To UBound(allLPU)

-            dbGet_LPU_Common dbConnection, lcd(i), allLPU(i), objQTR

-        Next i

-    End If

-End Function

-

-Sub Get_LPU_Common(ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-    Dim dbConnection As Object

-    dbOpenConnection dbConnection

-    

-    dbGet_LPU_Common dbConnection, lcd, cLPU, objQTR

-    

-    dbCloseConnection dbConnection

-End Sub

-

-Sub dbGet_LPU_Common(dbConnection As Object, ByRef lcd As tLPU_COMMON, cLPU As tLPU, objQTR As tQTR)

-

-    lcd.lpu = cLPU

-    lcd.bdgt = dbGet_BDGT_Record(dbConnection, cLPU.id, objQTR.entry_date)

-    lcd.i_hir = dbGetAll_Hir_RecordsbyLPU_ID(dbConnection, lcd.hir, cLPU.id, objQTR.entry_date)

-    lcd.i_ter = dbGetAll_Ter_RecordsbyLPU_ID(dbConnection, lcd.ter, cLPU.id, objQTR.entry_date)

-    lcd.i_ACS = dbGetAll_ACS_RecordsbyLPU_ID(dbConnection, lcd.ACS, cLPU.id, objQTR.entry_date)

-    With lcd

-        .bdgt_LPU = .bdgt.bdgt_NFG + .bdgt.bdgt_NMG

-        .pat_LPU = 0

-        If .i_hir > 0 Then

-            .pat_HIR = .hir(1).patients_ambulator_clexan + .hir(1).patients_stationar_clexan

-            .sale_HIR = objQTR.ClxnH20mg * (.hir(1).patients_ambulator_clexan_20mg + .hir(1).patients_stationar_clexan_20mg)

-            .sale_HIR = .sale_HIR + objQTR.ClxnH40mg * (.hir(1).patients_ambulator_clexan_40mg + .hir(1).patients_stationar_clexan_40mg)

-            .pat_LPU = .pat_LPU + .hir(1).operations_per_quarter

-        End If

-        If .i_ter > 0 Then

-            .pat_TER = .ter(1).patients_ambulator_clexan + .ter(1).patients_stationar_clexan

-            .sale_TER = .pat_TER * objQTR.ClxnT40mg

-            .pat_LPU = .pat_LPU + .ter(1).patients_per_quarter

-        End If

-        If .i_ACS > 0 Then

-            .pat_CRD = .ACS(1).patients_stationar_clexan

-            .sale_CRD = .pat_CRD * objQTR.ClxnC_ACS

-            .pat_LPU = .pat_LPU + .ACS(1).patients_per_quarter

-        End If

-        .pat_ALL = .pat_HIR + .pat_TER + .pat_CRD

-        .sale_ALL = .sale_HIR + .sale_TER + .sale_CRD

-    End With

-End Sub

-

-<<<<<<
-======================
-CHRT_PIE
->>>>>>
-Attribute VB_Name = "CHRT_PIE"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-   

-    Unprotect

-    On Error Resume Next

-    Range("P5:Q24").Sort _

-        Key1:=Range("Q5"), _

-        Order1:=xlDescending, _

-        Header:=xlGuess, _

-        OrderCustom:=1, _

-        MatchCase:=False, _

-        Orientation:=xlTopToBottom

-        

-    Protect UserInterfaceOnly:=True

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Range("A1").Select

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_PLN_QTR
->>>>>>
-Attribute VB_Name = "CHRT_PLN_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-CHRT_BDGT_QTR
->>>>>>
-Attribute VB_Name = "CHRT_BDGT_QTR"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-Option Explicit

-

-Private Sub Worksheet_Activate()

-    Range("A1").Select

-End Sub

-

-Private Sub Worksheet_SelectionChange(ByVal Target As Range)

-    Worksheet_Activate

-End Sub

-

-Sub Done()

-    Dim s As String

-    s = Range("ret_addr")

-    Wks_select (s)

-End Sub

-

-<<<<<<
-======================
-dlg_LPU_delete
->>>>>>
-Attribute VB_Name = "dlg_LPU_delete"

-Attribute VB_Base = "0{91AE5FA0-01C7-4C10-9E5F-D1D2DDF29401}{5726592A-BC0A-4E79-A963-35D354045716}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dlg_Mail
->>>>>>
-Attribute VB_Name = "dlg_Mail"

-Attribute VB_Base = "0{FB055133-927F-41FF-BC90-442833A40591}{11BCAB43-1EDD-440B-AB0E-20CD6E42E11A}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = False

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = False

-Private Sub btCancel_Click()

-    Me.Hide

-    Me.Tag = vbCancel

-End Sub

-

-Private Sub btOk_Click()

-    Me.Hide

-    Me.Tag = vbOK

-End Sub

-<<<<<<
-======================
-dbREP_id
->>>>>>
-Attribute VB_Name = "dbREP_id"

-Public Type tID_REP

-    id As Long

-    FirstName As String

-    LastName As String

-    Region As Integer

-    City As Integer

-End Type

-

-Public Type tID_REP_COMMON

-    id_rep As tID_REP

-    i_qtr As Long

-    qtrs As tQTR_COMMON

-End Type

-<<<<<<
-======================
-cdbExport
->>>>>>
-Attribute VB_Name = "cdbExport"

-Option Explicit

-

-Function GetDBSN() As String

-    Dim n As Long

-    Randomize Timer

-    n = Int((100000000 - 1000000 + 1) * Rnd + 1000000)

-    GetDBSN = Dec2ThirtySix(n)

-End Function

-

-Sub dbExport()

-    Dim src_file As String

-    Dim dst_file As String

-    Dim last_qtr As String

-    

-    On Error GoTo ErrHandler

-    

-    last_qtr = GetLastQTR_fromDB

-    If last_qtr = "" Then

-        MsgBox "Нет записей в базе данных. Экспорт невозможен.", vbOKOnly, PROGRAM_NAME

-        Exit Sub

-    End If

-    

-    src_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_FILENAME & PROGRAM_DATAEXT

-    dst_file = GetWBPath(ThisWorkbook.FullName) & PROGRAM_EXPORTNAME & last_qtr & "_" & GetDBSN() & PROGRAM_DATAEXT

-        

-    Dim fs

-    

-    Set fs = CreateObject("Scripting.FileSystemObject")

-    

-    fs.CopyFile src_file, dst_file

-    

-    If fs.FileExists(dst_file) Then

-        MsgBox "Данные экспортированы в файл:" & vbCrLf _

-                & dst_file & vbCrLf _

-                & "Используйте его для передачи", vbOKOnly, PROGRAM_NAME

-    Else

-        MsgBox "При экспорте возникла ошибка.", vbOKOnly, PROGRAM_NAME

-    End If

-

-Exit Sub

-

-ErrHandler:

-    If err.number <> 53 Then

-        MsgBox "Непредвиденная ошибка: " & err.Description

-    End If

-    Resume Next

-

-End Sub

-

-<<<<<<
-======================
-mRegs
->>>>>>
-Attribute VB_Name = "mRegs"

-Option Explicit

-

-Function GetRegionName(idx As Integer) As String

-    GetRegionName = Worksheets(REGS_SHEET).Range("LST_REGIONS").Cells(idx + 1, 1).Text

-End Function

-

-Function GetCityName(idx_reg As Integer, idx_city As Integer) As String

-    GetCityName = Worksheets(REGS_SHEET).Range("CITY_TABLES").Offset(idx_city + 1, idx_reg * 2).Text

-End Function

-

-Sub t()

-    Dim r As Integer

-    Dim c As Integer

-    Dim s As String

-    

-    r = 3

-    c = 3

-    s = GetRegionName(r)

-    s = s & ", " & GetCityName(r, c)

-    MsgBox s

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Sub Forecast()

-Attribute Forecast.VB_Description = "Macro recorded 06.12.2002 by nick"

-Attribute Forecast.VB_ProcData.VB_Invoke_Func = "f\n14"

-    With Selection

-        .Cells(1, 2).GoalSeek Goal:=1746, ChangingCell:=.Cells(1, 1)

-    End With

-End Sub

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet3
->>>>>>
-Attribute VB_Name = "Sheet3"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-

-Sub RandFill()

-Attribute RandFill.VB_ProcData.VB_Invoke_Func = "r\n14"

-    Selection.Formula = "=rand()"

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-

-Sub RandFill()

-Attribute RandFill.VB_ProcData.VB_Invoke_Func = "r\n14"

-    Selection.Formula = "=rand()"

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-

-Sub RandFill()

-Attribute RandFill.VB_ProcData.VB_Invoke_Func = "r\n14"

-    Selection.Formula = "=rand()"

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-Sub RandFill()

-    Selection.Formula = "=rand()"

-End Sub

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet6
->>>>>>
-Attribute VB_Name = "Sheet6"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-

-Sub RandFill()

-Attribute RandFill.VB_ProcData.VB_Invoke_Func = "r\n14"

-    Selection.Formula = "=rand()"

-End Sub

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-

-Sub RandFill()

-Attribute RandFill.VB_ProcData.VB_Invoke_Func = "r\n14"

-    Selection.Formula = "=rand()"

-End Sub

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet19
->>>>>>
-Attribute VB_Name = "Sheet19"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet18
->>>>>>
-Attribute VB_Name = "Sheet18"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet9
->>>>>>
-Attribute VB_Name = "Sheet9"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet12
->>>>>>
-Attribute VB_Name = "Sheet12"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet7
->>>>>>
-Attribute VB_Name = "Sheet7"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet13
->>>>>>
-Attribute VB_Name = "Sheet13"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet14
->>>>>>
-Attribute VB_Name = "Sheet14"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet15
->>>>>>
-Attribute VB_Name = "Sheet15"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet8
->>>>>>
-Attribute VB_Name = "Sheet8"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-

-Sub RandFill()

-    Selection.Formula = "=rand()"

-End Sub

-<<<<<<
-======================
-Sheet16
->>>>>>
-Attribute VB_Name = "Sheet16"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet17
->>>>>>
-Attribute VB_Name = "Sheet17"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-

-Sub RandFill()

-Attribute RandFill.VB_ProcData.VB_Invoke_Func = "r\n14"

-    Selection.Formula = "=rand()"

-End Sub

-

-<<<<<<
-======================
-Sheet21
->>>>>>
-Attribute VB_Name = "Sheet21"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-Sheet20
->>>>>>
-Attribute VB_Name = "Sheet20"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet10
->>>>>>
-Attribute VB_Name = "Sheet10"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet5
->>>>>>
-Attribute VB_Name = "Sheet5"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet11
->>>>>>
-Attribute VB_Name = "Sheet11"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Module1
->>>>>>
-Attribute VB_Name = "Module1"

-

-Sub RandFill()

-Attribute RandFill.VB_ProcData.VB_Invoke_Func = "r\n14"

-    Selection.Formula = "=rand()"

-End Sub

-

-<<<<<<
-Project Name : 'VBAProject'
-Quirk - duff tag length======================
-ThisWorkbook
->>>>>>
-Attribute VB_Name = "ThisWorkbook"

-Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet1
->>>>>>
-Attribute VB_Name = "Sheet1"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet2
->>>>>>
-Attribute VB_Name = "Sheet2"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-Sheet4
->>>>>>
-Attribute VB_Name = "Sheet4"

-Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"

-Attribute VB_GlobalNameSpace = False

-Attribute VB_Creatable = False

-Attribute VB_PredeclaredId = True

-Attribute VB_Exposed = True

-Attribute VB_TemplateDerived = False

-Attribute VB_Customizable = True

-<<<<<<
-======================
-ListFunc
->>>>>>
-Attribute VB_Name = "ListFunc"

-Option Explicit

-

-Function getEqClass(r As Range, ClRange As Range) As Integer

-    Dim i As Integer

-    For i = 1 To ClRange.Count

-        If r < ClRange.Cells(i) Then

-            getEqClass = i

-            Exit Function

-        End If

-    Next i

-End Function

-

-Function getClassLetter(Idx As Integer, ClNames As Range) As String

-    getClassLetter = ClNames.Cells(Idx)

-End Function

-

-Function GetEqLetter(r As Range, ClRange As Range, ClNames As Range) As String

-    GetEqLetter = getClassLetter(getEqClass(r, ClRange), ClNames)

-End Function

-<<<<<<